[Ada] Memory leak mixing limited and nonlimited functions

This patch fixes a memory leak. If a build-in-place function with a result
whose size is not known at the call site is called, and that function calls a
non-build-in-place function that allocates on the secondary stack, the
secondary stack was not necessarily cleaned up, which caused a memory leak.

The following program should print:
"Current allocated space :  0 bytes"
(among other things) in the loop.

./bip_leak-main > log
grep 'Current allocated' log
  Current allocated space :  0 bytes
  Current allocated space :  0 bytes
  Current allocated space :  0 bytes

with Ada.Finalization;
package BIP_Leak is
   subtype Limited_Controlled is Ada.Finalization.Limited_Controlled;

   type Nonlim_Controlled is new Ada.Finalization.Controlled with null record;
   type Needs_Fin is record
      X : Nonlim_Controlled;
   end record;

   type Lim_Controlled is new Limited_Controlled with null record;

   function Return_Lim_Controlled (Source : Boolean)
                       return Lim_Controlled;

   procedure Dump_SS;

end BIP_Leak;

with Ada.Text_IO;
pragma Warnings (Off);
with System.Secondary_Stack;
pragma Warnings (On);
package body BIP_Leak is
   function Transform (X : Needs_Fin) return Lim_Controlled is
   begin
      return (Limited_Controlled with null record);
   end;

   function Return_Needs_Fin (I : Boolean) return Needs_Fin is
     THR : Needs_Fin;
   begin
      return THR;
   end;

   function Return_Lim_Controlled (Source : Boolean)
                       return Lim_Controlled is
   begin
      return Transform (Return_Needs_Fin (Source));
   end Return_Lim_Controlled;

   procedure Dump_SS_Instance is
     new System.Secondary_Stack.SS_Info (Ada.Text_IO.Put_Line);
   procedure Dump_SS renames Dump_SS_Instance;

end BIP_Leak;

procedure BIP_Leak.Main is
begin
   for Count in 1 .. 350_000 loop
      declare
         Msg : constant Lim_Controlled := Return_Lim_Controlled (True);
      begin
         if Count mod 100_000 = 0 then
            Dump_SS;
         end if;
      end;
   end loop;
end BIP_Leak.Main;

2018-05-24  Bob Duff  <duff@adacore.com>

gcc/ada/

	* exp_ch7.adb (Expand_Cleanup_Actions): Create a mark unconditionally
	for build-in-place functions with a caller-unknown-size result.
	(Create_Finalizer): For build-in-place functions with a
	caller-unknown-size result, check at run time whether we need to
	release the secondary stack.

From-SVN: r260650

2 files changed, 64 insertions, 5 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index efe7559..7640204 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2018-05-24  Bob Duff  <duff@adacore.com>
+
+	* exp_ch7.adb (Expand_Cleanup_Actions): Create a mark unconditionally
+	for build-in-place functions with a caller-unknown-size result.
+	(Create_Finalizer): For build-in-place functions with a
+	caller-unknown-size result, check at run time whether we need to
+	release the secondary stack.
+
 2018-05-24  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_prag.adb (Analyze_Pragma): Use the full view of an internally
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 9d1919a..d27150f 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -1777,10 +1777,49 @@ package body Exp_Ch7 is
             Set_At_End_Proc (HSS, Empty);
          end if;
 
-         --  Release the secondary stack mark
+         --  Release the secondary stack
 
          if Present (Mark_Id) then
-            Append_To (Finalizer_Stmts, Build_SS_Release_Call (Loc, Mark_Id));
+            declare
+               Release : Node_Id :=
+                 Build_SS_Release_Call (Loc, Mark_Id);
+            begin
+               --  If this is a build-in-place function, then we need to
+               --  release the secondary stack, unless we are returning on the
+               --  secondary stack. We wrap the release call in:
+               --    if BIP_Alloc_Form /= Secondary_Stack then ...
+               --  If we are returning on the secondary stack, then releasing
+               --  is the caller's responsibility (or caller's caller, or ...).
+
+               if Nkind (N) = N_Subprogram_Body then
+                  declare
+                     Spec_Id : constant Entity_Id :=
+                                 Unique_Defining_Entity (N);
+                     BIP_SS  : constant Boolean :=
+                                 Is_Build_In_Place_Function (Spec_Id)
+                                   and then Needs_BIP_Alloc_Form (Spec_Id);
+                  begin
+                     if BIP_SS then
+                        Release :=
+                          Make_If_Statement (Loc,
+                            Condition =>
+                              Make_Op_Ne (Loc,
+                                Left_Opnd  =>
+                                  New_Occurrence_Of
+                                    (Build_In_Place_Formal
+                                      (Spec_Id, BIP_Alloc_Form), Loc),
+                                Right_Opnd =>
+                                  Make_Integer_Literal (Loc,
+                                    UI_From_Int (BIP_Allocation_Form'Pos
+                                                   (Secondary_Stack)))),
+
+                            Then_Statements => New_List (Release));
+                     end if;
+                  end;
+               end if;
+
+               Append_To (Finalizer_Stmts, Release);
+            end;
          end if;
 
          --  Protect the statements with abort defer/undefer. This is only when
@@ -4327,10 +4366,22 @@ package body Exp_Ch7 is
                                    and then Is_Task_Allocation_Block (N);
       Is_Task_Body           : constant Boolean :=
                                  Nkind (Original_Node (N)) = N_Task_Body;
+
+      --  We mark the secondary stack if it is used in this construct, and
+      --  we're not returning a function result on the secondary stack, except
+      --  that a build-in-place function that might or might not return on the
+      --  secondary stack always needs a mark. A run-time test is required in
+      --  the case where the build-in-place function has a BIP_Alloc extra
+      --  parameter (see Create_Finalizer).
+
       Needs_Sec_Stack_Mark   : constant Boolean :=
-                                 Uses_Sec_Stack (Scop)
-                                   and then
-                                     not Sec_Stack_Needed_For_Return (Scop);
+                                   (Uses_Sec_Stack (Scop)
+                                     and then
+                                       not Sec_Stack_Needed_For_Return (Scop))
+                                 or else
+                                   (Is_Build_In_Place_Function (Scop)
+                                     and then Needs_BIP_Alloc_Form (Scop));
+
       Needs_Custom_Cleanup   : constant Boolean :=
                                  Nkind (N) = N_Block_Statement
                                    and then Present (Cleanup_Actions (N));