[Ada] Premature secondary stack reclamation
authorHristian Kirtchev <kirtchev@adacore.com>
Mon, 21 May 2018 14:49:52 +0000 (14:49 +0000)
committerPierre-Marie de Rodat <pmderodat@gcc.gnu.org>
Mon, 21 May 2018 14:49:52 +0000 (14:49 +0000)
This patch modifies the creation of transient scopes to eliminate potential
premature secondary stack reclamations when there is no suitable transient
context and the scope was intended to manage the secondary stack. Instead,
the logic was changed to accommodate a special case where an assignment with
suppressed controlled actions that appears within a type initialization
procedure requires secondary stack reclamation.

The patch also corrects the handling of function calls which utilize the
secondary stack in loop parameter specifications. Previously the predicate
which determined whether the function will utilize the secondary stack was
not accurate enough, and in certain cases could lead to leaks.

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

--  iterators.ads

package Iterators is
   type Iterator is limited interface;
   type Iterator_Access is access all Iterator'Class;

   function Next
     (I       : in out Iterator;
      Element : out Character) return Boolean is abstract;

   procedure Iterate
     (I    : in out Iterator'Class;
      Proc : access procedure (Element : Character));
end Iterators;

--  iterators.adb

package body Iterators is
   procedure Iterate
     (I    : in out Iterator'Class;
      Proc : access procedure (Element : Character))
   is
      Element : Character;
   begin
      while I.Next (Element) loop
         Proc (Element);
      end loop;
   end Iterate;
end Iterators;

--  base.ads

with Iterators; use Iterators;

package Base is
   type String_Access is access all String;
   type Node is tagged record
      S : String_Access;
   end record;

   type Node_Access is access all Node'Class;
   type Node_Array is array (Positive range <>) of Node_Access;

   function As_Array (N : Node_Access) return Node_Array;
   function Get_String (C : Character) return String;

   type Node_Iterator is limited new Iterator with record
      Node : Node_Access;
      I    : Positive;
   end record;

   overriding function Next
     (It      : in out Node_Iterator;
      Element : out Character) return Boolean;

   function Constructor_1 (N : Node_Access) return Node_Iterator;
   function Constructor_2 (N : Node_Access) return Node_Iterator;
end Base;

--  base.adb

package body Base is
   function As_Array (N : Node_Access) return Node_Array is
   begin
      return (1 => N);
   end As_Array;

   function Get_String (C : Character) return String is
   begin
      return (1 .. 40 => C);
   end Get_String;

   function Next
     (It      : in out Node_Iterator;
      Element : out Character) return Boolean
   is
   begin
      if It.I > It.Node.S'Last then
         return False;
      else
         It.I := It.I + 1;
         Element := It.Node.S (It.I - 1);
         return True;
      end if;
   end Next;

   function Constructor_1 (N : Node_Access) return Node_Iterator is
   begin
      return Node_Iterator'(N, 1);
   end Constructor_1;

   function Constructor_2 (N : Node_Access) return Node_Iterator is
   begin
      return Constructor_1 (As_Array (N) (1));
   end Constructor_2;
end Base;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Base;        use Base;
with Iterators;   use Iterators;

procedure Main is
   N : constant Node_Access := new Node'(S => new String'("hello world"));

   procedure Process (C : Character) is
   begin
      Put_Line (Get_String (C));
   end Process;

   C : Iterator'Class := Constructor_2 (N);

