diff mbox series

[Ada] Get finalization right when a function returns a function call

Message ID 20201015094002.GA67948@adacore.com
State New
Headers show
Series [Ada] Get finalization right when a function returns a function call | expand

Commit Message

Pierre-Marie de Rodat Oct. 15, 2020, 9:40 a.m. UTC 
When a function returns a function call, we want to avoid making an
unnecessary copy. This is particularly important because of a bug
which had the effect that when a copy was generated, the copied
object was never finalized. If, as in the case of the example for this
ticket, finalization was being used to reclaim storage, then this
lack of finalization introduced a storage leak. Other bugs uncovered
and fixed along the way included incorrect computation of the
Predicates_Ignored attribute (incorrect in two different ways) and
an incorrect implementation of the RM rule that, roughly speaking,
assertion policies are to be ignored in checking the legality of
a static expression.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

	* checks.adb (Apply_Predicate_Check): Generate "infinite
	recursion" warning message even if run-time predicate checking
	is disabled.
	* exp_ch6.adb (Expand_Simple_Function_Return): In testing
	whether the returned expression is a function call, look for the
	case where the call has been transformed into a dereference of
	an access value that designates the result of a function call.
	* sem_ch3.adb (Analyze_Object_Declaration): Legality checking
	for a static expression is unaffected by assertion policy (and,
	in particular, enabling/disabling of subtype predicates.  To get
	the right legality checking, we need to call
	Check_Expression_Against_Static_Predicate for a static
	expression even if predicate checking is disabled for the given
	predicate-bearing subtype.  On the other hand, we don't want to
	call Make_Predicate_Check unless predicate checking is enabled.
	* sem_ch7.adb (Uninstall_Declarations.Preserve_Full_Attributes):
	Preserve the Predicates_Ignored attribute.
	* sem_eval.adb (Check_Expression_Against_Static_Predicate):
	Previously callers ensured that this procedure was only called
	if predicate checking was enabled; that is no longer the case,
	so predicates-disabled case must be handled.
	* sem_prag.adb (Analyze_Pragma): Fix bug in setting
	Predicates_Ignored attribute in Predicate pragma case.
diff mbox series

Patch

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2744,13 +2744,9 @@  package body Checks is
       Par : Node_Id;
       S   : Entity_Id;
 
+      Check_Disabled : constant Boolean := (not Predicate_Enabled (Typ))
+        or else not Predicate_Check_In_Scope (N);
    begin
-      if not Predicate_Enabled (Typ)
-        or else not Predicate_Check_In_Scope (N)
-      then
-         return;
-      end if;
-
       S := Current_Scope;
       while Present (S) and then not Is_Subprogram (S) loop
          S := Scope (S);
@@ -2759,7 +2755,9 @@  package body Checks is
       --  If the check appears within the predicate function itself, it means
       --  that the user specified a check whose formal is the predicated
       --  subtype itself, rather than some covering type. This is likely to be
-      --  a common error, and thus deserves a warning.
+      --  a common error, and thus deserves a warning. We want to emit this
+      --  warning even if predicate checking is disabled (in which case the
+      --  warning is still useful even if it is not strictly accurate).
 
       if Present (S) and then S = Predicate_Function (Typ) then
          Error_Msg_NE
@@ -2774,9 +2772,15 @@  package body Checks is
                Parent (N), Typ);
          end if;
 
-         Insert_Action (N,
-           Make_Raise_Storage_Error (Sloc (N),
-             Reason => SE_Infinite_Recursion));
+         if not Check_Disabled then
+            Insert_Action (N,
+              Make_Raise_Storage_Error (Sloc (N),
+                Reason => SE_Infinite_Recursion));
+            return;
+         end if;
+      end if;
+
+      if Check_Disabled then
          return;
       end if;
 


diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -7318,6 +7318,13 @@  package body Exp_Ch6 is
       Exp : Node_Id := Expression (N);
       pragma Assert (Present (Exp));
 
