From dbe13a374e58cda45a1a06df8e2a689bcc24e1da Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Wed, 6 Jun 2007 12:26:05 +0200 Subject: [PATCH] exp_ch7.ads, [...] (Expand_Cleanup_Actions): Set Sloc of inserted cleanup code appropriately for GDB use. 2007-04-20 Ed Schonberg Thomas Quinot * exp_ch7.ads, exp_ch7.adb (Expand_Cleanup_Actions): Set Sloc of inserted cleanup code appropriately for GDB use. (Make_Deep_Proc): Use Make_Handler_For_Ctrl_Operation to create exception handler for Deep_Adjust or Deep_Finalize. (Make_Handler_For_Ctrl_Operation): New subprogram. When runtime entity Raise_From_Controlled_Operation is available, use a call to that subprogram instead of a plain "raise Program_Error" node to raise Program_Error if an exception is propagated from an Adjust or Finalize operation. (Insert_Actions_In_Scope_Around): If the statement to be wrapped appears in the optional statement list of a triggering alternative, the scope actions can be inserted directly there, and not in the list that includes the asynchronous select itself. From-SVN: r125400 --- gcc/ada/exp_ch7.adb | 231 ++++++++++++++++++++++++++++---------------- gcc/ada/exp_ch7.ads | 7 +- 2 files changed, 155 insertions(+), 83 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 144d20b6f21..6dcfae82809 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -40,7 +40,6 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Lib; use Lib; -with Hostparm; use Hostparm; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -58,6 +57,7 @@ with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -90,27 +90,33 @@ package body Exp_Ch7 is -- declaration and the secondary stack deallocation is done in the -- proper enclosing scope (see Wrap_Transient_Declaration for details) - -- Note about function returning tagged types: It has been decided to - -- always allocate their result in the secondary stack while it is not + -- Note about functions returning tagged types: It has been decided to + -- always allocate their result in the secondary stack, even though is not -- absolutely mandatory when the tagged type is constrained because the -- caller knows the size of the returned object and thus could allocate the - -- result in the primary stack. But, allocating them always in the - -- secondary stack simplifies many implementation hassles: + -- result in the primary stack. An exception to this is when the function + -- builds its result in place, as is done for functions with inherently + -- limited result types for Ada 2005. In that case, certain callers may + -- pass the address of a constrained object as the target object for the + -- function result. - -- - If it is dispatching function call, the computation of the size of + -- By allocating tagged results in the secondary stack a number of + -- implementation difficulties are avoided: + + -- - If it is a dispatching function call, the computation of the size of -- the result is possible but complex from the outside. -- - If the returned type is controlled, the assignment of the returned -- value to the anonymous object involves an Adjust, and we have no - -- easy way to access the anonymous object created by the back-end + -- easy way to access the anonymous object created by the back end. -- - If the returned type is class-wide, this is an unconstrained type - -- anyway + -- anyway. - -- Furthermore, the little loss in efficiency which is the result of this - -- decision is not such a big deal because function returning tagged types - -- are not very much used in real life as opposed to functions returning - -- access to a tagged type + -- Furthermore, the small loss in efficiency which is the result of this + -- decision is not such a big deal because functions returning tagged types + -- are not as common in practice compared to functions returning access to + -- a tagged type. -------------------------------------------------- -- Transient Blocks and Finalization Management -- @@ -245,8 +251,8 @@ package body Exp_Ch7 is -- controlled components (Has_Controlled_Component flag set). In the first -- case the procedures to call are the user-defined primitive operations -- Initialize/Adjust/Finalize. In the second case, GNAT generates - -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge of - -- calling the former procedures on the controlled components. + -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge + -- of calling the former procedures on the controlled components. -- For records with Has_Controlled_Component set, a hidden "controller" -- component is inserted. This controller component contains its own @@ -255,9 +261,9 @@ package body Exp_Ch7 is -- technique facilitates the management of objects whose number of -- controlled components changes during execution. This controller -- component is itself controlled and is attached to the upper-level - -- finalization chain. Its adjust primitive is in charge of calling - -- adjust on the components and adusting the finalization pointer to - -- match their new location (see a-finali.adb). + -- finalization chain. Its adjust primitive is in charge of calling adjust + -- on the components and adusting the finalization pointer to match their + -- new location (see a-finali.adb). -- It is not possible to use a similar technique for arrays that have -- Has_Controlled_Component set. In this case, deep procedures are @@ -265,11 +271,11 @@ package body Exp_Ch7 is -- detachment on the finalization list for all component. -- Initialize calls: they are generated for declarations or dynamic - -- allocations of Controlled objects with no initial value. They are - -- always followed by an attachment to the current Finalization - -- Chain. For the dynamic allocation case this the chain attached to - -- the scope of the access type definition otherwise, this is the chain - -- of the current scope. + -- allocations of Controlled objects with no initial value. They are always + -- followed by an attachment to the current Finalization Chain. For the + -- dynamic allocation case this the chain attached to the scope of the + -- access type definition otherwise, this is the chain of the current + -- scope. -- Adjust Calls: They are generated on 2 occasions: (1) for -- declarations or dynamic allocations of Controlled objects with an @@ -280,21 +286,26 @@ package body Exp_Ch7 is -- Finalization Calls: They are generated on (1) scope exit, (2) -- assignments, (3) unchecked deallocations. In case (3) they have to -- be detached from the final chain, in case (2) they must not and in - -- case (1) this is not important since we are exiting the scope - -- anyway. + -- case (1) this is not important since we are exiting the scope anyway. -- Other details: - -- - Type extensions will have a new record controller at each derivation - -- level containing controlled components. - -- - For types that are both Is_Controlled and Has_Controlled_Components, - -- the record controller and the object itself are handled separately. - -- It could seem simpler to attach the object at the end of its record - -- controller but this would not tackle view conversions properly. - -- - A classwide type can always potentially have controlled components - -- but the record controller of the corresponding actual type may not - -- be known at compile time so the dispatch table contains a special - -- field that allows to compute the offset of the record controller - -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset + + -- Type extensions will have a new record controller at each derivation + -- level containing controlled components. The record controller for + -- the parent/ancestor is attached to the finalization list of the + -- extension's record controller (i.e. the parent is like a component + -- of the extension). + + -- For types that are both Is_Controlled and Has_Controlled_Components, + -- the record controller and the object itself are handled separately. + -- It could seem simpler to attach the object at the end of its record + -- controller but this would not tackle view conversions properly. + + -- A classwide type can always potentially have controlled components + -- but the record controller of the corresponding actual type may not + -- be known at compile time so the dispatch table contains a special + -- field that allows to compute the offset of the record controller + -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. -- Here is a simple example of the expansion of a controlled block : @@ -1031,6 +1042,12 @@ package body Exp_Ch7 is Wrap_Node : Node_Id; begin + -- Nothing to do for virtual machines where memory is GCed + + if VM_Target /= No_VM then + return; + end if; + -- Do not create a transient scope if we are already inside one for S in reverse Scope_Stack.First .. Scope_Stack.Last loop @@ -1066,7 +1083,7 @@ package body Exp_Ch7 is null; else - New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); + Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); Set_Scope_Is_Transient; if Sec_Stack then @@ -1089,27 +1106,25 @@ package body Exp_Ch7 is ---------------------------- procedure Expand_Cleanup_Actions (N : Node_Id) is - Loc : Source_Ptr; - S : constant Entity_Id := - Current_Scope; - Flist : constant Entity_Id := - Finalization_Chain_Entity (S); - Is_Task : constant Boolean := - (Nkind (Original_Node (N)) = N_Task_Body); - Is_Master : constant Boolean := + S : constant Entity_Id := Current_Scope; + Flist : constant Entity_Id := Finalization_Chain_Entity (S); + Is_Task : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body; + + Is_Master : constant Boolean := Nkind (N) /= N_Entry_Body and then Is_Task_Master (N); - Is_Protected : constant Boolean := + Is_Protected : constant Boolean := Nkind (N) = N_Subprogram_Body and then Is_Protected_Subprogram_Body (N); - Is_Task_Allocation : constant Boolean := + Is_Task_Allocation : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N); - Is_Asynchronous_Call : constant Boolean := + Is_Asynchronous_Call : constant Boolean := Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N); Clean : Entity_Id; + Loc : Source_Ptr; Mark : Entity_Id := Empty; New_Decls : constant List_Id := New_List; Blok : Node_Id; @@ -1120,21 +1135,19 @@ package body Exp_Ch7 is Old_Poll : Boolean; begin - - -- Compute a location that is not directly in the user code in - -- order to avoid to generate confusing debug info. A good - -- approximation is the name of the outer user-defined scope - - declare - S1 : Entity_Id := S; - - begin - while not Comes_From_Source (S1) and then S1 /= Standard_Standard loop - S1 := Scope (S1); - end loop; - - Loc := Sloc (S1); - end; + -- If we are generating expanded code for debugging purposes, use + -- the Sloc of the point of insertion for the cleanup code. The Sloc + -- will be updated subsequently to reference the proper line in the + -- .dg file. If we are not debugging generated code, use instead + -- No_Location, so that no debug information is generated for the + -- cleanup code. This makes the behavior of the NEXT command in GDB + -- monotonic, and makes the placement of breakpoints more accurate. + + if Debug_Generated_Code then + Loc := Sloc (S); + else + Loc := No_Location; + end if; -- There are cleanup actions only if the secondary stack needs -- releasing or some finalizations are needed or in the context @@ -1194,12 +1207,12 @@ package body Exp_Ch7 is -- If secondary stack is in use, expand: -- _Mxx : constant Mark_Id := SS_Mark; - -- Suppress calls to SS_Mark and SS_Release if Java_VM, - -- since we never use the secondary stack on the JVM. + -- Suppress calls to SS_Mark and SS_Release if VM_Target, + -- since we never use the secondary stack on the VM. if Uses_Sec_Stack (Current_Scope) and then not Sec_Stack_Needed_For_Return (Current_Scope) - and then not Java_VM + and then VM_Target = No_VM then Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); Append_To (New_Decls, @@ -1565,7 +1578,7 @@ package body Exp_Ch7 is -- This is done only for non-generic packages if Ekind (Ent) = E_Package then - New_Scope (Corresponding_Spec (N)); + Push_Scope (Corresponding_Spec (N)); Build_Task_Activation_Call (N); Pop_Scope; end if; @@ -1629,8 +1642,7 @@ package body Exp_Ch7 is -- have a specific separate compilation unit for that). if No_Body then - - New_Scope (Defining_Entity (N)); + Push_Scope (Defining_Entity (N)); if Has_RACW (Defining_Entity (N)) then @@ -2016,12 +2028,17 @@ package body Exp_Ch7 is Target : Node_Id; begin - -- If the node to be wrapped is the triggering alternative of an + -- If the node to be wrapped is the triggering statement of an -- asynchronous select, it is not part of a statement list. The -- actions must be inserted before the Select itself, which is - -- part of some list of statements. + -- part of some list of statements. Note that the triggering + -- alternative includes the triggering statement and an optional + -- statement list. If the node to be wrapped is part of that list, + -- the normal insertion applies. - if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative then + if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative + and then not Is_List_Member (Node_To_Be_Wrapped) + then Target := Parent (Parent (Node_To_Be_Wrapped)); else Target := N; @@ -2661,12 +2678,7 @@ package body Exp_Ch7 is Parameter_Type => New_Reference_To (Type_B, Loc))); if Prim = Finalize_Case or else Prim = Adjust_Case then - Handler := New_List ( - Make_Implicit_Exception_Handler (Loc, - Exception_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Raise_Program_Error (Loc, - Reason => PE_Finalize_Raised_Exception)))); + Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc)); end if; Proc_Name := @@ -2932,6 +2944,61 @@ package body Exp_Ch7 is return Res; end Make_Final_Call; + ------------------------------------- + -- Make_Handler_For_Ctrl_Operation -- + ------------------------------------- + + -- Generate: + + -- when E : others => + -- Raise_From_Controlled_Operation (X => E); + + -- or: + + -- when others => + -- raise Program_Error [finalize raised exception]; + + -- depending on whether Raise_From_Controlled_Operation is available + + function Make_Handler_For_Ctrl_Operation + (Loc : Source_Ptr) return Node_Id + is + E_Occ : Entity_Id; + -- Choice parameter (for the first case above) + + Raise_Node : Node_Id; + -- Procedure call or raise statement + + begin + if RTE_Available (RE_Raise_From_Controlled_Operation) then + + -- Standard runtime: add choice parameter E, and pass it to + -- Raise_From_Controlled_Operation so that the original exception + -- name and message can be recorded in the exception message for + -- Program_Error. + + E_Occ := Make_Defining_Identifier (Loc, Name_E); + Raise_Node := Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Raise_From_Controlled_Operation), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (E_Occ, Loc))); + + else + -- Restricted runtime: exception messages are not supported + + E_Occ := Empty; + Raise_Node := Make_Raise_Program_Error (Loc, + Reason => PE_Finalize_Raised_Exception); + end if; + + return Make_Implicit_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Choice_Parameter => E_Occ, + Statements => New_List (Raise_Node)); + end Make_Handler_For_Ctrl_Operation; + -------------------- -- Make_Init_Call -- -------------------- @@ -3069,7 +3136,8 @@ package body Exp_Ch7 is begin -- Case where only secondary stack use is involved - if Uses_Sec_Stack (Current_Scope) + if VM_Target = No_VM + and then Uses_Sec_Stack (Current_Scope) and then No (Flist) and then Nkind (Action) /= N_Return_Statement and then Nkind (Par) /= N_Exception_Handler @@ -3136,7 +3204,6 @@ package body Exp_Ch7 is declare Last_Inserted : Node_Id := Prev (Action); - begin if Present (Last_Inserted) then Freeze_All (First_Entity (Current_Scope), Last_Inserted); @@ -3340,7 +3407,7 @@ package body Exp_Ch7 is -- released upon its exit unless this is a function that returns on -- the sec stack in which case this will be done by the caller. - if Uses_SS then + if VM_Target = No_VM and then Uses_SS then S := Enclosing_Dynamic_Scope (S); if Ekind (S) = E_Function @@ -3428,7 +3495,7 @@ package body Exp_Ch7 is -- end _Clean; -- begin - -- ; + -- ; -- at end -- _Clean; -- end; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index a062fef3921..ebaa1f3f63b 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -24,6 +24,7 @@ -- -- ------------------------------------------------------------------------------ +with Namet; use Namet; with Types; use Types; package Exp_Ch7 is @@ -163,6 +164,10 @@ package Exp_Ch7 is -- say attach the result of the call to the current finalization list, -- which is the one of the transient scope created for such constructs. + function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; + -- Generate an implicit exception handler with an 'others' choice, + -- converting any occurrence to a raise of Program_Error. + -------------------------------------------- -- Task and Protected Object finalization -- -------------------------------------------- -- 2.30.2