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


git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@262495 138bc75d-0d04-0410-961f-82ee72b054a4

8 files changed, 106 insertions, 13 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3ae83a70198..c5cf06c4cdd 100644
--- 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 82a44922c18..def48f16974 100644
--- 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 e456cc63373..e0e5cfe4de2 100644
--- 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 f9a74ac6db7..f8a33d809b3 100644
--- 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
index 00000000000..62ad9d29105
--- /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
index 00000000000..879c6bc2b6c
--- /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
index 00000000000..97e19fcd2e4
--- /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
index 00000000000..0e3ec81d142
--- /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" } }