[Ada] Secondary stack leak in loop iterator

When the evaluation of the loop iterator invokes a function whose
result relies on the secondary stack the compiler does not generate
code to release the consumed memory as soon as the loop terminates.

After this patch the following test works fine.

with Text_IO; use Text_IO;
pragma Warnings (Off);
with System.Secondary_Stack;
pragma Warnings (On);
procedure Sec_Stack_Leak is
   function F (X : String) return Integer is
   begin
      return 10;
   end F;

   function G (X : Integer) return String is
   begin
      return (1 .. X => 'x');
   end G;

   procedure Info is new System.Secondary_Stack.Ss_Info (Put_Line);

   procedure Nest is
   begin
      for I in Integer range 1 .. 100 loop
         for J in Integer range 1 .. F (G (10_000)) loop
            null;
         end loop;
         Info;
      end loop;
      Info;
   end Nest;

begin
   Info;
   Nest;
   Info;
end Sec_Stack_Leak;

Commands:
  gnatmake -q sec_stack_leak.adb
  sec_stack_leak | grep "Current allocated space :" | uniq
Output:
  Current allocated space :  0 bytes

2018-07-17  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* sem_ch5.adb (Has_Call_Using_Secondary_Stack): Moved to library level
	to reuse it.
	(Analyze_Loop_Statement): Wrap the loop in a block when the evaluation
	of the loop iterator relies on the secondary stack.

From-SVN: r262774

2 files changed, 122 insertions, 65 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 2be7d3b..db369cc 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-07-17  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch5.adb (Has_Call_Using_Secondary_Stack): Moved to library level
+	to reuse it.
+	(Analyze_Loop_Statement): Wrap the loop in a block when the evaluation
+	of the loop iterator relies on the secondary stack.
+
 2018-07-17  Piotr Trojanek  <trojanek@adacore.com>
 
 	* sem_util.adb (Next_Actual): If the parent is a N_Null_Statement,
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 3ce57ea..ad592fb 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -83,6 +83,12 @@ package body Sem_Ch5 is
    --  messages. This variable is recursively saved on entry to processing the
    --  construct, and restored on exit.
 
+   function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
+   --  N is the node for an arbitrary construct. This function searches the
+   --  construct N to see if any expressions within it contain function
+   --  calls that use the secondary stack, returning True if any such call
+   --  is found, and False otherwise.
+
    procedure Preanalyze_Range (R_Copy : Node_Id);
    --  Determine expected type of range or domain of iteration of Ada 2012
    --  loop by analyzing separate copy. Do the analysis and resolution of the
@@ -2692,12 +2698,6 @@ package body Sem_Ch5 is
       --  forms. In this case it is not sufficent to check the static predicate
       --  function only, look for a dynamic predicate aspect as well.
 
-      function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
-      --  N is the node for an arbitrary construct. This function searches the
-      --  construct N to see if any expressions within it contain function
-      --  calls that use the secondary stack, returning True if any such call
-      --  is found, and False otherwise.
-
       procedure Process_Bounds (R : Node_Id);
       --  If the iteration is given by a range, create temporaries and
       --  assignment statements block to capture the bounds and perform
@@ -2782,65 +2782,6 @@ package body Sem_Ch5 is
          end if;
       end Check_Predicate_Use;
 
-      ------------------------------------
-      -- Has_Call_Using_Secondary_Stack --
-      ------------------------------------
-
-      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
-
-         ----------------
-         -- Check_Call --
-         ----------------
-
-         function Check_Call (N : Node_Id) return Traverse_Result is
-            Nam  : Node_Id;
-            Subp : Entity_Id;
-            Typ  : Entity_Id;
-
-         begin
-            if Nkind (N) = N_Function_Call then
-               Nam := Name (N);
-
-               --  Obtain the subprogram being invoked
-
-               loop
-                  if Nkind (Nam) = N_Explicit_Dereference then
-                     Nam := Prefix (Nam);
-
-                  elsif Nkind (Nam) = N_Selected_Component then
-                     Nam := Selector_Name (Nam);
-
-                  else
-                     exit;
-                  end if;
-               end loop;
-
-               Subp := Entity (Nam);
-               Typ  := Etype (Subp);
-
-               if Requires_Transient_Scope (Typ) then
-                  return Abandon;
-
-               elsif Sec_Stack_Needed_For_Return (Subp) then
-                  return Abandon;
-               end if;
-            end if;
-
-            --  Continue traversing the tree
-
-            return OK;
-         end Check_Call;
-
-         function Check_Calls is new Traverse_Func (Check_Call);
-
-      --  Start of processing for Has_Call_Using_Secondary_Stack
-
-      begin
-         return Check_Calls (N) = Abandon;
-      end Has_Call_Using_Secondary_Stack;
-
       --------------------
       -- Process_Bounds --
       --------------------
