[Ada] fix undue pessimization wrt Pure subprograms

[Ada] fix undue pessimization wrt Pure subprograms

[Olivier Hainque]

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

Hello,

We rediscussed the Ada language reference manual bits about "pragma
Pure" and decided to revisit the orientation taken in

   http://gcc.gnu.org/ml/gcc-patches/2008-08/msg00029.html

In particular, we are now of the opinion that

  << 18/2 If a library unit is declared pure, then the implementation is
          permitted to omit a call on a library-level subprogram of
          the library unit if the results are not needed after the call.
  >>

allows us to omit a call to a Pure subprogram possibly raising an
exception even if there is an exception handler, as in 

    procedure handle_raise_from_pure is
       K : Integer;
    begin
       K := Raise_CE_If_0 (0);
    exception
       when others => Put_Line ("exception caught");
    end;

This patch re-activates and tidies the code controling this, which
cures a regression in optimization opportunities.

Bootstrapped and regtested on x86_64-suse-linux.

Olivier

	2008-11-13  Olivier Hainque  <hainque@adacore.com>

	ada/
	* gcc-interface/decl.c (gnat_to_gnu_entity) <case E_Function>:
	Turn Ada Pure on subprograms back into GCC CONST when eh constructs
	are explicit to the back-end.  Tidy.

	testsuite/
	* gnat.dg/test_raise_from_pure.adb: Adjust to match revised intent.
	* gnat.dg/wrap_raise_from_pure.ad[bs]: Remove.
	* gnat.dg/handle_raise_from_pure.adb: New test.


[-- Attachment #2: pure-const.dif --]
[-- Type: text/plain, Size: 6200 bytes --]

Index: ada/gcc-interface/decl.c
===================================================================
*** ada/gcc-interface/decl.c	(revision 141734)
--- ada/gcc-interface/decl.c	(working copy)
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 3739,3745 ****
  	bool public_flag = Is_Public (gnat_entity) || imported_p;
  	bool extern_flag
  	  = (Is_Public (gnat_entity) && !definition) || imported_p;
! 	bool pure_flag = Is_Pure (gnat_entity);
  	bool volatile_flag = No_Return (gnat_entity);
  	bool returns_by_ref = false;
  	bool returns_unconstrained = false;
--- 3739,3757 ----
  	bool public_flag = Is_Public (gnat_entity) || imported_p;
  	bool extern_flag
  	  = (Is_Public (gnat_entity) && !definition) || imported_p;
! 
!        /* 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
!           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.  */
! 	bool const_flag
! 	  = (Exception_Mechanism == Back_End_Exceptions
! 	     && Is_Pure (gnat_entity));
! 
  	bool volatile_flag = No_Return (gnat_entity);
  	bool returns_by_ref = false;
  	bool returns_unconstrained = false;
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 3972,3983 ****
  
  		/* If a parameter is a pointer, this function may modify
  		   memory through it and thus shouldn't be considered
! 		   a pure 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_FAT_POINTER_P (gnu_param_type))
! 		  pure_flag = false;
  	      }
  
  	    if (copy_in_copy_out)
--- 3984,3995 ----
  
  		/* If a parameter is a pointer, this 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_FAT_POINTER_P (gnu_param_type))
! 		  const_flag = false;
  	      }
  
  	    if (copy_in_copy_out)
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 4054,4074 ****
  				   returns_by_ref, returns_by_target_ptr);
  
  	/* A subprogram (something that doesn't return anything) shouldn't
! 	   be considered Pure since there would be no reason for 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)
! 	  pure_flag = false;
! 
! 	/* The semantics of "pure" in Ada used to essentially match that of
! 	   "const" in the middle-end.  In particular, both properties were
! 	   orthogonal to the "nothrow" property.  This is not true in the
! 	   middle-end any more and we have no choice but to ignore the hint
! 	   at this stage.  */
  
  	gnu_type
  	  = build_qualified_type (gnu_type,
  				  TYPE_QUALS (gnu_type)
  				  | (TYPE_QUAL_VOLATILE * volatile_flag));
  
  	Sloc_to_locus (Sloc (gnat_entity), &input_location);
--- 4066,4081 ----
  				   returns_by_ref, returns_by_target_ptr);
  
  	/* A subprogram (something that doesn't return anything) shouldn't
! 	   be considered const since there would be no reason for 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)
! 	  const_flag = false;
  
  	gnu_type
  	  = build_qualified_type (gnu_type,
  				  TYPE_QUALS (gnu_type)
+ 				  | (TYPE_QUAL_CONST * const_flag)
  				  | (TYPE_QUAL_VOLATILE * volatile_flag));
  
  	Sloc_to_locus (Sloc (gnat_entity), &input_location);
*************** gnat_to_gnu_entity (Entity_Id gnat_entit
*** 4077,4084 ****
  	  gnu_stub_type
  	    = build_qualified_type (gnu_stub_type,
  				    TYPE_QUALS (gnu_stub_type)
! 				    | (Exception_Mechanism == Back_End_Exceptions
! 				       ? TYPE_QUAL_CONST * pure_flag : 0)
  				    | (TYPE_QUAL_VOLATILE * volatile_flag));
  
  	/* If we have a builtin decl for that function, check the signatures
--- 4084,4090 ----
  	  gnu_stub_type
  	    = build_qualified_type (gnu_stub_type,
  				    TYPE_QUALS (gnu_stub_type)
! 				    | (TYPE_QUAL_CONST * const_flag)
  				    | (TYPE_QUAL_VOLATILE * volatile_flag));
  
  	/* If we have a builtin decl for that function, check the signatures
Index: testsuite/gnat.dg/handle_raise_from_pure.adb
===================================================================
*** testsuite/gnat.dg/handle_raise_from_pure.adb	(revision 0)
--- testsuite/gnat.dg/handle_raise_from_pure.adb	(revision 0)
***************
*** 0 ****
--- 1,11 ----
+ --  { dg-do run }
+ --  { dg-options "-O2" }
+ with Ada.Text_Io; use Ada.Text_IO;
+ with Raise_From_Pure; use Raise_From_Pure;
+ procedure handle_raise_from_pure is
+    K : Integer;
+ begin
+    K := Raise_CE_If_0 (0);
+ exception
+    when others => Put_Line ("exception caught");
+ end;
Index: testsuite/gnat.dg/test_raise_from_pure.adb
===================================================================
*** testsuite/gnat.dg/test_raise_from_pure.adb	(revision 141259)
--- testsuite/gnat.dg/test_raise_from_pure.adb	(working copy)
***************
*** 1,9 ****
  --  { dg-do run }
  --  { dg-options "-O2" }
! with Wrap_Raise_From_Pure; use Wrap_Raise_From_Pure;
  procedure test_raise_from_pure is
  begin
!    Wrap_Raise_From_Pure.Check;
! exception
!    when Constraint_Error => null;
  end;
--- 1,8 ----
  --  { dg-do run }
  --  { dg-options "-O2" }
! with Raise_From_Pure; use Raise_From_Pure;
  procedure test_raise_from_pure is
+    K : Integer;
  begin
!    K := Raise_CE_If_0 (0);
  end;