[Ada] Secondary stack leaks during object initialization

This patch modifies the transient scope mechanism to prevent secondary stack
leaks during object initialization. The modifications are as follows:

1) Prior to this change, the secondary stack was never managed within type
initialization procedures, for reasons unknown. It is speculated that the
controlled type model used at that time may have influenced this decision.
The secondary stack is now managed within type initialization procedures
in order to recover the memory once individual components or whole objects
are initialized.

2) A transient scope now delegates the secondary stack management to an
enclosing scope if there is no suitable context to wrap. This ensures that
the requirement to manage the secondary stack is not lost when the scope was
established for that purpose in mind.

3) A previous mechanism which examined the definition of a type (recursively)
to determine whether the type will involve the secondary stack was removed
because a) the mechanism could not detect this need with certainty, and b) the
trigger for secondary stack usage is now moved to the resolution of function
calls, which is always accurate.

------------
-- Source --
------------

--  types.ads

with Ada.Finalization; use Ada.Finalization;

package Types is
   type Ctrl is new Controlled with record
      Id : Integer;
   end record;

   procedure Initialize (Obj : in out Ctrl);

   function Make_Ctrl return Ctrl;
   function Make_Ctrl_From (Obj : Ctrl) return Ctrl;

   type Constr is array (1 .. 3) of Ctrl;
   type Unconstr is array (Integer range <>) of Ctrl;

   function Make_Constr return Constr;
   function Make_Unconstr (Low : Integer; High : Integer) return Unconstr;

   type Rec_1 is new Controlled with record
      Comp : Ctrl := Make_Ctrl;
   end record;

   type Rec_2 is new Controlled with record
      Comp : Ctrl := Make_Ctrl_From (Make_Ctrl);
   end record;

   type Rec_3 is new Controlled with record
      Comp : Constr := Make_Constr;
   end record;

   type Rec_4 is new Controlled with record
      Comp : Unconstr (1 .. 3) := Make_Unconstr (1, 3);
   end record;

   type Rec_5 is record
      Comp : Integer := 1 + Make_Ctrl.Id;
   end record;

   type Rec_6 is record
      Comp : Boolean := (for all X in 1 .. Make_Ctrl.Id =>
                           X = Make_Ctrl.Id);
   end record;
end Types;

--  types.adb

package body Types is
   Id_Gen : Integer := 0;

   procedure Initialize (Obj : in out Ctrl) is
   begin
      Id_Gen := Id_Gen + 1;
      Obj.Id := Id_Gen;
   end Initialize;

   function Make_Constr return Constr is
      Result : constant Constr := (others => Make_Ctrl);
   begin
      return Result;
   end Make_Constr;

   function Make_Ctrl return Ctrl is
      Result : Ctrl;
   begin
      return Result;
   end Make_Ctrl;

   function Make_Ctrl_From (Obj : Ctrl) return Ctrl is
      Result : Ctrl;
   begin
      Result.Id := Obj.Id;
      return Result;
   end Make_Ctrl_From;

   function Make_Unconstr (Low : Integer; High : Integer) return Unconstr is
      Result : constant Unconstr (Low .. High) := (others => Make_Ctrl);
   begin
      return Result;
   end Make_Unconstr;
end Types;

--  maker.ads

generic
   type Obj_Typ is private;
procedure Maker (Count : Positive);

--  maker.adb

procedure Maker (Count : Positive) is
   procedure Create is
      Obj : Obj_Typ;
      pragma Warnings (Off, Obj);
   begin null; end Create;

begin
   for Iter in 1 .. Count loop
      Create;
   end loop;
end Maker;

--  leaks.adb

with Maker;
with Types; use Types;

with Maker;
with Types; use Types;

procedure Leaks is
   procedure Make_1 is new Maker (Rec_1);
   procedure Make_2 is new Maker (Rec_2);
   procedure Make_3 is new Maker (Rec_3);
   procedure Make_4 is new Maker (Rec_4);
   procedure Make_5 is new Maker (Rec_5);
   procedure Make_6 is new Maker (Rec_6);

begin
   Make_1 (5_000);
   Make_2 (5_000);
   Make_3 (5_000);
   Make_4 (5_000);
   Make_5 (5_000);
   Make_6 (5_000);
end Leaks;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q leaks.adb
$ valgrind ./leaks > leaks.txt 2>&1
$ grep -c "still reachable" leaks.txt
0

