With GNAT you can declare a function as pure with a dedicated pragma, even if
it takes a parameter passed by reference. In this case, if the parameter is
declared as In (the default), the language additionally guarantees that it is
not modified, thus making the function also pure in the GCC sense.
Tested on x86-64/Linux, applied on the mainline.
2018-07-07 Eric Botcazou <ebotca...@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_param): Minor tweak.
(gnat_to_gnu_subprog_type): New pure_flag local variable. Set it for
a pure Ada function with a by-ref In parameter. Propagate it onto the
function type by means of the TYPE_QUAL_RESTRICT flag.
* gcc-interface/utils.c (finish_subprog_decl): Set DECL_PURE_P if the
function type has the TYPE_QUAL_RESTRICT flag set.
2018-07-07 Eric Botcazou <ebotca...@adacore.com>
* gnat.dg/pure_function3a.adb: New test.
* gnat.dg/pure_function3b.adb: Likewise.
* gnat.dg/pure_function3c.adb: Likewise.
* gnat.dg/pure_function3_pkg.ads: New helper.
--
Eric BotcazouIndex: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c (revision 262468)
+++ gcc-interface/decl.c (working copy)
@@ -5228,7 +5228,6 @@ gnat_to_gnu_param (Entity_Id gnat_param,
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
gnu_param_type = TREE_TYPE (gnu_param_type);
- by_component_ptr = true;
gnu_param_type = TREE_TYPE (gnu_param_type);
if (ro_param)
@@ -5236,6 +5235,7 @@ gnat_to_gnu_param (Entity_Id gnat_param,
= change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
gnu_param_type = build_pointer_type (gnu_param_type);
+ by_component_ptr = true;
}
/* Fat pointers are passed as thin pointers for foreign conventions. */
@@ -5561,14 +5561,15 @@ gnat_to_gnu_subprog_type (Entity_Id gnat
/* Fields in return type of procedure with copy-in copy-out parameters. */
tree gnu_field_list = NULL_TREE;
/* The semantics of "pure" in Ada essentially matches that of "const"
- in the back-end. In particular, both properties are orthogonal to
- the "nothrow" property if the EH circuitry is explicit in the
- internal representation of the back-end. If we are to completely
+ or "pure" in GCC. In particular, both properties are orthogonal
+ to the "nothrow" property if the EH circuitry is explicit in the
+ internal representation of the middle-end. If we are to completely
hide the EH circuitry from it, we need to declare that calls to pure
Ada subprograms that can throw have side effects since they can
- trigger an "abnormal" transfer of control flow; thus they can be
- neither "const" nor "pure" in the back-end sense. */
+ trigger an "abnormal" transfer of control flow; therefore, they can
+ be neither "const" nor "pure" in the GCC sense. */
bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog));
+ bool pure_flag = false;
bool return_by_direct_ref_p = false;
bool return_by_invisi_ref_p = false;
bool return_unconstrained_p = false;
@@ -5849,13 +5850,19 @@ gnat_to_gnu_subprog_type (Entity_Id gnat
gnu_param_list = chainon (gnu_param, gnu_param_list);
save_gnu_tree (gnat_param, gnu_param, false);
- /* If a parameter is a pointer, a function may modify memory through
- it and thus shouldn't be considered a const function. Also, the
- memory may be modified between two calls, so they can't be CSE'ed.
- The latter case also handles by-ref parameters. */
- if (POINTER_TYPE_P (gnu_param_type)
- || TYPE_IS_FAT_POINTER_P (gnu_param_type))
- const_flag = false;
+ /* A pure function in the Ada sense which takes an access parameter
+ may modify memory through it and thus need be considered neither
+ const nor pure in the GCC sense. Likewise it if takes a by-ref
+ In Out or Out parameter. But if it takes a by-ref In parameter,
+ then it may only read memory through it and can be considered
+ pure in the GCC sense. */
+ if ((const_flag || pure_flag)
+ && (POINTER_TYPE_P (gnu_param_type)
+ || TYPE_IS_FAT_POINTER_P (gnu_param_type)))
+ {
+ const_flag = false;
+ pure_flag = DECL_POINTS_TO_READONLY_P (gnu_param);
+ }
}
/* If the parameter uses the copy-in copy-out mechanism, allocate a field
@@ -6007,6 +6014,9 @@ gnat_to_gnu_subprog_type (Entity_Id gnat
if (const_flag)
gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
+ if (pure_flag)
+ gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_RESTRICT);
+
if (No_Return (gnat_subprog))
gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c (revision 262468)
+++ gcc-interface/utils.c (working copy)
@@ -3330,6 +3330,9 @@ finish_subprog_decl (tree decl, tree asm
/* Propagate the "const" property. */
TREE_READONLY (decl) = TYPE_READONLY (type);
+ /* Propagate the "pure" property. */
+ DECL_PURE_P (decl) = TYPE_RESTRICT (type);
+
/* Propagate the "noreturn" property. */
TREE_THIS_VOLATILE (decl) = TYPE_VOLATILE (type);
package Pure_Function3_Pkg is
type T is limited private;
function F (Self : T) return Integer with Pure_Function;
procedure Set (Self : in out T);
function F_And_Set (Self : in out T) return Integer with Pure_Function;
private
type T is limited record
F : Integer;
end record;
end Pure_Function3_Pkg;
-- { dg-do compile }
-- { dg-options "-O -gnatws -fdump-tree-optimized" }
with Pure_Function3_Pkg; use Pure_Function3_Pkg;
procedure Pure_Function3a is
V : T;
begin
if F (V) = 1 then
raise Program_Error;
elsif F (V) = 2 then
raise Program_Error;
end if;
end;
-- { dg-final { scan-tree-dump-times "pure_function3_pkg.f" 1 "optimized" } }
-- { dg-do compile }
-- { dg-options "-O -gnatws -fdump-tree-optimized" }
with Pure_Function3_Pkg; use Pure_Function3_Pkg;
procedure Pure_Function3b is
V : T;
begin
if F (V) = 1 then
raise Program_Error;
end if;
Set (V);
if F (V) = 2 then
raise Program_Error;
end if;
end;
-- { dg-final { scan-tree-dump-times "pure_function3_pkg.f" 2 "optimized" } }
-- { dg-do compile }
-- { dg-options "-O -gnatws -fdump-tree-optimized" }
with Pure_Function3_Pkg; use Pure_Function3_Pkg;
procedure Pure_Function3c is
V : T;
begin
if F_And_Set (V) = 1 then
raise Program_Error;
elsif F_And_Set (V) = 2 then
raise Program_Error;
end if;
end;
-- { dg-final { scan-tree-dump-times "pure_function3_pkg.f" 2 "optimized" } }
