decl.c (gnat_to_gnu_param): Minor tweak.

	* 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.

From-SVN: r262495

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3ae83a70198ccb90461fb5b3e0576760707204e3..c5cf06c4cddf10ae9284d5ce2430bfe243aa5240 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-07-07  Eric Botcazou  <ebotcazou@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-06  Jim Wilson  <jimw@sifive.com>
 
        * Makefile.rtl: Add riscv*-linux* support.

diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 82a44922c18f8d3c116ac5d4f4bda6be504d50db..def48f169744a8e1ba96cfcc0dc47e22bed3bb67 100644 (file)
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -5228,7 +5228,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
             && 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, tree gnu_param_type, bool first,
          = 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_subprog, bool definition,
   /* 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_subprog, bool definition,
          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_subprog, bool definition,
       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);
 

diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index e456cc63373599895001109e692836a801a073a4..e0e5cfe4de2ac9d379058c2395db09829a76564d 100644 (file)
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -3330,6 +3330,9 @@ finish_subprog_decl (tree decl, tree asm_name, tree type)
   /* 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);
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f9a74ac6db7afdae88bc7db6ef8f9a1dc88fbff5..f8a33d809b38c71c3b58d5b5b0a207da4d44a694 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2018-07-07  Eric Botcazou  <ebotcazou@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.
+
 2018-07-07  Jakub Jelinek  <jakub@redhat.com>
 
        PR target/84711

diff --git a/gcc/testsuite/gnat.dg/pure_function3_pkg.ads b/gcc/testsuite/gnat.dg/pure_function3_pkg.ads
new file mode 100644 (file)
index 0000000..62ad9d2
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/pure_function3_pkg.ads
@@ -0,0 +1,14 @@
+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;

diff --git a/gcc/testsuite/gnat.dg/pure_function3a.adb b/gcc/testsuite/gnat.dg/pure_function3a.adb
new file mode 100644 (file)
index 0000000..879c6bc
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/pure_function3a.adb
@@ -0,0 +1,16 @@
+-- { 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" } }

diff --git a/gcc/testsuite/gnat.dg/pure_function3b.adb b/gcc/testsuite/gnat.dg/pure_function3b.adb
new file mode 100644 (file)
index 0000000..97e19fc
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/pure_function3b.adb
@@ -0,0 +1,18 @@
+-- { 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" } }

diff --git a/gcc/testsuite/gnat.dg/pure_function3c.adb b/gcc/testsuite/gnat.dg/pure_function3c.adb
new file mode 100644 (file)
index 0000000..0e3ec81
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/pure_function3c.adb
@@ -0,0 +1,16 @@
+-- { 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" } }