begin
   C.Iterate (Process'Access);
end Main;

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

$ gnatmake -q main.adb
$ ./main
hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee
llllllllllllllllllllllllllllllllllllllll
llllllllllllllllllllllllllllllllllllllll
oooooooooooooooooooooooooooooooooooooooo

wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
oooooooooooooooooooooooooooooooooooooooo
rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
llllllllllllllllllllllllllllllllllllllll
dddddddddddddddddddddddddddddddddddddddd

2018-05-21  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

* exp_ch7.adb (Establish_Transient_Scope): Code cleanup. Do not
delegate the secondary stack management when there is no suitable
transient context, and the transient scope was intended to manage the
secondary stack because this causes premature reclamation. Change the
transient scope creation logic by special casing assignment statements
of controlled components for type initialization procedures.
(Find_Node_To_Be_Wrapped): Renamed to Find_Transient_Context. Update
the comment on usage.
(Find_Transient_Context): Change the initinte loop into a while loop.
Iterations schemes and iterator specifications are not valid transient
contexts because they rely on special processing. Assignment statements
are now treated as a normal transient context, special cases are
handled by the caller. Add special processing for pragma Check.
(Is_OK_Construct): Removed. Its functionality has been merged in
routine Find_Transient_Context.
* sem_ch5.adb (Check_Call): Reimplemented. Add code to properly
retrieve the subprogram being invoked. Use a more accurate predicate
(Requires_Transient_Scope) to determine that the function will emply
the secondary stack.

From-SVN: r260443

gcc/ada/ChangeLog
gcc/ada/exp_ch7.adb
gcc/ada/sem_ch5.adb

index 33500f334edc555439d0029af48448877f20e65f..e729f1851fe01cdbf75074ac67c177200dbc0e6f 100644 (file)
@@ -1,3 +1,25 @@
+2018-04-04  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_ch7.adb (Establish_Transient_Scope): Code cleanup. Do not
+       delegate the secondary stack management when there is no suitable
+       transient context, and the transient scope was intended to manage the
+       secondary stack because this causes premature reclamation. Change the
+       transient scope creation logic by special casing assignment statements
+       of controlled components for type initialization procedures.
+       (Find_Node_To_Be_Wrapped): Renamed to Find_Transient_Context. Update
+       the comment on usage.
+       (Find_Transient_Context): Change the initinte loop into a while loop.
+       Iterations schemes and iterator specifications are not valid transient
+       contexts because they rely on special processing. Assignment statements
+       are now treated as a normal transient context, special cases are
+       handled by the caller. Add special processing for pragma Check.
+       (Is_OK_Construct): Removed. Its functionality has been merged in
+       routine Find_Transient_Context.
+       * sem_ch5.adb (Check_Call): Reimplemented. Add code to properly
+       retrieve the subprogram being invoked. Use a more accurate predicate
+       (Requires_Transient_Scope) to determine that the function will emply
+       the secondary stack.
+
 2018-04-04  Piotr Trojanek  <trojanek@adacore.com>
 
        * ada_get_targ.adb: Fix subprogram body headers.
index e669454243431dff50e92ee224d39a31842cac57..9d1919ab6440ffc5781971a13d76215177004a71 100644 (file)
@@ -125,10 +125,10 @@ package body Exp_Ch7 is
    -- Transient Blocks and Finalization Management --
    --------------------------------------------------
 
-   function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
-   --  N is a node which may generate a transient scope. Loop over the parent
-   --  pointers of N until we find the appropriate node to wrap. If it returns
-   --  Empty, it means that no transient scope is needed in this context.
+   function Find_Transient_Context (N : Node_Id) return Node_Id;
+   --  Locate a suitable context for arbitrary node N which may need to be
+   --  serviced by a transient scope. Return Empty if no suitable context is
+   --  available.
 
    procedure Insert_Actions_In_Scope_Around
      (N         : Node_Id;
@@ -4082,10 +4082,6 @@ package body Exp_Ch7 is
       --  Examine the scope stack looking for the nearest enclosing transient
       --  scope. Return Empty if no such scope exists.
 
-      function Is_OK_Construct (Constr : Node_Id) return Boolean;
-      --  Determine whether arbitrary node Constr is a suitable construct which
-      --  requires handling by a transient scope.
-
       function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
       --  Determine whether arbitrary Id denotes a package or subprogram [body]
 
@@ -4224,40 +4220,6 @@ package body Exp_Ch7 is
          return Empty;
       end Find_Enclosing_Transient_Scope;
 
-      ---------------------
-      -- Is_OK_Construct --
-      ---------------------
-
-      function Is_OK_Construct (Constr : Node_Id) return Boolean is
-      begin
-         --  Nothing to do when there is no construct to consider
-
-         if No (Constr) then
-            return False;
-
-         --  Nothing to do when the construct is an iteration scheme or an Ada
-         --  2012 iterator because the expression is one of the bounds, and the
-         --  expansion will create an explicit declaration for it (see routine
-         --  Analyze_Iteration_Scheme).
-
-         elsif Nkind_In (Constr, N_Iteration_Scheme,
-                                 N_Iterator_Specification)
-         then
-            return False;
-
-         --  Nothing to do in formal verification mode when the construct is
-         --  pragma Check, because the pragma remains unexpanded.
-
-         elsif GNATprove_Mode
-           and then Nkind (Constr) = N_Pragma
-           and then Get_Pragma_Id (Constr) = Pragma_Check
-         then
-            return False;
-         end if;
-
-         return True;
-      end Is_OK_Construct;
-
       ------------------------------
       -- Is_Package_Or_Subprogram --
       ------------------------------
@@ -4274,8 +4236,8 @@ package body Exp_Ch7 is
 
       --  Local variables
 
-      Scop_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
-      Constr  : Node_Id;
+      Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
+      Context  : Node_Id;
 
    --  Start of processing for Establish_Transient_Scope
 
@@ -4283,13 +4245,13 @@ package body Exp_Ch7 is
       --  Do not create a new transient scope if there is an existing transient
       --  scope on the stack.
 
-      if Present (Scop_Id) then
+      if Present (Trans_Id) then
 
          --  If the transient scope was requested for purposes of managing the
          --  secondary stack, then the existing scope must perform this task.
 
          if Manage_Sec_Stack then
-            Set_Uses_Sec_Stack (Scop_Id);
+            Set_Uses_Sec_Stack (Trans_Id);
          end if;
 
          return;
@@ -4299,18 +4261,41 @@ package body Exp_Ch7 is
       --  scopes. Locate the proper construct which must be serviced by a new
       --  transient scope.
 
-      Constr := Find_Node_To_Be_Wrapped (N);
+      Context := Find_Transient_Context (N);
 
-      if Is_OK_Construct (Constr) then
-         Create_Transient_Scope (Constr);
+      if Present (Context) then
+         if Nkind (Context) = N_Assignment_Statement then
 
-      --  Otherwise there is no suitable construct which requires handling by
-      --  a transient scope. If the transient scope was requested for purposes
-      --  of managing the secondary stack, delegate the work to an enclosing
-      --  scope.
+            --  An assignment statement with suppressed controlled semantics
+            --  does not need a transient scope because finalization is not
+            --  desirable at this point. Note that No_Ctrl_Actions is also
+            --  set for non-controlled assignments to suppress dispatching
+            --  _assign.
 
-      elsif Manage_Sec_Stack then
-         Delegate_Sec_Stack_Management;
+            if No_Ctrl_Actions (Context)
+              and then Needs_Finalization (Etype (Name (Context)))
+            then
+               --  When a controlled component is initialized by a function
+               --  call, the result on the secondary stack is always assigned
+               --  to the component. Signal the nearest suitable scope that it
+               --  is safe to manage the secondary stack.
+
+               if Manage_Sec_Stack and then Within_Init_Proc then
+                  Delegate_Sec_Stack_Management;
+               end if;
+
+            --  Otherwise the assignment is a normal transient context and thus
+            --  requires a transient scope.
+
+            else
+               Create_Transient_Scope (Context);
+            end if;
+
+         --  General case
+
+         else
+            Create_Transient_Scope (Context);
+         end if;
       end if;
    end Establish_Transient_Scope;
 
@@ -4815,18 +4800,18 @@ package body Exp_Ch7 is
       end if;
    end Expand_N_Package_Declaration;
 
-   -----------------------------
-   -- Find_Node_To_Be_Wrapped --
-   -----------------------------
+   ----------------------------
+   -- Find_Transient_Context --
+   ----------------------------
 
-   function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
+   function Find_Transient_Context (N : Node_Id) return Node_Id is
       Curr : Node_Id;
       Prev : Node_Id;
 
    begin
       Curr := N;
       Prev := Empty;
-      loop
+      while Present (Curr) loop
          case Nkind (Curr) is
 
             --  Declarations
@@ -4858,58 +4843,66 @@ package body Exp_Ch7 is
                | N_Entry_Body_Formal_Part
                | N_Exit_Statement
                | N_If_Statement
-               | N_Iteration_Scheme
                | N_Terminate_Alternative
             =>
                pragma Assert (Present (Prev));
                return Prev;
 
-            --  Assignment statements are usually wrapped in a transient block
-            --  except when they are generated as part of controlled aggregate
-            --  where the wrapping should take place more globally. Note that
-            --  No_Ctrl_Actions is set also for non-controlled assignments, in
-            --  order to disable the use of dispatching _assign, thus the test
-            --  for a controlled type.
-
             when N_Assignment_Statement =>
-               if No_Ctrl_Actions (Curr)
-                 and then Needs_Finalization (Etype (Name (Curr)))
-               then
-                  return Empty;
-               else
-                  return Curr;
-               end if;
-
-            --  An entry of procedure call is usually wrapped except when it
-            --  acts as the alternative of a conditional or timed entry call.
-            --  In that case wrap the context of the alternative.
+               return Curr;
 
             when N_Entry_Call_Statement
                | N_Procedure_Call_Statement
             =>
+               --  When an entry or procedure call acts as the alternative of a
+               --  conditional or timed entry call, the proper context is that
+               --  of the alternative.
+
                if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
                  and then Nkind_In (Parent (Parent (Curr)),
                                     N_Conditional_Entry_Call,
                                     N_Timed_Entry_Call)
                then
                   return Parent (Parent (Curr));
+
+               --  General case for entry or procedure calls
+
                else
                   return Curr;
                end if;
 
-            when N_Pragma
-               | N_Raise_Statement
-            =>
-               return Curr;
+            when N_Pragma =>
+
+               --  Pragma Check is not a valid transient context in GNATprove
+               --  mode because the pragma must remain unchanged.
+
+               if GNATprove_Mode
+                 and then Get_Pragma_Id (Curr) = Pragma_Check
+               then
+                  return Empty;
+
+               --  General case for pragmas
+
+               else
+                  return Curr;
+               end if;
 
-            --  A return statement is not wrapped when the associated function
-            --  would require wrapping.
+            when N_Raise_Statement =>
+               return Curr;
 
             when N_Simple_Return_Statement =>
+
+               --  A return statement is not a valid transient context when the
+               --  function itself requires transient scope management because
+               --  the result will be reclaimed too early.
+
                if Requires_Transient_Scope (Etype
                     (Return_Applies_To (Return_Statement_Entity (Curr))))
                then
                   return Empty;
+
+               --  General case for return statements
+
                else
                   return Curr;
                end if;
@@ -4921,12 +4914,25 @@ package body Exp_Ch7 is
                   return Curr;
                end if;
 
-            --  If the construct is within the iteration scheme of a loop, it
-            --  requires a declaration followed by an assignment, in order to
-            --  have a usable statement to wrap.
+            --  An iteration scheme or an Ada 2012 iterator specification is
+            --  not a valid context because Analyze_Iteration_Scheme already
+            --  employs special processing for them.
+
+            when N_Iteration_Scheme
+               | N_Iterator_Specification
+            =>
+               return Empty;
 
             when N_Loop_Parameter_Specification =>
-               return Parent (Curr);
+
+               --  An iteration scheme is not a valid context because routine
+               --  Analyze_Iteration_Scheme already employs special processing.
+
+               if Nkind (Parent (Curr)) = N_Iteration_Scheme then
+                  return Empty;
+               else
+                  return Parent (Curr);
+               end if;
 
             --  Termination
 
@@ -4963,7 +4969,9 @@ package body Exp_Ch7 is
          Prev := Curr;
          Curr := Parent (Curr);
       end loop;
-   end Find_Node_To_Be_Wrapped;
+
+      return Empty;
+   end Find_Transient_Context;
 
    ----------------------------------
    -- Has_New_Controlled_Component --
index b94c9e8c17ba3787e35fde57375250d53e8ce92e..2a3b1ff0437070a8551a921d1fccb2de6d4fe391 100644 (file)
@@ -2779,7 +2779,6 @@ package body Sem_Ch5 is
       ------------------------------------
 
       function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is
-
          function Check_Call (N : Node_Id) return Traverse_Result;
          --  Check if N is a function call which uses the secondary stack
 
@@ -2788,36 +2787,32 @@ package body Sem_Ch5 is
          ----------------
 
          function Check_Call (N : Node_Id) return Traverse_Result is
-            Nam        : Node_Id;
-            Subp       : Entity_Id;
-            Return_Typ : Entity_Id;
+            Nam  : Node_Id;
+            Subp : Entity_Id;
+            Typ  : Entity_Id;
 
          begin
             if Nkind (N) = N_Function_Call then
                Nam := Name (N);
 
-               --  Call using access to subprogram with explicit dereference
-
-               if Nkind (Nam) = N_Explicit_Dereference then
-                  Subp := Etype (Nam);
-
-               --  Call using a selected component notation or Ada 2005 object
-               --  operation notation
+               --  Obtain the subprogram being invoked
 
-               elsif Nkind (Nam) = N_Selected_Component then
-                  Subp := Entity (Selector_Name (Nam));
+               loop
+                  if Nkind (Nam) = N_Explicit_Dereference then
+                     Nam := Prefix (Nam);
 
-               --  Common case
+                  elsif Nkind (Nam) = N_Selected_Component then
+                     Nam := Selector_Name (Nam);
 
-               else
-                  Subp := Entity (Nam);
-               end if;
+                  else
+                     exit;
+                  end if;
+               end loop;
 
-               Return_Typ := Etype (Subp);
+               Subp := Entity (Nam);
+               Typ  := Etype (Subp);
 
-               if Is_Composite_Type (Return_Typ)
-                 and then not Is_Constrained (Return_Typ)
-               then
+               if Requires_Transient_Scope (Typ) then
                   return Abandon;
 
                elsif Sec_Stack_Needed_For_Return (Subp) then