[Ada] Fix incorrect call to Pure function returning discriminated type

[Ada] Fix incorrect call to Pure function returning discriminated type

[Eric Botcazou]

[-- Attachment #1: Type: text/plain, Size: 713 bytes --]

This disables incorrect optimization (mainly CSE) of calls to Pure functions 
returning a discriminated record type.  These functions allocate their return 
value on the secondary stack and thus calls to them cannot be CSE'ed because 
the stack can be reclaimed in between.

Tested on x86_64-suse-linux, applied on the mainline.


2015-04-08  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Function>: Do not make
	a function returning an unconstrained type 'const' for the middle-end.


2015-04-08  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/opt48.adb: New test.
	* gnat.dg/opt48_pkg1.ad[sb]: New helper.
	* gnat.dg/opt48_pkg2.ad[sb]: Likewise.


-- 
Eric Botcazou

[-- Attachment #2: p.diff --]
[-- Type: text/x-patch, Size: 2285 bytes --]

Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 221915)
+++ gcc-interface/decl.c	(working copy)
@@ -4266,8 +4266,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 		return_by_direct_ref_p = true;
 	      }
 
-	    /* If we are supposed to return an unconstrained array type, make
-	       the actual return type the fat pointer type.  */
+	    /* If the return type is an unconstrained array type, the return
+	       value will be allocated on the secondary stack so the actual
+	       return type is the fat pointer type.  */
 	    else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
 	      {
 		gnu_return_type = TREE_TYPE (gnu_return_type);
@@ -4275,8 +4276,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	      }
 
 	    /* Likewise, if the return type requires a transient scope, the
-	       return value will be allocated on the secondary stack so the
-	       actual return type is the pointer type.  */
+	       return value will also be allocated on the secondary stack so
+	       the actual return type is the pointer type.  */
 	    else if (Requires_Transient_Scope (gnat_return_type))
 	      {
 		gnu_return_type = build_pointer_type (gnu_return_type);
@@ -4591,11 +4592,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 				 return_by_direct_ref_p,
 				 return_by_invisi_ref_p);
 
-	/* A subprogram (something that doesn't return anything) shouldn't
-	   be considered const since there would be no reason for such a
+	/* A procedure (something that doesn't return anything) shouldn't be
+	   considered const since there would be no reason for calling such a
 	   subprogram.  Note that procedures with Out (or In Out) parameters
-	   have already been converted into a function with a return type.  */
-	if (TREE_CODE (gnu_return_type) == VOID_TYPE)
+	   have already been converted into a function with a return type.
+	   Similarly, if the function returns an unconstrained type, then the
+	   function will allocate the return value on the secondary stack and
+	   thus calls to it cannot be CSE'ed, lest the stack be reclaimed.  */
+	if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
 	  const_flag = false;
 
 	if (const_flag || volatile_flag)

[-- Attachment #3: opt48.adb --]
[-- Type: text/x-adasrc, Size: 216 bytes --]

-- { dg-do run }
-- { dg-options "-O" }

with Opt48_Pkg1; use Opt48_Pkg1;
with Opt48_Pkg2; use Opt48_Pkg2;

procedure Opt48 is
begin
   if Get_Z /= (12, "Hello world!") then
      raise Program_Error;
   end if;
end;

[-- Attachment #4: opt48_pkg1.adb --]
[-- Type: text/x-adasrc, Size: 264 bytes --]

package body Opt48_Pkg1 is

   function G return Rec is
   begin
      return (32, "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA");
   end G;

   X : Rec := F;
   Y : Rec := G;
   Z : Rec := F;

   function Get_Z return Rec is
   begin
      return Z;
   end;

end Opt48_Pkg1;

[-- Attachment #5: opt48_pkg1.ads --]
[-- Type: text/x-adasrc, Size: 103 bytes --]

with Opt48_Pkg2; use Opt48_Pkg2;

package Opt48_Pkg1 is

   function Get_Z return Rec;

end Opt48_Pkg1;

[-- Attachment #6: opt48_pkg2.adb --]
[-- Type: text/x-adasrc, Size: 126 bytes --]

package body Opt48_Pkg2 is

   function F return Rec is
   begin
      return (12, "Hello world!");
   end F;

end Opt48_Pkg2;

[-- Attachment #7: opt48_pkg2.ads --]
[-- Type: text/x-adasrc, Size: 161 bytes --]

package Opt48_Pkg2 is

   pragma Pure;

   type Rec (L : Natural) is record
      S : String (1 .. L);
   end record;

   function F return Rec;

end Opt48_Pkg2;