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 @@
-- -- -- --
-- 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- --
...@@ -4066,92 +4066,51 @@ package body Exp_Ch7 is ...@@ -4066,92 +4066,51 @@ package body Exp_Ch7 is
-- result. It creates a new scope on the scope stack in order to enclose -- result. It creates a new scope on the scope stack in order to enclose
-- all transient variables generated. -- all transient variables generated.
procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is procedure Establish_Transient_Scope
Loc : constant Source_Ptr := Sloc (N); (N : Node_Id;
Iter_Loop : Entity_Id; Manage_Sec_Stack : Boolean)
Scop_Id : Entity_Id; is
Scop_Rec : Scope_Stack_Entry; procedure Create_Transient_Scope (Constr : Node_Id);
Wrap_Node : Node_Id; -- Place a new scope on the scope stack in order to service construct
-- Constr. The new scope may also manage the secondary stack.
begin
-- Do not create a new transient scope if there is an existing transient
-- scope on the stack.
for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
Scop_Rec := Scope_Stack.Table (Index);
Scop_Id := Scop_Rec.Entity;
-- The current scope is transient. If the scope being established
-- needs to manage the secondary stack, then the existing scope
-- overtakes that function.
if Scop_Rec.Is_Transient then
if Sec_Stack then
Set_Uses_Sec_Stack (Scop_Id);
end if;
return;
-- Prevent the search from going too far because transient blocks
-- are bounded by packages and subprogram scopes. Reaching Standard
-- should be impossible without hitting one of the other cases first
-- unless Standard was manually pushed.
elsif Scop_Id = Standard_Standard
or else Ekind_In (Scop_Id, E_Entry,
E_Entry_Family,
E_Function,
E_Package,
E_Procedure,
E_Subprogram_Body)
then
exit;
end if;
end loop;
Wrap_Node := Find_Node_To_Be_Wrapped (N); procedure Delegate_Sec_Stack_Management;
-- Move the management of the secondary stack to the nearest enclosing
-- suitable scope.
-- The context does not contain a node that requires a transient scope, function Find_Enclosing_Transient_Scope return Entity_Id;
-- nothing to do. -- Examine the scope stack looking for the nearest enclosing transient
-- scope. Return Empty if no such scope exists.
if No (Wrap_Node) then function Is_OK_Construct (Constr : Node_Id) return Boolean;
null; -- Determine whether arbitrary node Constr is a suitable construct which
-- requires handling by a transient scope.
-- If the node to wrap is an iteration_scheme, the expression is one of function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
-- the bounds, and the expansion will make an explicit declaration for -- Determine whether arbitrary Id denotes a package or subprogram [body]
-- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
-- transformations here. Same for an Ada 2012 iterator specification,
-- where a block is created for the expression that build the container.
elsif Nkind_In (Wrap_Node, N_Iteration_Scheme, ----------------------------
N_Iterator_Specification) -- Create_Transient_Scope --
then ----------------------------
null;
-- In formal verification mode, if the node to wrap is a pragma check, procedure Create_Transient_Scope (Constr : Node_Id) is
-- this node and enclosed expression are not expanded, so do not apply Loc : constant Source_Ptr := Sloc (N);
-- any transformations here.
elsif GNATprove_Mode Iter_Loop : Entity_Id;
and then Nkind (Wrap_Node) = N_Pragma Trans_Scop : Entity_Id;
and then Get_Pragma_Id (Wrap_Node) = Pragma_Check
then
null;
-- Create a block entity to act as a transient scope. Note that when the begin
-- node to be wrapped is an expression or a statement, a real physical Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
-- block is constructed (see routines Wrap_Transient_Expression and Set_Etype (Trans_Scop, Standard_Void_Type);
-- Wrap_Transient_Statement) and inserted into the tree.
else Push_Scope (Trans_Scop);
Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); Set_Node_To_Be_Wrapped (Constr);
Set_Scope_Is_Transient; Set_Scope_Is_Transient;
-- The transient scope must also take care of the secondary stack -- The transient scope must also manage the secondary stack
-- management.
if Sec_Stack then if Manage_Sec_Stack then
Set_Uses_Sec_Stack (Current_Scope); Set_Uses_Sec_Stack (Trans_Scop);
Check_Restriction (No_Secondary_Stack, N); Check_Restriction (No_Secondary_Stack, N);
-- The expansion of iterator loops generates references to objects -- The expansion of iterator loops generates references to objects
...@@ -4178,20 +4137,180 @@ package body Exp_Ch7 is ...@@ -4178,20 +4137,180 @@ package body Exp_Ch7 is
-- machinery to manage the secondary stack (see routine -- machinery to manage the secondary stack (see routine
-- Process_Statements_For_Controlled_Objects). -- Process_Statements_For_Controlled_Objects).
Iter_Loop := Find_Enclosing_Iterator_Loop (Current_Scope); Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
if Present (Iter_Loop) then if Present (Iter_Loop) then
Set_Uses_Sec_Stack (Iter_Loop); Set_Uses_Sec_Stack (Iter_Loop);
end if; end if;
end if; end if;
Set_Etype (Current_Scope, Standard_Void_Type);
Set_Node_To_Be_Wrapped (Wrap_Node);
if Debug_Flag_W then if Debug_Flag_W then
Write_Str (" <Transient>"); Write_Str (" <Transient>");
Write_Eol; Write_Eol;
end if; end if;
end Create_Transient_Scope;
-----------------------------------
-- Delegate_Sec_Stack_Management --
-----------------------------------
procedure Delegate_Sec_Stack_Management is
Scop_Id : Entity_Id;
Scop_Rec : Scope_Stack_Entry;
begin
for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
Scop_Rec := Scope_Stack.Table (Index);
Scop_Id := Scop_Rec.Entity;
-- Prevent the search from going too far or within the scope space
-- of another unit.
if Scop_Id = Standard_Standard then
return;
-- No transient scope should be encountered during the traversal
-- because Establish_Transient_Scope should have already handled
-- this case.
elsif Scop_Rec.Is_Transient then
pragma Assert (False);
return;
-- The construct which requires secondary stack management is
-- always enclosed by a package or subprogram scope.
elsif Is_Package_Or_Subprogram (Scop_Id) then
Set_Uses_Sec_Stack (Scop_Id);
Check_Restriction (No_Secondary_Stack, N);
return;
end if;
end loop;
-- At this point no suitable scope was found. This should never occur
-- because a construct is always enclosed by a compilation unit which
-- has a scope.
pragma Assert (False);
end Delegate_Sec_Stack_Management;
------------------------------------
-- Find_Enclosing_Transient_Scope --
------------------------------------
function Find_Enclosing_Transient_Scope return Entity_Id is
Scop_Id : Entity_Id;
Scop_Rec : Scope_Stack_Entry;
begin
for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
Scop_Rec := Scope_Stack.Table (Index);
Scop_Id := Scop_Rec.Entity;
-- Prevent the search from going too far or within the scope space
-- of another unit.
if Scop_Id = Standard_Standard
or else Is_Package_Or_Subprogram (Scop_Id)
then
exit;
elsif Scop_Rec.Is_Transient then
return Scop_Id;
end if;
end loop;
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 --
------------------------------
function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
begin
return Ekind_In (Id, E_Entry,
E_Entry_Family,
E_Function,
E_Package,
E_Procedure,
E_Subprogram_Body);
end Is_Package_Or_Subprogram;
-- Local variables
Scop_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
Constr : Node_Id;
-- Start of processing for Establish_Transient_Scope
begin
-- Do not create a new transient scope if there is an existing transient
-- scope on the stack.
if Present (Scop_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);
end if;
return;
end if;
-- At this point it is known that the scope stack is free of transient
-- scopes. Locate the proper construct which must be serviced by a new
-- transient scope.
Constr := Find_Node_To_Be_Wrapped (N);
if Is_OK_Construct (Constr) then
Create_Transient_Scope (Constr);
-- 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.
elsif Manage_Sec_Stack then
Delegate_Sec_Stack_Management;
end if; end if;
end Establish_Transient_Scope; end Establish_Transient_Scope;
...@@ -4701,70 +4820,35 @@ package body Exp_Ch7 is ...@@ -4701,70 +4820,35 @@ package body Exp_Ch7 is
----------------------------- -----------------------------
function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
P : Node_Id; Curr : Node_Id;
The_Parent : Node_Id; Prev : Node_Id;
begin begin
The_Parent := N; Curr := N;
P := Empty; Prev := Empty;
loop loop
case Nkind (The_Parent) is case Nkind (Curr) is
-- Simple statement can be wrapped
when N_Pragma =>
return The_Parent;
-- Usually assignments are good candidate for wrapping except
-- when they have been generated as part of a controlled aggregate
-- where the wrapping should take place more globally. Note that
-- No_Ctrl_Actions may be set also for non-controlled assignements
-- in order to disable the use of dispatching _assign, so we need
-- to test explicitly for a controlled type here.
when N_Assignment_Statement => -- Declarations
if No_Ctrl_Actions (The_Parent)
and then Needs_Finalization (Etype (Name (The_Parent)))
then
null;
else
return The_Parent;
end if;
-- An entry call statement is a special case if it occurs in the
-- context of a Timed_Entry_Call. In this case we wrap the entire
-- timed entry call.
when N_Entry_Call_Statement
| N_Procedure_Call_Statement
=>
if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
and then Nkind_In (Parent (Parent (The_Parent)),
N_Timed_Entry_Call,
N_Conditional_Entry_Call)
then
return Parent (Parent (The_Parent));
else
return The_Parent;
end if;
-- Object declarations are also a boundary for the transient scope -- Declarations act as a boundary for a transient scope even if
-- even if they are not really wrapped. For further details, see -- they are not wrapped, see Wrap_Transient_Declaration.
-- Wrap_Transient_Declaration.
when N_Object_Declaration when N_Object_Declaration
| N_Object_Renaming_Declaration | N_Object_Renaming_Declaration
| N_Subtype_Declaration | N_Subtype_Declaration
=> =>
return The_Parent; return Curr;
-- Statements
-- The expression itself is to be wrapped if its parent is a -- Statements and statement-like constructs act as a boundary for
-- compound statement or any other statement where the expression -- a transient scope.
-- is known to be scalar.
when N_Accept_Alternative when N_Accept_Alternative
| N_Attribute_Definition_Clause | N_Attribute_Definition_Clause
| N_Case_Statement | N_Case_Statement
| N_Case_Statement_Alternative
| N_Code_Statement | N_Code_Statement
| N_Delay_Alternative | N_Delay_Alternative
| N_Delay_Until_Statement | N_Delay_Until_Statement
...@@ -4777,32 +4861,77 @@ package body Exp_Ch7 is ...@@ -4777,32 +4861,77 @@ package body Exp_Ch7 is
| N_Iteration_Scheme | N_Iteration_Scheme
| N_Terminate_Alternative | N_Terminate_Alternative
=> =>
pragma Assert (Present (P)); pragma Assert (Present (Prev));
return P; return Prev;
when N_Attribute_Reference => -- Assignment statements are usually wrapped in a transient block
if Is_Procedure_Attribute_Name -- except when they are generated as part of controlled aggregate
(Attribute_Name (The_Parent)) -- 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 then
return The_Parent; return Empty;
else
return Curr;
end if; end if;
-- A raise statement can be wrapped. This will arise when the -- An entry of procedure call is usually wrapped except when it
-- expression in a raise_with_expression uses the secondary -- acts as the alternative of a conditional or timed entry call.
-- stack, for example. -- In that case wrap the context of the alternative.
when N_Raise_Statement => when N_Entry_Call_Statement
return The_Parent; | N_Procedure_Call_Statement
=>
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));
else
return Curr;
end if;
when N_Pragma
| N_Raise_Statement
=>
return Curr;
-- If the expression is within the iteration scheme of a loop, -- A return statement is not wrapped when the associated function
-- we must create a declaration for it, followed by an assignment -- would require wrapping.
-- in order to have a usable statement to wrap.
when N_Simple_Return_Statement =>
if Requires_Transient_Scope (Etype
(Return_Applies_To (Return_Statement_Entity (Curr))))
then
return Empty;
else
return Curr;
end if;
-- Special
when N_Attribute_Reference =>
if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
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.
when N_Loop_Parameter_Specification => when N_Loop_Parameter_Specification =>
return Parent (The_Parent); return Parent (Curr);
-- The following nodes contains "dummy calls" which don't need to -- Termination
-- be wrapped.
-- The following nodes represent "dummy contexts" which do not
-- need to be wrapped.
when N_Component_Declaration when N_Component_Declaration
| N_Discriminant_Specification | N_Discriminant_Specification
...@@ -4810,43 +4939,29 @@ package body Exp_Ch7 is ...@@ -4810,43 +4939,29 @@ package body Exp_Ch7 is
=> =>
return Empty; return Empty;
-- The return statement is not to be wrapped when the function -- If the traversal leaves a scope without having been able to
-- itself needs wrapping at the outer-level -- find a construct to wrap, something is going wrong, but this
-- can happen in error situations that are not detected yet (such
when N_Simple_Return_Statement => -- as a dynamic string in a pragma Export).
declare
Applies_To : constant Entity_Id :=
Return_Applies_To
(Return_Statement_Entity (The_Parent));
Return_Type : constant Entity_Id := Etype (Applies_To);
begin
if Requires_Transient_Scope (Return_Type) then
return Empty;
else
return The_Parent;
end if;
end;
-- If we leave a scope without having been able to find a node to
-- wrap, something is going wrong but this can happen in error
-- situation that are not detected yet (such as a dynamic string
-- in a pragma export)
when N_Block_Statement when N_Block_Statement
| N_Entry_Body
| N_Package_Body | N_Package_Body
| N_Package_Declaration | N_Package_Declaration
| N_Protected_Body
| N_Subprogram_Body | N_Subprogram_Body
| N_Task_Body
=> =>
return Empty; return Empty;
-- Otherwise continue the search -- Default
when others => when others =>
null; null;
end case; end case;
P := The_Parent; Prev := Curr;
The_Parent := Parent (P); Curr := Parent (Curr);
end loop; end loop;
end Find_Node_To_Be_Wrapped; end Find_Node_To_Be_Wrapped;
......
...@@ -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
......
...@@ -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- --
...@@ -117,13 +117,6 @@ package body Sem_Res is ...@@ -117,13 +117,6 @@ package body Sem_Res is
-- an infinite recursion, and if so, outputs appropriate messages. Returns -- an infinite recursion, and if so, outputs appropriate messages. Returns
-- True if an infinite recursion is detected, and False otherwise. -- True if an infinite recursion is detected, and False otherwise.
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
-- If the type of the object being initialized uses the secondary stack
-- directly or indirectly, create a transient scope for the call to the
-- init proc. This is because we do not create transient scopes for the
-- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
procedure Check_No_Direct_Boolean_Operators (N : Node_Id); procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
-- N is the node for a logical operator. If the operator is predefined, and -- N is the node for a logical operator. If the operator is predefined, and
-- the root type of the operands is Standard.Boolean, then a check is made -- the root type of the operands is Standard.Boolean, then a check is made
...@@ -858,89 +851,6 @@ package body Sem_Res is ...@@ -858,89 +851,6 @@ package body Sem_Res is
return True; return True;
end Check_Infinite_Recursion; end Check_Infinite_Recursion;
-------------------------------
-- Check_Initialization_Call --
-------------------------------
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
Typ : constant Entity_Id := Etype (First_Formal (Nam));
function Uses_SS (T : Entity_Id) return Boolean;
-- Check whether the creation of an object of the type will involve
-- use of the secondary stack. If T is a record type, this is true
-- if the expression for some component uses the secondary stack, e.g.
-- through a call to a function that returns an unconstrained value.
-- False if T is controlled, because cleanups occur elsewhere.
-------------
-- Uses_SS --
-------------
function Uses_SS (T : Entity_Id) return Boolean is
Comp : Entity_Id;
Expr : Node_Id;
Full_Type : Entity_Id := Underlying_Type (T);
begin
-- Normally we want to use the underlying type, but if it's not set
-- then continue with T.
if not Present (Full_Type) then
Full_Type := T;
end if;
if Is_Array_Type (Full_Type) then
return Uses_SS (Component_Type (Full_Type));
elsif Is_Record_Type (Full_Type) then
Comp := First_Component (Full_Type);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
-- The expression for a dynamic component may be rewritten
-- as a dereference, so retrieve original node.
Expr := Original_Node (Expression (Parent (Comp)));
-- Return True if the expression is a call to a function
-- (including an attribute function such as Image, or a
-- user-defined operator) with a result that requires a
-- transient scope.
if (Nkind (Expr) = N_Function_Call
or else Nkind (Expr) in N_Op
or else (Nkind (Expr) = N_Attribute_Reference
and then Present (Expressions (Expr))))
and then Requires_Transient_Scope (Etype (Expr))
then
return True;
elsif Uses_SS (Etype (Comp)) then
return True;
end if;
end if;
Next_Component (Comp);
end loop;
return False;
else
return False;
end if;
end Uses_SS;
-- Start of processing for Check_Initialization_Call
begin
-- Establish a transient scope if the type needs it
if Uses_SS (Typ) then
Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
end if;
end Check_Initialization_Call;
--------------------------------------- ---------------------------------------
-- Check_No_Direct_Boolean_Operators -- -- Check_No_Direct_Boolean_Operators --
--------------------------------------- ---------------------------------------
...@@ -3930,13 +3840,14 @@ package body Sem_Res is ...@@ -3930,13 +3840,14 @@ package body Sem_Res is
-- transient scope for it, so that it can receive the proper -- transient scope for it, so that it can receive the proper
-- finalization list. -- finalization list.
elsif Nkind (A) = N_Function_Call elsif Expander_Active
and then Nkind (A) = N_Function_Call
and then Is_Limited_Record (Etype (F)) and then Is_Limited_Record (Etype (F))
and then not Is_Constrained (Etype (F)) and then not Is_Constrained (Etype (F))
and then Expander_Active and then (Needs_Finalization (Etype (F))
and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) or else Has_Task (Etype (F)))
then then
Establish_Transient_Scope (A, Sec_Stack => False); Establish_Transient_Scope (A, Manage_Sec_Stack => False);
Resolve (A, Etype (F)); Resolve (A, Etype (F));
-- A small optimization: if one of the actuals is a concatenation -- A small optimization: if one of the actuals is a concatenation
...@@ -3947,15 +3858,14 @@ package body Sem_Res is ...@@ -3947,15 +3858,14 @@ package body Sem_Res is
-- static string, and we want to preserve warnings involving -- static string, and we want to preserve warnings involving
-- sequences of such statements. -- sequences of such statements.
elsif Nkind (A) = N_Op_Concat elsif Expander_Active
and then Nkind (A) = N_Op_Concat
and then Nkind (N) = N_Procedure_Call_Statement and then Nkind (N) = N_Procedure_Call_Statement
and then Expander_Active and then not (Is_Intrinsic_Subprogram (Nam)
and then and then Chars (Nam) = Name_Asm)
not (Is_Intrinsic_Subprogram (Nam)
and then Chars (Nam) = Name_Asm)
and then not Static_Concatenation (A) and then not Static_Concatenation (A)
then then
Establish_Transient_Scope (A, Sec_Stack => False); Establish_Transient_Scope (A, Manage_Sec_Stack => False);
Resolve (A, Etype (F)); Resolve (A, Etype (F));
else else
...@@ -3963,12 +3873,12 @@ package body Sem_Res is ...@@ -3963,12 +3873,12 @@ package body Sem_Res is
and then Is_Array_Type (Etype (F)) and then Is_Array_Type (Etype (F))
and then not Same_Ancestor (Etype (F), Etype (Expression (A))) and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
and then and then
(Is_Limited_Type (Etype (F)) (Is_Limited_Type (Etype (F))
or else Is_Limited_Type (Etype (Expression (A)))) or else Is_Limited_Type (Etype (Expression (A))))
then then
Error_Msg_N Error_Msg_N
("conversion between unrelated limited array types " ("conversion between unrelated limited array types not "
& "not allowed ('A'I-00246)", A); & "allowed ('A'I-00246)", A);
if Is_Limited_Type (Etype (F)) then if Is_Limited_Type (Etype (F)) then
Explain_Limited_Type (Etype (F), A); Explain_Limited_Type (Etype (F), A);
...@@ -4011,10 +3921,12 @@ package body Sem_Res is ...@@ -4011,10 +3921,12 @@ package body Sem_Res is
-- enabled only, otherwise the transient scope will not -- enabled only, otherwise the transient scope will not
-- be removed in the expansion of the wrapped construct. -- be removed in the expansion of the wrapped construct.
if (Is_Controlled (DDT) or else Has_Task (DDT)) if Expander_Active
and then Expander_Active and then (Needs_Finalization (DDT)
or else Has_Task (DDT))
then then
Establish_Transient_Scope (A, Sec_Stack => False); Establish_Transient_Scope
(A, Manage_Sec_Stack => False);
end if; end if;
end; end;
...@@ -6443,11 +6355,6 @@ package body Sem_Res is ...@@ -6443,11 +6355,6 @@ package body Sem_Res is
-- is already present. It may not be available if e.g. the subprogram is -- is already present. It may not be available if e.g. the subprogram is
-- declared in a child instance. -- declared in a child instance.
-- If this is an initialization call for a type whose construction
-- uses the secondary stack, and it is not a nested call to initialize
-- a component, we do need to create a transient scope for it. We
-- check for this by traversing the type in Check_Initialization_Call.
if Is_Inlined (Nam) if Is_Inlined (Nam)
and then Has_Pragma_Inline (Nam) and then Has_Pragma_Inline (Nam)
and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
...@@ -6463,26 +6370,17 @@ package body Sem_Res is ...@@ -6463,26 +6370,17 @@ package body Sem_Res is
null; null;
elsif Expander_Active elsif Expander_Active
and then Is_Type (Etype (Nam)) and then Ekind (Nam) = E_Function
and then Requires_Transient_Scope (Etype (Nam)) and then Requires_Transient_Scope (Etype (Nam))
and then
(not Within_Init_Proc
or else
(not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function))
then then
Establish_Transient_Scope (N, Sec_Stack => True); Establish_Transient_Scope (N, Manage_Sec_Stack => True);
-- If the call appears within the bounds of a loop, it will -- If the call appears within the bounds of a loop, it will be
-- be rewritten and reanalyzed, nothing left to do here. -- rewritten and reanalyzed, nothing left to do here.
if Nkind (N) /= N_Function_Call then if Nkind (N) /= N_Function_Call then
return; return;
end if; end if;
elsif Is_Init_Proc (Nam)
and then not Within_Init_Proc
then
Check_Initialization_Call (N, Nam);
end if; end if;
-- A protected function cannot be called within the definition of the -- A protected function cannot be called within the definition of the
...@@ -7890,13 +7788,13 @@ package body Sem_Res is ...@@ -7890,13 +7788,13 @@ package body Sem_Res is
Set_Analyzed (N, True); Set_Analyzed (N, True);
end; end;
-- Protected functions can return on the secondary stack, in which -- Protected functions can return on the secondary stack, in which case
-- case we must trigger the transient scope mechanism. -- we must trigger the transient scope mechanism.
elsif Expander_Active elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam)) and then Requires_Transient_Scope (Etype (Nam))
then then
Establish_Transient_Scope (N, Sec_Stack => True); Establish_Transient_Scope (N, Manage_Sec_Stack => True);
end if; end if;
end Resolve_Entry_Call; end Resolve_Entry_Call;
......
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