@@ -3644,6 +3585,56 @@ package body Sem_Ch5 is
          end;
       end if;
 
+      --  Wrap the loop in a block when the evaluation of the loop iterator
+      --  relies on the secondary stack. Required to ensure releasing the
+      --  secondary stack as soon as the loop completes.
+
+      if Present (Iter)
+        and then Present (Loop_Parameter_Specification (Iter))
+        and then not Is_Wrapped_In_Block (N)
+      then
+         declare
+            LPS       : constant Node_Id :=
+                          Loop_Parameter_Specification (Iter);
+            DSD       : constant Node_Id :=
+                          Original_Node (Discrete_Subtype_Definition (LPS));
+            Block_Nod : Node_Id;
+            Block_Id  : Entity_Id;
+            HB        : Node_Id;
+            LB        : Node_Id;
+
+         begin
+            if Nkind (DSD) = N_Subtype_Indication
+              and then Nkind (Range_Expression (Constraint (DSD))) = N_Range
+            then
+               LB := New_Copy_Tree
+                       (Low_Bound (Range_Expression (Constraint (DSD))));
+               HB := New_Copy_Tree
+                       (High_Bound (Range_Expression (Constraint (DSD))));
+
+               Preanalyze (LB);
+               Preanalyze (HB);
+
+               if Has_Call_Using_Secondary_Stack (LB)
+                    or else Has_Call_Using_Secondary_Stack (HB)
+               then
+                  Block_Nod :=
+                    Make_Block_Statement (Loc,
+                      Declarations => New_List,
+                    Handled_Statement_Sequence =>
+                      Make_Handled_Sequence_Of_Statements (Loc,
+                        Statements => New_List (Relocate_Node (N))));
+
+                  Add_Block_Identifier (Block_Nod, Block_Id);
+                  Set_Uses_Sec_Stack (Block_Id);
+                  Rewrite (N, Block_Nod);
+                  Analyze (N);
+                  return;
+               end if;
+            end if;
+         end;
+      end if;
+
       --  Kill current values on entry to loop, since statements in the body of
       --  the loop may have been executed before the loop is entered. Similarly
       --  we kill values after the loop, since we do not know that the body of
@@ -4072,6 +4063,65 @@ package body Sem_Ch5 is
       end if;
    end Check_Unreachable_Code;
 
+   ------------------------------------
+   -- Has_Call_Using_Secondary_Stack --
+   ------------------------------------
+
+   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
+
+      ----------------
+      -- Check_Call --
+      ----------------
+
+      function Check_Call (N : Node_Id) return Traverse_Result is
+         Nam  : Node_Id;
+         Subp : Entity_Id;
+         Typ  : Entity_Id;
+
+      begin
+         if Nkind (N) = N_Function_Call then
+            Nam := Name (N);
+
+            --  Obtain the subprogram being invoked
+
+            loop
+               if Nkind (Nam) = N_Explicit_Dereference then
+                  Nam := Prefix (Nam);
+
+               elsif Nkind (Nam) = N_Selected_Component then
+                  Nam := Selector_Name (Nam);
+
+               else
+                  exit;
+               end if;
+            end loop;
+
+            Subp := Entity (Nam);
+            Typ  := Etype (Subp);
+
+            if Requires_Transient_Scope (Typ) then
+               return Abandon;
+
+            elsif Sec_Stack_Needed_For_Return (Subp) then
+               return Abandon;
+            end if;
+         end if;
+
+         --  Continue traversing the tree
+
+         return OK;
+      end Check_Call;
+
+      function Check_Calls is new Traverse_Func (Check_Call);
+
+   --  Start of processing for Has_Call_Using_Secondary_Stack
+
+   begin
+      return Check_Calls (N) = Abandon;
+   end Has_Call_Using_Secondary_Stack;
+
    ----------------------
    -- Preanalyze_Range --
    ----------------------