2018-01-11  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_aggr.adb (Convert_Aggr_In_Object_Decl): Update the call to
	Establish_Transient_Scope.
	(Convert_To_Assignments): Update the call to Establish_Transient_Scope.
	(Expand_Array_Aggregate): Update the call to Establish_Transient_Scope.
	* exp_ch6.adb (Expand_Call_Helper): Update the call to
	Establish_Transient_Scope.
	(Make_Build_In_Place_Call_In_Object_Declaration): Update the call to
	Establish_Transient_Scope.
	* exp_ch7.adb (Establish_Transient_Scope): Restructured. Delegate the
	management of the secondary stack to an enclosing scope if there is no
	suitable construct to wrap, and the transient scope was intended to
	manage the secondary stack.
	(Find_Node_To_Be_Wrapped): Restructured. A case_statement_alternative
	is a valid boundary for a transient expression which comes from the
	statements of the alternative, otherwise alternatives cannot be
	wrapped. Assignments of controlled objects which have controlled
	actions suppressed now stop the traversal as there is no point in
	looking for an enclosing construct. Add several N_xxx_Body choices to
	the termination conditions for completeness.
	* exp_ch7.ads (Establish_Transient_Scope): Update the parameter profile
	and the associated comment on usage.
	* exp_smem.adb (Add_Shared_Var_Lock_Procs): Update the call to
	Establish_Transient_Scope.
	(Add_Write_After): Update the call to Establish_Transient_Scope.
	* sem_res.adb (Check_Initialization_Call): Removed.
	(Resolve_Actuals): Account for additional cases where finalization
	actions are required by utilizing predicate Needs_Finalization rather
	than Is_Controlled.
	(Resolve_Call): Type initialization procedures can now utilize
	transient scopes to manage the secondary stack, thus preventing leaks
	during initialization.  Remove the previous kludgy algorithm which
	attempts to manage the secondary stack at the object creation site.

From-SVN: r256513

1 files changed, 27 insertions, 129 deletions

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index c4ed06f..a4d6a26 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -117,13 +117,6 @@ package body Sem_Res is
    --  an infinite recursion, and if so, outputs appropriate messages. Returns
    --  True if an infinite recursion is detected, and False otherwise.
 
-   procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
-   --  If the type of the object being initialized uses the secondary stack
-   --  directly or indirectly, create a transient scope for the call to the
-   --  init proc. This is because we do not create transient scopes for the
-   --  initialization of individual components within the init proc itself.
-   --  Could be optimized away perhaps?
-
    procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
    --  N is the node for a logical operator. If the operator is predefined, and
    --  the root type of the operands is Standard.Boolean, then a check is made
@@ -858,89 +851,6 @@ package body Sem_Res is
       return True;
    end Check_Infinite_Recursion;
 
-   -------------------------------
-   -- Check_Initialization_Call --
-   -------------------------------
-
-   procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
-      Typ : constant Entity_Id := Etype (First_Formal (Nam));
-
-      function Uses_SS (T : Entity_Id) return Boolean;
-      --  Check whether the creation of an object of the type will involve
-      --  use of the secondary stack. If T is a record type, this is true
-      --  if the expression for some component uses the secondary stack, e.g.
-      --  through a call to a function that returns an unconstrained value.
-      --  False if T is controlled, because cleanups occur elsewhere.
-
-      -------------
-      -- Uses_SS --
-      -------------
-
-      function Uses_SS (T : Entity_Id) return Boolean is
-         Comp      : Entity_Id;
-         Expr      : Node_Id;
-         Full_Type : Entity_Id := Underlying_Type (T);
-
-      begin
-         --  Normally we want to use the underlying type, but if it's not set
-         --  then continue with T.
-
-         if not Present (Full_Type) then
-            Full_Type := T;
-         end if;
-
-         if Is_Array_Type (Full_Type) then
-            return Uses_SS (Component_Type (Full_Type));
-
-         elsif Is_Record_Type (Full_Type) then
-            Comp := First_Component (Full_Type);
-            while Present (Comp) loop
-               if Ekind (Comp) = E_Component
-                 and then Nkind (Parent (Comp)) = N_Component_Declaration
-               then
-                  --  The expression for a dynamic component may be rewritten
-                  --  as a dereference, so retrieve original node.
-
-                  Expr := Original_Node (Expression (Parent (Comp)));
-
-                  --  Return True if the expression is a call to a function
-                  --  (including an attribute function such as Image, or a
-                  --  user-defined operator) with a result that requires a
-                  --  transient scope.
-
-                  if (Nkind (Expr) = N_Function_Call
-                       or else Nkind (Expr) in N_Op
-                       or else (Nkind (Expr) = N_Attribute_Reference
-                                 and then Present (Expressions (Expr))))
-                    and then Requires_Transient_Scope (Etype (Expr))
-                  then
-                     return True;
-
-                  elsif Uses_SS (Etype (Comp)) then
-                     return True;
-                  end if;
-               end if;
-
-               Next_Component (Comp);
-            end loop;
-
-            return False;
-
-         else
-            return False;
-         end if;
-      end Uses_SS;
-
-   --  Start of processing for Check_Initialization_Call
-
-   begin
-      --  Establish a transient scope if the type needs it
-
-      if Uses_SS (Typ) then
-         Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
-      end if;
-   end Check_Initialization_Call;
-
    ---------------------------------------
    -- Check_No_Direct_Boolean_Operators --
    ---------------------------------------
@@ -3930,13 +3840,14 @@ package body Sem_Res is
             --  transient scope for it, so that it can receive the proper
             --  finalization list.
 