+      Exp_Is_Function_Call : constant Boolean :=
+        Nkind (Exp) = N_Function_Call
+          or else (Nkind (Exp) = N_Explicit_Dereference
+                   and then Is_Entity_Name (Prefix (Exp))
+                   and then Ekind (Entity (Prefix (Exp))) = E_Constant
+                   and then Is_Related_To_Func_Return (Entity (Prefix (Exp))));
+
       Exp_Typ : constant Entity_Id := Etype (Exp);
       --  The type of the expression (not necessarily the same as R_Type)
 
@@ -7533,7 +7540,7 @@  package body Exp_Ch6 is
             Decl : Node_Id;
             Ent  : Entity_Id;
          begin
-            if Nkind (Exp) /= N_Function_Call
+            if not Exp_Is_Function_Call
               and then Has_Discriminants (Ubt)
               and then not Is_Constrained (Ubt)
               and then not Has_Unchecked_Union (Ubt)
@@ -7570,7 +7577,7 @@  package body Exp_Ch6 is
               (not Is_Array_Type (Exp_Typ)
                 or else Is_Constrained (Exp_Typ) = Is_Constrained (R_Type)
                 or else CW_Or_Has_Controlled_Part (Utyp))
-           and then Nkind (Exp) = N_Function_Call
+           and then Exp_Is_Function_Call
          then
             Set_By_Ref (N);
 


diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -4423,7 +4423,7 @@  package body Sem_Ch3 is
       --  the predicate still applies.
 
       if not Suppress_Assignment_Checks (N)
-        and then Predicate_Enabled (T)
+        and then (Predicate_Enabled (T) or else Has_Static_Predicate (T))
         and then
           (not No_Initialization (N)
             or else (Present (E) and then Nkind (E) = N_Aggregate))
@@ -4434,15 +4434,23 @@  package body Sem_Ch3 is
       then
          --  If the type has a static predicate and the expression is known at
          --  compile time, see if the expression satisfies the predicate.
+         --  In the case of a static expression, this must be done even if
+         --  the predicate is not enabled (as per static expression rules).
 
          if Present (E) then
             Check_Expression_Against_Static_Predicate (E, T);
          end if;
 
+         --  Do not perform further predicate-related checks unless
+         --  predicates are enabled for the subtype.
+
+         if not Predicate_Enabled (T) then
+            null;
+
          --  If the type is a null record and there is no explicit initial
          --  expression, no predicate check applies.
 
-         if No (E) and then Is_Null_Record_Type (T) then
+         elsif No (E) and then Is_Null_Record_Type (T) then
             null;
 
          --  Do not generate a predicate check if the initialization expression


diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -2725,6 +2725,7 @@  package body Sem_Ch7 is
          Set_Has_Pragma_Unreferenced_Objects
                                      (Priv, Has_Pragma_Unreferenced_Objects
                                                                        (Full));
+         Set_Predicates_Ignored      (Priv, Predicates_Ignored         (Full));
          if Is_Unchecked_Union (Full) then
             Set_Is_Unchecked_Union (Base_Type (Priv));
          end if;


diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -445,9 +445,11 @@  package body Sem_Eval is
          --  is folded, and since this is definitely a failure, extra checks
          --  are OK.
 
-         Insert_Action (Expr,
-           Make_Predicate_Check
-             (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
+         if Predicate_Enabled (Typ) then
+            Insert_Action (Expr,
+              Make_Predicate_Check
+                (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
+         end if;
       end if;
    end Check_Expression_Against_Static_Predicate;
 


diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -21201,9 +21201,7 @@  package body Sem_Prag is
             Set_Has_Delayed_Freeze (Typ);
 
             Set_Predicates_Ignored (Typ,
-              Present (Check_Policy_List)
-                and then
-                  Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
+              Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
             Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
          end Predicate;