This change fixes a defect whereby GNAT would fail to generate secondary
stack cleanup code for a scope containing a local object of a limited
discriminated type initialized by a (build-in-place) function call,
thus causing a storage leak.
The following test case must not leak memory for each iteration of the loop:
package Limited_Factory is
type Lim (D : Integer) is limited private;
function Create_In_Place return Lim;
private
type Lim (D : Integer) is limited record
S : String (1 .. 1024);
end record;
end Limited_Factory;
package body Limited_Factory is
function Create_In_Place return Lim is
begin
return Lim'(D => 42, S => (others => 'x'));
end;
end Limited_Factory;
with Limited_Factory; use Limited_Factory;
procedure Sec_Stack_BIP is
procedure Leak is
Obj : Lim := Create_In_Place;
begin
null;
end;
begin
for J in 1 .. 1000 loop
Leak;
end loop;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-17 Thomas Quinot <qui...@adacore.com>
* exp_ch7.adb (Establish_Transient_Scope.Find_Node_To_Be_Wrapped):
Start examining the tree at the node passed to
Establish_Transient_Scope (not its parent).
* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration):
The access type for the variable storing the reference to
the call must be declared and frozen prior to establishing a
transient scope.
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 212716)
+++ exp_ch7.adb (working copy)
@@ -4208,11 +4208,8 @@
begin
The_Parent := N;
+ P := Empty;
loop
- P := The_Parent;
- pragma Assert (P /= Empty);
- The_Parent := Parent (P);
-
case Nkind (The_Parent) is
-- Simple statement can be wrapped
@@ -4263,7 +4260,7 @@
-- The expression itself is to be wrapped if its parent is a
-- compound statement or any other statement where the expression
- -- is known to be scalar
+ -- is known to be scalar.
when N_Accept_Alternative |
N_Attribute_Definition_Clause |
@@ -4279,6 +4276,7 @@
N_If_Statement |
N_Iteration_Scheme |
N_Terminate_Alternative =>
+ pragma Assert (Present (P));
return P;
when N_Attribute_Reference =>
@@ -4344,6 +4342,9 @@
when others =>
null;
end case;
+
+ P := The_Parent;
+ The_Parent := Parent (P);
end loop;
end Find_Node_To_Be_Wrapped;
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 212657)
+++ exp_ch6.adb (working copy)
@@ -10181,10 +10181,9 @@
Func_Call : Node_Id := Function_Call;
Function_Id : Entity_Id;
Pool_Actual : Node_Id;
+ Ptr_Typ : Entity_Id;
Ptr_Typ_Decl : Node_Id;
Pass_Caller_Acc : Boolean := False;
- New_Expr : Node_Id;
- Ref_Type : Entity_Id;
Res_Decl : Node_Id;
Result_Subt : Entity_Id;
@@ -10224,6 +10223,53 @@
Result_Subt := Etype (Function_Id);
+ -- Create an access type designating the function's result subtype. We
+ -- use the type of the original call because it may be a call to an
+ -- inherited operation, which the expansion has replaced with the parent
+ -- operation that yields the parent type. Note that this access type
+ -- must be declared before we establish a transient scope, so that it
+ -- receives the proper accessibility level.
+
+ Ptr_Typ := Make_Temporary (Loc, 'A');
+ Ptr_Typ_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Etype (Function_Call), Loc)));
+
+ -- The access type and its accompanying object must be inserted after
+ -- the object declaration in the constrained case, so that the function
+ -- call can be passed access to the object. In the unconstrained case,
+ -- or if the object declaration is for a return object, the access type
+ -- and object must be inserted before the object, since the object
+ -- declaration is rewritten to be a renaming of a dereference of the
+ -- access object. Note: we need to freeze Ptr_Typ explicitly, because
+ -- the result object is in a different (transient) scope, so won't
+ -- cause freezing.
+
+ if Is_Constrained (Underlying_Type (Result_Subt))
+ and then not Is_Return_Object (Defining_Identifier (Object_Decl))
+ then
+ Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
+ else
+ Insert_Action (Object_Decl, Ptr_Typ_Decl);
+ end if;
+
+ -- Force immediate freezing of Ptr_Typ because Res_Decl will be
+ -- elaborated in an inner (transient) scope and thus won't cause
+ -- freezing by itself.
+
+ declare
+ Ptr_Typ_Freeze_Ref : constant Node_Id :=
+ New_Occurrence_Of (Ptr_Typ, Loc);
+ begin
+ Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl);
+ Freeze_Expression (Ptr_Typ_Freeze_Ref);
+ end;
+
-- If the the object is a return object of an enclosing build-in-place
-- function, then the implicit build-in-place parameters of the
-- enclosing function are simply passed along to the called function.
@@ -10356,53 +10402,22 @@
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
- -- Create an access type designating the function's result subtype. We
- -- use the type of the original expression because it may be a call to
- -- an inherited operation, which the expansion has replaced with the
- -- parent operation that yields the parent type.
-
- Ref_Type := Make_Temporary (Loc, 'A');
-
- Ptr_Typ_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Etype (Function_Call), Loc)));
-
- -- The access type and its accompanying object must be inserted after
- -- the object declaration in the constrained case, so that the function
- -- call can be passed access to the object. In the unconstrained case,
- -- or if the object declaration is for a return object, the access type
- -- and object must be inserted before the object, since the object
- -- declaration is rewritten to be a renaming of a dereference of the
- -- access object.
-
- if Is_Constrained (Underlying_Type (Result_Subt))
- and then not Is_Return_Object (Defining_Identifier (Object_Decl))
- then
- Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
- else
- Insert_Action (Object_Decl, Ptr_Typ_Decl);
- end if;
-
-- Finally, create an access object initialized to a reference to the
-- function call. We know this access value cannot be null, so mark the
-- entity accordingly to suppress the access check.
- New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
-
- Def_Id := Make_Temporary (Loc, 'R', New_Expr);
- Set_Etype (Def_Id, Ref_Type);
+ Def_Id := Make_Temporary (Loc, 'R', Func_Call);
+ Set_Etype (Def_Id, Ptr_Typ);
Set_Is_Known_Non_Null (Def_Id);
Res_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
- Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
- Expression => New_Expr);
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression =>
+ Make_Reference (Loc, Relocate_Node (Func_Call)));
+
Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
-- If the result subtype of the called function is constrained and