-            elsif Nkind (A) = N_Function_Call
+            elsif Expander_Active
+              and then Nkind (A) = N_Function_Call
               and then Is_Limited_Record (Etype (F))
               and then not Is_Constrained (Etype (F))
-              and then Expander_Active
-              and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
+              and then (Needs_Finalization (Etype (F))
+                         or else Has_Task (Etype (F)))
             then
-               Establish_Transient_Scope (A, Sec_Stack => False);
+               Establish_Transient_Scope (A, Manage_Sec_Stack => False);
                Resolve (A, Etype (F));
 
             --  A small optimization: if one of the actuals is a concatenation
@@ -3947,15 +3858,14 @@ package body Sem_Res is
             --  static string, and we want to preserve warnings involving
             --  sequences of such statements.
 
-            elsif Nkind (A) = N_Op_Concat
+            elsif Expander_Active
+              and then Nkind (A) = N_Op_Concat
               and then Nkind (N) = N_Procedure_Call_Statement
-              and then Expander_Active
-              and then
-                not (Is_Intrinsic_Subprogram (Nam)
-                      and then Chars (Nam) = Name_Asm)
+              and then not (Is_Intrinsic_Subprogram (Nam)
+                             and then Chars (Nam) = Name_Asm)
               and then not Static_Concatenation (A)
             then
-               Establish_Transient_Scope (A, Sec_Stack => False);
+               Establish_Transient_Scope (A, Manage_Sec_Stack => False);
                Resolve (A, Etype (F));
 
             else
@@ -3963,12 +3873,12 @@ package body Sem_Res is
                  and then Is_Array_Type (Etype (F))
                  and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
                  and then
-                  (Is_Limited_Type (Etype (F))
-                    or else Is_Limited_Type (Etype (Expression (A))))
+                   (Is_Limited_Type (Etype (F))
+                     or else Is_Limited_Type (Etype (Expression (A))))
                then
                   Error_Msg_N
-                    ("conversion between unrelated limited array types "
-                     & "not allowed ('A'I-00246)", A);
+                    ("conversion between unrelated limited array types not "
+                     & "allowed ('A'I-00246)", A);
 
                   if Is_Limited_Type (Etype (F)) then
                      Explain_Limited_Type (Etype (F), A);
@@ -4011,10 +3921,12 @@ package body Sem_Res is
                      --  enabled only, otherwise the transient scope will not
                      --  be removed in the expansion of the wrapped construct.
 
-                     if (Is_Controlled (DDT) or else Has_Task (DDT))
-                       and then Expander_Active
+                     if Expander_Active
+                       and then (Needs_Finalization (DDT)
+                                  or else Has_Task (DDT))
                      then
-                        Establish_Transient_Scope (A, Sec_Stack => False);
+                        Establish_Transient_Scope
+                          (A, Manage_Sec_Stack => False);
                      end if;
                   end;
 
@@ -6443,11 +6355,6 @@ package body Sem_Res is
       --  is already present. It may not be available if e.g. the subprogram is
       --  declared in a child instance.
 
-      --  If this is an initialization call for a type whose construction
-      --  uses the secondary stack, and it is not a nested call to initialize
-      --  a component, we do need to create a transient scope for it. We
-      --  check for this by traversing the type in Check_Initialization_Call.
-
       if Is_Inlined (Nam)
         and then Has_Pragma_Inline (Nam)
         and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
@@ -6463,26 +6370,17 @@ package body Sem_Res is
          null;
 
       elsif Expander_Active
-        and then Is_Type (Etype (Nam))
+        and then Ekind (Nam) = E_Function
         and then Requires_Transient_Scope (Etype (Nam))
-        and then
-          (not Within_Init_Proc
-            or else
-              (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function))
       then
-         Establish_Transient_Scope (N, Sec_Stack => True);
+         Establish_Transient_Scope (N, Manage_Sec_Stack => True);
 
-         --  If the call appears within the bounds of a loop, it will
-         --  be rewritten and reanalyzed, nothing left to do here.
+         --  If the call appears within the bounds of a loop, it will be
+         --  rewritten and reanalyzed, nothing left to do here.
 
          if Nkind (N) /= N_Function_Call then
             return;
          end if;
-
-      elsif Is_Init_Proc (Nam)
-        and then not Within_Init_Proc
-      then
-         Check_Initialization_Call (N, Nam);
       end if;
 
       --  A protected function cannot be called within the definition of the
@@ -7890,13 +7788,13 @@ package body Sem_Res is
             Set_Analyzed (N, True);
          end;
 
-      --  Protected functions can return on the secondary stack, in which
-      --  case we must trigger the transient scope mechanism.
+      --  Protected functions can return on the secondary stack, in which case
+      --  we must trigger the transient scope mechanism.
 
       elsif Expander_Active
         and then Requires_Transient_Scope (Etype (Nam))
       then
-         Establish_Transient_Scope (N, Sec_Stack => True);
+         Establish_Transient_Scope (N, Manage_Sec_Stack => True);
       end if;
    end Resolve_Entry_Call;