Commit 6560f851 by Hristian Kirtchev Committed by Pierre-Marie de Rodat

[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
parent c9e80306
2018-01-11 Hristian Kirtchev <kirtchev@adacore.com>
* 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.
2018-01-11 Jerome Lambourg <lambourg@adacore.com> 2018-01-11 Jerome Lambourg <lambourg@adacore.com>
* libgnat/g-soliop__qnx.ads: New. * libgnat/g-soliop__qnx.ads: New.
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -4092,15 +4092,16 @@ package body Exp_Aggr is ...@@ -4092,15 +4092,16 @@ package body Exp_Aggr is
and then Ekind (Current_Scope) /= E_Return_Statement and then Ekind (Current_Scope) /= E_Return_Statement
and then not Is_Limited_Type (Typ) and then not Is_Limited_Type (Typ)
then then
Establish_Transient_Scope (Aggr, Sec_Stack => False); Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
end if; end if;
declare declare
Node_After : constant Node_Id := Next (N); Node_After : constant Node_Id := Next (N);
begin begin
Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
Collect_Initialization_Statements (Obj, N, Node_After); Collect_Initialization_Statements (Obj, N, Node_After);
end; end;
Set_No_Initialization (N); Set_No_Initialization (N);
Initialize_Discriminants (N, Typ); Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl; end Convert_Aggr_In_Object_Decl;
...@@ -4228,7 +4229,7 @@ package body Exp_Aggr is ...@@ -4228,7 +4229,7 @@ package body Exp_Aggr is
-- Should the condition be more restrictive ??? -- Should the condition be more restrictive ???
if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
Establish_Transient_Scope (N, Sec_Stack => False); Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if; end if;
-- If the aggregate is nonlimited, create a temporary. If it is limited -- If the aggregate is nonlimited, create a temporary. If it is limited
...@@ -6161,7 +6162,7 @@ package body Exp_Aggr is ...@@ -6161,7 +6162,7 @@ package body Exp_Aggr is
-- for default initialization, e.g. with Initialize_Scalars. -- for default initialization, e.g. with Initialize_Scalars.
if Requires_Transient_Scope (Typ) then if Requires_Transient_Scope (Typ) then
Establish_Transient_Scope (N, Sec_Stack => False); Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if; end if;
if Has_Default_Init_Comps (N) then if Has_Default_Init_Comps (N) then
...@@ -6292,15 +6293,15 @@ package body Exp_Aggr is ...@@ -6292,15 +6293,15 @@ package body Exp_Aggr is
Set_No_Initialization (Tmp_Decl, True); Set_No_Initialization (Tmp_Decl, True);
-- If we are within a loop, the temporary will be pushed on the -- If we are within a loop, the temporary will be pushed on the
-- stack at each iteration. If the aggregate is the expression for an -- stack at each iteration. If the aggregate is the expression
-- allocator, it will be immediately copied to the heap and can -- for an allocator, it will be immediately copied to the heap
-- be reclaimed at once. We create a transient scope around the -- and can be reclaimed at once. We create a transient scope
-- aggregate for this purpose. -- around the aggregate for this purpose.
if Ekind (Current_Scope) = E_Loop if Ekind (Current_Scope) = E_Loop
and then Nkind (Parent (Parent (N))) = N_Allocator and then Nkind (Parent (Parent (N))) = N_Allocator
then then
Establish_Transient_Scope (N, Sec_Stack => False); Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if; end if;
Insert_Action (N, Tmp_Decl); Insert_Action (N, Tmp_Decl);
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -4369,7 +4369,7 @@ package body Exp_Ch6 is ...@@ -4369,7 +4369,7 @@ package body Exp_Ch6 is
or else Nkind (Parent (N)) /= N_Function_Call or else Nkind (Parent (N)) /= N_Function_Call
or else not Is_Build_In_Place_Function_Call (Parent (N))) or else not Is_Build_In_Place_Function_Call (Parent (N)))
then then
Establish_Transient_Scope (Call_Node, Sec_Stack => True); Establish_Transient_Scope (Call_Node, Manage_Sec_Stack => True);
end if; end if;
end if; end if;
end Expand_Call_Helper; end Expand_Call_Helper;
...@@ -8548,8 +8548,8 @@ package body Exp_Ch6 is ...@@ -8548,8 +8548,8 @@ package body Exp_Ch6 is
Attribute_Name => Name_Unrestricted_Access); Attribute_Name => Name_Unrestricted_Access);
end if; end if;
-- In other indefinite cases, pass an indication to do the allocation on -- In other indefinite cases, pass an indication to do the allocation
-- the secondary stack and set Caller_Object to Empty so that a null -- on the secondary stack and set Caller_Object to Empty so that a null
-- value will be passed for the caller's object address. A transient -- value will be passed for the caller's object address. A transient
-- scope is established to ensure eventual cleanup of the result. -- scope is established to ensure eventual cleanup of the result.
...@@ -8558,7 +8558,7 @@ package body Exp_Ch6 is ...@@ -8558,7 +8558,7 @@ package body Exp_Ch6 is
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack); (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
Caller_Object := Empty; Caller_Object := Empty;
Establish_Transient_Scope (Obj_Decl, Sec_Stack => True); Establish_Transient_Scope (Obj_Decl, Manage_Sec_Stack => True);
end if; end if;
-- Pass along any finalization master actual, which is needed in the -- Pass along any finalization master actual, which is needed in the
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2016, 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -276,10 +276,12 @@ package Exp_Ch7 is ...@@ -276,10 +276,12 @@ package Exp_Ch7 is
-- a "scope node" that is to say one of the following: N_Block_Statement, -- a "scope node" that is to say one of the following: N_Block_Statement,
-- N_Subprogram_Body, N_Task_Body, N_Entry_Body. -- N_Subprogram_Body, N_Task_Body, N_Entry_Body.
procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean); procedure Establish_Transient_Scope
-- Push a new transient scope on the scope stack. N is the node responsible (N : Node_Id;
-- for the need of a transient scope. If Sec_Stack is True then the Manage_Sec_Stack : Boolean);
-- secondary stack is brought in, otherwise it isn't. -- Push a new transient scope on the scope stack. N is the node which must
-- be serviced by the transient scope. Set Manage_Sec_Stack when the scope
-- must mark and release the secondary stack.
function Node_To_Be_Wrapped return Node_Id; function Node_To_Be_Wrapped return Node_Id;
-- Return the node to be wrapped if the current scope is transient -- Return the node to be wrapped if the current scope is transient
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -207,7 +207,7 @@ package body Exp_Smem is ...@@ -207,7 +207,7 @@ package body Exp_Smem is
else else
Insert_Action (N, Vde); Insert_Action (N, Vde);
Establish_Transient_Scope (N, Sec_Stack => False); Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if; end if;
-- Mark object as locked in the current (transient) scope -- Mark object as locked in the current (transient) scope
...@@ -255,13 +255,15 @@ package body Exp_Smem is ...@@ -255,13 +255,15 @@ package body Exp_Smem is
--------------------- ---------------------
procedure Add_Write_After (N : Node_Id) is procedure Add_Write_After (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ent : constant Entity_Id := Entity (N); Ent : constant Entity_Id := Entity (N);
Loc : constant Source_Ptr := Sloc (N);
Par : constant Node_Id := Insert_Node; Par : constant Node_Id := Insert_Node;
begin begin
if Present (Shared_Var_Procs_Instance (Ent)) then if Present (Shared_Var_Procs_Instance (Ent)) then
if Nkind (Insert_Node) = N_Function_Call then if Nkind (Insert_Node) = N_Function_Call then
Establish_Transient_Scope (Insert_Node, Sec_Stack => False); Establish_Transient_Scope (Insert_Node, Manage_Sec_Stack => False);
Store_After_Actions_In_Scope (New_List ( Store_After_Actions_In_Scope (New_List (
Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write))); Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)));
else else
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment