From 66c0fa2cc9a2dbe62db5bed4fe5310d2e5912baf Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Mon, 21 May 2018 14:49:52 +0000 Subject: [PATCH] [Ada] Premature secondary stack reclamation This patch modifies the creation of transient scopes to eliminate potential premature secondary stack reclamations when there is no suitable transient context and the scope was intended to manage the secondary stack. Instead, the logic was changed to accommodate a special case where an assignment with suppressed controlled actions that appears within a type initialization procedure requires secondary stack reclamation. The patch also corrects the handling of function calls which utilize the secondary stack in loop parameter specifications. Previously the predicate which determined whether the function will utilize the secondary stack was not accurate enough, and in certain cases could lead to leaks. ------------ -- Source -- ------------ -- iterators.ads package Iterators is type Iterator is limited interface; type Iterator_Access is access all Iterator'Class; function Next (I : in out Iterator; Element : out Character) return Boolean is abstract; procedure Iterate (I : in out Iterator'Class; Proc : access procedure (Element : Character)); end Iterators; -- iterators.adb package body Iterators is procedure Iterate (I : in out Iterator'Class; Proc : access procedure (Element : Character)) is Element : Character; begin while I.Next (Element) loop Proc (Element); end loop; end Iterate; end Iterators; -- base.ads with Iterators; use Iterators; package Base is type String_Access is access all String; type Node is tagged record S : String_Access; end record; type Node_Access is access all Node'Class; type Node_Array is array (Positive range <>) of Node_Access; function As_Array (N : Node_Access) return Node_Array; function Get_String (C : Character) return String; type Node_Iterator is limited new Iterator with record Node : Node_Access; I : Positive; end record; overriding function Next (It : in out Node_Iterator; Element : out Character) return Boolean; function Constructor_1 (N : Node_Access) return Node_Iterator; function Constructor_2 (N : Node_Access) return Node_Iterator; end Base; -- base.adb package body Base is function As_Array (N : Node_Access) return Node_Array is begin return (1 => N); end As_Array; function Get_String (C : Character) return String is begin return (1 .. 40 => C); end Get_String; function Next (It : in out Node_Iterator; Element : out Character) return Boolean is begin if It.I > It.Node.S'Last then return False; else It.I := It.I + 1; Element := It.Node.S (It.I - 1); return True; end if; end Next; function Constructor_1 (N : Node_Access) return Node_Iterator is begin return Node_Iterator'(N, 1); end Constructor_1; function Constructor_2 (N : Node_Access) return Node_Iterator is begin return Constructor_1 (As_Array (N) (1)); end Constructor_2; end Base; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Base; use Base; with Iterators; use Iterators; procedure Main is N : constant Node_Access := new Node'(S => new String'("hello world")); procedure Process (C : Character) is begin Put_Line (Get_String (C)); end Process; C : Iterator'Class := Constructor_2 (N); begin C.Iterate (Process'Access); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee llllllllllllllllllllllllllllllllllllllll llllllllllllllllllllllllllllllllllllllll oooooooooooooooooooooooooooooooooooooooo wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww oooooooooooooooooooooooooooooooooooooooo rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr llllllllllllllllllllllllllllllllllllllll dddddddddddddddddddddddddddddddddddddddd 2018-05-21 Hristian Kirtchev gcc/ada/ * exp_ch7.adb (Establish_Transient_Scope): Code cleanup. Do not delegate the secondary stack management when there is no suitable transient context, and the transient scope was intended to manage the secondary stack because this causes premature reclamation. Change the transient scope creation logic by special casing assignment statements of controlled components for type initialization procedures. (Find_Node_To_Be_Wrapped): Renamed to Find_Transient_Context. Update the comment on usage. (Find_Transient_Context): Change the initinte loop into a while loop. Iterations schemes and iterator specifications are not valid transient contexts because they rely on special processing. Assignment statements are now treated as a normal transient context, special cases are handled by the caller. Add special processing for pragma Check. (Is_OK_Construct): Removed. Its functionality has been merged in routine Find_Transient_Context. * sem_ch5.adb (Check_Call): Reimplemented. Add code to properly retrieve the subprogram being invoked. Use a more accurate predicate (Requires_Transient_Scope) to determine that the function will emply the secondary stack. From-SVN: r260443 --- gcc/ada/ChangeLog | 22 ++++++ gcc/ada/exp_ch7.adb | 188 +++++++++++++++++++++++++++------------------------- gcc/ada/sem_ch5.adb | 37 +++++------ 3 files changed, 136 insertions(+), 111 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 33500f3..e729f18 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2018-04-04 Hristian Kirtchev + + * exp_ch7.adb (Establish_Transient_Scope): Code cleanup. Do not + delegate the secondary stack management when there is no suitable + transient context, and the transient scope was intended to manage the + secondary stack because this causes premature reclamation. Change the + transient scope creation logic by special casing assignment statements + of controlled components for type initialization procedures. + (Find_Node_To_Be_Wrapped): Renamed to Find_Transient_Context. Update + the comment on usage. + (Find_Transient_Context): Change the initinte loop into a while loop. + Iterations schemes and iterator specifications are not valid transient + contexts because they rely on special processing. Assignment statements + are now treated as a normal transient context, special cases are + handled by the caller. Add special processing for pragma Check. + (Is_OK_Construct): Removed. Its functionality has been merged in + routine Find_Transient_Context. + * sem_ch5.adb (Check_Call): Reimplemented. Add code to properly + retrieve the subprogram being invoked. Use a more accurate predicate + (Requires_Transient_Scope) to determine that the function will emply + the secondary stack. + 2018-04-04 Piotr Trojanek * ada_get_targ.adb: Fix subprogram body headers. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index e669454..9d1919a 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -125,10 +125,10 @@ package body Exp_Ch7 is -- Transient Blocks and Finalization Management -- -------------------------------------------------- - function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; - -- N is a node which may generate a transient scope. Loop over the parent - -- pointers of N until we find the appropriate node to wrap. If it returns - -- Empty, it means that no transient scope is needed in this context. + function Find_Transient_Context (N : Node_Id) return Node_Id; + -- Locate a suitable context for arbitrary node N which may need to be + -- serviced by a transient scope. Return Empty if no suitable context is + -- available. procedure Insert_Actions_In_Scope_Around (N : Node_Id; @@ -4082,10 +4082,6 @@ package body Exp_Ch7 is -- Examine the scope stack looking for the nearest enclosing transient -- scope. Return Empty if no such scope exists. - function Is_OK_Construct (Constr : Node_Id) return Boolean; - -- Determine whether arbitrary node Constr is a suitable construct which - -- requires handling by a transient scope. - function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean; -- Determine whether arbitrary Id denotes a package or subprogram [body] @@ -4224,40 +4220,6 @@ package body Exp_Ch7 is 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 -- ------------------------------ @@ -4274,8 +4236,8 @@ package body Exp_Ch7 is -- Local variables - Scop_Id : constant Entity_Id := Find_Enclosing_Transient_Scope; - Constr : Node_Id; + Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope; + Context : Node_Id; -- Start of processing for Establish_Transient_Scope @@ -4283,13 +4245,13 @@ package body Exp_Ch7 is -- Do not create a new transient scope if there is an existing transient -- scope on the stack. - if Present (Scop_Id) then + if Present (Trans_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); + Set_Uses_Sec_Stack (Trans_Id); end if; return; @@ -4299,18 +4261,41 @@ package body Exp_Ch7 is -- scopes. Locate the proper construct which must be serviced by a new -- transient scope. - Constr := Find_Node_To_Be_Wrapped (N); + Context := Find_Transient_Context (N); - if Is_OK_Construct (Constr) then - Create_Transient_Scope (Constr); + if Present (Context) then + if Nkind (Context) = N_Assignment_Statement then - -- 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. + -- An assignment statement with suppressed controlled semantics + -- does not need a transient scope because finalization is not + -- desirable at this point. Note that No_Ctrl_Actions is also + -- set for non-controlled assignments to suppress dispatching + -- _assign. - elsif Manage_Sec_Stack then - Delegate_Sec_Stack_Management; + if No_Ctrl_Actions (Context) + and then Needs_Finalization (Etype (Name (Context))) + then + -- When a controlled component is initialized by a function + -- call, the result on the secondary stack is always assigned + -- to the component. Signal the nearest suitable scope that it + -- is safe to manage the secondary stack. + + if Manage_Sec_Stack and then Within_Init_Proc then + Delegate_Sec_Stack_Management; + end if; + + -- Otherwise the assignment is a normal transient context and thus + -- requires a transient scope. + + else + Create_Transient_Scope (Context); + end if; + + -- General case + + else + Create_Transient_Scope (Context); + end if; end if; end Establish_Transient_Scope; @@ -4815,18 +4800,18 @@ package body Exp_Ch7 is end if; end Expand_N_Package_Declaration; - ----------------------------- - -- Find_Node_To_Be_Wrapped -- - ----------------------------- + ---------------------------- + -- Find_Transient_Context -- + ---------------------------- - function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is + function Find_Transient_Context (N : Node_Id) return Node_Id is Curr : Node_Id; Prev : Node_Id; begin Curr := N; Prev := Empty; - loop + while Present (Curr) loop case Nkind (Curr) is -- Declarations @@ -4858,58 +4843,66 @@ package body Exp_Ch7 is | N_Entry_Body_Formal_Part | N_Exit_Statement | N_If_Statement - | N_Iteration_Scheme | N_Terminate_Alternative => pragma Assert (Present (Prev)); return Prev; - -- Assignment statements are usually wrapped in a transient block - -- except when they are generated as part of controlled aggregate - -- 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 - return Empty; - else - return Curr; - end if; - - -- An entry of procedure call is usually wrapped except when it - -- acts as the alternative of a conditional or timed entry call. - -- In that case wrap the context of the alternative. + return Curr; when N_Entry_Call_Statement | N_Procedure_Call_Statement => + -- When an entry or procedure call acts as the alternative of a + -- conditional or timed entry call, the proper context is that + -- of the alternative. + 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)); + + -- General case for entry or procedure calls + else return Curr; end if; - when N_Pragma - | N_Raise_Statement - => - return Curr; + when N_Pragma => + + -- Pragma Check is not a valid transient context in GNATprove + -- mode because the pragma must remain unchanged. + + if GNATprove_Mode + and then Get_Pragma_Id (Curr) = Pragma_Check + then + return Empty; + + -- General case for pragmas + + else + return Curr; + end if; - -- A return statement is not wrapped when the associated function - -- would require wrapping. + when N_Raise_Statement => + return Curr; when N_Simple_Return_Statement => + + -- A return statement is not a valid transient context when the + -- function itself requires transient scope management because + -- the result will be reclaimed too early. + if Requires_Transient_Scope (Etype (Return_Applies_To (Return_Statement_Entity (Curr)))) then return Empty; + + -- General case for return statements + else return Curr; end if; @@ -4921,12 +4914,25 @@ package body Exp_Ch7 is 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. + -- An iteration scheme or an Ada 2012 iterator specification is + -- not a valid context because Analyze_Iteration_Scheme already + -- employs special processing for them. + + when N_Iteration_Scheme + | N_Iterator_Specification + => + return Empty; when N_Loop_Parameter_Specification => - return Parent (Curr); + + -- An iteration scheme is not a valid context because routine + -- Analyze_Iteration_Scheme already employs special processing. + + if Nkind (Parent (Curr)) = N_Iteration_Scheme then + return Empty; + else + return Parent (Curr); + end if; -- Termination @@ -4963,7 +4969,9 @@ package body Exp_Ch7 is Prev := Curr; Curr := Parent (Curr); end loop; - end Find_Node_To_Be_Wrapped; + + return Empty; + end Find_Transient_Context; ---------------------------------- -- Has_New_Controlled_Component -- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index b94c9e8..2a3b1ff 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2779,7 +2779,6 @@ package body Sem_Ch5 is ------------------------------------ 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 @@ -2788,36 +2787,32 @@ package body Sem_Ch5 is ---------------- function Check_Call (N : Node_Id) return Traverse_Result is - Nam : Node_Id; - Subp : Entity_Id; - Return_Typ : Entity_Id; + Nam : Node_Id; + Subp : Entity_Id; + Typ : Entity_Id; begin if Nkind (N) = N_Function_Call then Nam := Name (N); - -- Call using access to subprogram with explicit dereference - - if Nkind (Nam) = N_Explicit_Dereference then - Subp := Etype (Nam); - - -- Call using a selected component notation or Ada 2005 object - -- operation notation + -- Obtain the subprogram being invoked - elsif Nkind (Nam) = N_Selected_Component then - Subp := Entity (Selector_Name (Nam)); + loop + if Nkind (Nam) = N_Explicit_Dereference then + Nam := Prefix (Nam); - -- Common case + elsif Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); - else - Subp := Entity (Nam); - end if; + else + exit; + end if; + end loop; - Return_Typ := Etype (Subp); + Subp := Entity (Nam); + Typ := Etype (Subp); - if Is_Composite_Type (Return_Typ) - and then not Is_Constrained (Return_Typ) - then + if Requires_Transient_Scope (Typ) then return Abandon; elsif Sec_Stack_Needed_For_Return (Subp) then -- 2.7.4