From: Hristian Kirtchev Date: Wed, 18 Nov 2015 10:30:12 +0000 (+0100) Subject: re PR ada/66242 (Front-end error if exception propagation disabled) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7bf911b58345771e3be025a0b132912df4f566bd;p=gcc.git re PR ada/66242 (Front-end error if exception propagation disabled) 2015-11-18 Hristian Kirtchev PR ada/66242 * exp_ch3.adb (Default_Initialize_Object): Reimplemented. Abort defer / undefer pairs are now encapsulated in a block with an AT END handler. Partial finalization now takes restriction No_Exception_Propagation into account when generating blocks. * exp_ch7.adb Various reformattings. (Create_Finalizer): Change the generation of abort defer / undefer pairs and explain the lack of an AT END handler. (Process_Transient_Objects): Add generation of abort defer/undefer pairs. * exp_ch9.adb Various reformattings. (Build_Protected_Subprogram_Body): Use Build_Runtime_Call to construct a call to Abort_Defer. (Build_Protected_Subprogram_Call_Cleanup): Use Build_Runtime_Call to construct a call to Abort_Undefer. (Expand_N_Asynchronous_Select): Use Build_Runtime_Call to construct a call to Abort_Defer. * exp_intr.adb (Expand_Unc_Deallocation): Abort defer / undefer pairs are now encapsulated in a block with an AT END handler. Finalization now takes restriction No_Exception_Propagation into account when generating blocks. * exp_util.ads, exp_util.adb (Wrap_Cleanup_Procedure): Removed. From-SVN: r230531 --- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6fb3a598351..af245ec637f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -201,9 +201,9 @@ package body Exp_Ch3 is -- subprogram they rename is not frozen when the type is frozen. procedure Insert_Component_Invariant_Checks - (N : Node_Id; - Typ : Entity_Id; - Proc : Node_Id); + (N : Node_Id; + Typ : Entity_Id; + Proc : Node_Id); -- If a composite type has invariants and also has components with defined -- invariants. the component invariant procedure is inserted into the user- -- defined invariant procedure and added to the checks to be performed. @@ -5197,8 +5197,8 @@ package body Exp_Ch3 is if Ekind (Comp) = E_Component and then Chars (Comp) = Chars (Old_Comp) then - Set_Discriminant_Checking_Func (Comp, - Discriminant_Checking_Func (Old_Comp)); + Set_Discriminant_Checking_Func + (Comp, Discriminant_Checking_Func (Old_Comp)); end if; Next_Component (Old_Comp); @@ -6083,20 +6083,19 @@ package body Exp_Ch3 is -- Local variables - Abrt_Blk : Node_Id; - Abrt_HSS : Node_Id; - Abrt_Id : Entity_Id; - Abrt_Stmts : List_Id; - Aggr_Init : Node_Id; - Comp_Init : List_Id := No_List; - Fin_Call : Node_Id; - Fin_Stmts : List_Id := No_List; - Obj_Init : Node_Id := Empty; - Obj_Ref : Node_Id; - - Dummy : Entity_Id; - -- This variable captures a dummy internal entity, see the comment - -- associated with its use. + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + + Abrt_Blk : Node_Id; + Abrt_Blk_Id : Entity_Id; + Abrt_HSS : Node_Id; + Aggr_Init : Node_Id; + AUD : Entity_Id; + Comp_Init : List_Id := No_List; + Fin_Call : Node_Id; + Init_Stmts : List_Id := No_List; + Obj_Init : Node_Id := Empty; + Obj_Ref : Node_Id; -- Start of processing for Default_Initialize_Object @@ -6112,19 +6111,25 @@ package body Exp_Ch3 is return; end if; - -- Step 1: Initialize the object + -- The expansion performed by this routine is as follows: - if Needs_Finalization (Typ) and then not No_Initialization (N) then - Obj_Init := - Make_Init_Call - (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Typ); - end if; - - -- Step 2: Initialize the components of the object + -- begin + -- Abort_Defer; + -- Type_Init_Proc (Obj); + + -- begin + -- [Deep_]Initialize (Obj); + + -- exception + -- when others => + -- [Deep_]Finalize (Obj, Self => False); + -- raise; + -- end; + -- at end + -- Abort_Undefer_Direct; + -- end; - -- Do not initialize the components if their initialization is - -- prohibited. + -- Initialize the components of the object if Has_Non_Null_Base_Init_Proc (Typ) and then not No_Initialization (N) @@ -6154,7 +6159,8 @@ package body Exp_Ch3 is elsif Build_Equivalent_Aggregate then null; - -- Otherwise invoke the type init proc + -- Otherwise invoke the type init proc, generate: + -- Type_Init_Proc (Obj); else Obj_Ref := New_Object_Reference; @@ -6182,41 +6188,35 @@ package body Exp_Ch3 is Analyze_And_Resolve (Expression (N), Typ); end if; - -- Step 3: Add partial finalization and abort actions, generate: + -- Initialize the object, generate: + -- [Deep_]Initialize (Obj); + + if Needs_Finalization (Typ) and then not No_Initialization (N) then + Obj_Init := + Make_Init_Call + (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Typ); + end if; + + -- Build a special finalization block when both the object and its + -- controlled components are to be initialized. The block finalizes + -- the components if the object initialization fails. Generate: - -- Type_Init_Proc (Obj); -- begin - -- Deep_Initialize (Obj); + -- + -- exception -- when others => - -- Deep_Finalize (Obj, Self => False); + -- -- raise; -- end; - -- Step 3a: Build the finalization block (if applicable) - - -- The finalization block is required when both the object and its - -- controlled components are to be initialized. The block finalizes - -- the components if the object initialization fails. - if Has_Controlled_Component (Typ) and then Present (Comp_Init) and then Present (Obj_Init) - and then not Restriction_Active (No_Exception_Propagation) + and then Exceptions_OK then - -- Generate: - -- Type_Init_Proc (Obj); - - Fin_Stmts := Comp_Init; - - -- Generate: - -- begin - -- Deep_Initialize (Obj); - -- exception - -- when others => - -- Deep_Finalize (Obj, Self => False); - -- raise; - -- end; + Init_Stmts := Comp_Init; Fin_Call := Make_Final_Call @@ -6232,7 +6232,7 @@ package body Exp_Ch3 is Set_No_Elaboration_Check (Fin_Call); - Append_To (Fin_Stmts, + Append_To (Init_Stmts, Make_Block_Statement (Loc, Declarations => No_List, @@ -6250,100 +6250,93 @@ package body Exp_Ch3 is Make_Raise_Statement (Loc))))))); end if; - -- Finalization is not required, the initialization calls are passed - -- to the abort block building circuitry, generate: + -- Otherwise finalization is not required, the initialization calls + -- are passed to the abort block building circuitry, generate: -- Type_Init_Proc (Obj); - -- Deep_Initialize (Obj); + -- [Deep_]Initialize (Obj); else if Present (Comp_Init) then - Fin_Stmts := Comp_Init; + Init_Stmts := Comp_Init; end if; if Present (Obj_Init) then - if No (Fin_Stmts) then - Fin_Stmts := New_List; + if No (Init_Stmts) then + Init_Stmts := New_List; end if; - Append_To (Fin_Stmts, Obj_Init); + Append_To (Init_Stmts, Obj_Init); end if; end if; - -- Step 3b: Build the abort block (if applicable) - - -- The abort block is required when aborts are allowed in order to - -- protect both initialization calls. - - if Present (Comp_Init) and then Present (Obj_Init) then - if Abort_Allowed then - - -- Generate: - -- Abort_Defer; + -- Build an abort block to protect the initialization calls - Prepend_To - (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + if Abort_Allowed + and then Present (Comp_Init) + and then Present (Obj_Init) + then + -- Generate: + -- Abort_Defer; - -- Generate: - -- begin - -- Abort_Defer; - -- - -- at end - -- Abort_Undefer_Direct; - -- end; + Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - declare - AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); + -- When exceptions are propagated, abort deferral must take place + -- in the presence of initialization or finalization exceptions. + -- Generate: - begin - Abrt_HSS := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, - At_End_Proc => New_Occurrence_Of (AUD, Loc)); + -- begin + -- Abort_Defer; + -- + -- at end + -- Abort_Undefer_Direct; + -- end; - -- Present the Abort_Undefer_Direct function to the backend - -- so that it can inline the call to the function. + if Exceptions_OK then + AUD := RTE (RE_Abort_Undefer_Direct); - Add_Inlined_Body (AUD, N); - end; + Abrt_HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Init_Stmts, + At_End_Proc => New_Occurrence_Of (AUD, Loc)); Abrt_Blk := Make_Block_Statement (Loc, - Declarations => No_List, Handled_Statement_Sequence => Abrt_HSS); - Add_Block_Identifier (Abrt_Blk, Abrt_Id); - Expand_At_End_Handler (Abrt_HSS, Abrt_Id); + Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); + Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id); - Abrt_Stmts := New_List (Abrt_Blk); + -- Present the Abort_Undefer_Direct function to the backend so + -- that it can inline the call to the function. - -- Abort is not required + Add_Inlined_Body (AUD, N); - else - -- Generate a dummy entity to ensure that the internal symbols - -- are in sync when a unit is compiled with and without aborts. - -- The entity is a block with proper scope and type. + Init_Stmts := New_List (Abrt_Blk); - Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); - Set_Etype (Dummy, Standard_Void_Type); - Abrt_Stmts := Fin_Stmts; - end if; + -- Otherwise exceptions are not propagated. Generate: - -- No initialization calls present + -- Abort_Defer; + -- + -- Abort_Undefer; - else - Abrt_Stmts := Fin_Stmts; + else + Append_To (Init_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; end if; - -- Step 4: Insert the whole initialization sequence into the tree - -- If the object has a delayed freeze, as will be the case when - -- it has aspect specifications, the initialization sequence is - -- part of the freeze actions. + -- Insert the whole initialization sequence into the tree. If the + -- object has a delayed freeze, as will be the case when it has + -- aspect specifications, the initialization sequence is part of + -- the freeze actions. - if Has_Delayed_Freeze (Def_Id) then - Append_Freeze_Actions (Def_Id, Abrt_Stmts); - else - Insert_Actions_After (After, Abrt_Stmts); + if Present (Init_Stmts) then + if Has_Delayed_Freeze (Def_Id) then + Append_Freeze_Actions (Def_Id, Init_Stmts); + else + Insert_Actions_After (After, Init_Stmts); + end if; end if; end Default_Initialize_Object; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f4db92fb5c6..f5b97e2340c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1323,13 +1323,6 @@ package body Exp_Ch7 is ---------------------- procedure Create_Finalizer is - Body_Id : Entity_Id; - Fin_Body : Node_Id; - Fin_Spec : Node_Id; - Jump_Block : Node_Id; - Label : Node_Id; - Label_Id : Entity_Id; - function New_Finalizer_Name return Name_Id; -- Create a fully qualified name of a package spec or body finalizer. -- The generated name is of the form: xx__yy__finalize_[spec|body]. @@ -1380,6 +1373,15 @@ package body Exp_Ch7 is return Name_Find; end New_Finalizer_Name; + -- Local variables + + Body_Id : Entity_Id; + Fin_Body : Node_Id; + Fin_Spec : Node_Id; + Jump_Block : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id; + -- Start of processing for Create_Finalizer begin @@ -1532,16 +1534,17 @@ package body Exp_Ch7 is -- Protect the statements with abort defer/undefer. This is only when -- aborts are allowed and the clean up statements require deferral or - -- there are controlled objects to be finalized. + -- there are controlled objects to be finalized. Note that the abort + -- defer/undefer pair does not require an extra block because each + -- finalization exception is caught in its corresponding finalization + -- block. As a result, the call to Abort_Defer always takes place. if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then Prepend_To (Finalizer_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc))); + Build_Runtime_Call (Loc, RE_Abort_Defer)); Append_To (Finalizer_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc))); + Build_Runtime_Call (Loc, RE_Abort_Undefer)); end if; -- The local exception does not need to be reraised for library-level @@ -1596,7 +1599,8 @@ package body Exp_Ch7 is Defining_Unit_Name => Body_Id), Declarations => Finalizer_Decls, Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts)); + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Finalizer_Stmts)); -- Step 4: Spec and body insertion, analysis @@ -2806,9 +2810,7 @@ package body Exp_Ch7 is else -- Generate: - -- [Deep_]Finalize (Obj); -- No_Exception_Propagation - - -- begin -- Exception handlers allowed + -- begin -- [Deep_]Finalize (Obj); -- exception @@ -4727,6 +4729,8 @@ package body Exp_Ch7 is -- Raised : Boolean := False; -- begin + -- Abort_Defer; + -- begin -- Hook_N := null; -- [Deep_]Finalize (Ctrl_Trans_Obj_N); @@ -4752,26 +4756,8 @@ package body Exp_Ch7 is -- if Raised and not Abrt then -- Raise_From_Controlled_Operation (Ex); -- end if; - -- end; - - -- When restriction No_Exception_Propagation is active, the expansion - -- is as follows: - -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ; - -- Hook_1 : Ptr_Typ_1 := null; - -- Ctrl_Trans_Obj_1 : ...; - -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access; - -- . . . - -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ; - -- Hook_N : Ptr_Typ_N := null; - -- Ctrl_Trans_Obj_N : ...; - -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access; - - -- begin - -- Hook_N := null; - -- [Deep_]Finalize (Ctrl_Trans_Obj_N); - -- Hook_1 := null; - -- [Deep_]Finalize (Ctrl_Trans_Obj_1); + -- Abort_Undefer_Direct; -- end; -- Recognize a scenario where the transient context is an object @@ -4983,6 +4969,7 @@ package body Exp_Ch7 is -- When exception propagation is enabled wrap the hook clear -- statement and the finalization call into a block to catch -- potential exceptions raised during finalization. Generate: + -- begin -- [Temp := null;] -- [Deep_]Finalize (Obj_Ref); @@ -5037,6 +5024,20 @@ package body Exp_Ch7 is end loop; if Present (Blk_Decl) then + + -- Note that the abort defer / undefer pair does not require an + -- extra block because each finalization exception is caught in + -- its corresponding finalization block. As a result, the call to + -- Abort_Defer always takes place. + + if Abort_Allowed then + Prepend_To (Blk_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Defer)); + + Append_To (Blk_Stmts, + Build_Runtime_Call (Loc, RE_Abort_Undefer)); + end if; + Insert_After_And_Analyze (Blk_Ins, Blk_Decl); end if; end Process_Transient_Objects; @@ -5428,10 +5429,13 @@ package body Exp_Ch7 is function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Finalizer_Decls : List_Id := No_List; Finalizer_Data : Finalization_Exception_Data; Call : Node_Id; @@ -5442,9 +5446,6 @@ package body Exp_Ch7 is Loop_Id : Entity_Id; Stmts : List_Id; - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - procedure Build_Indexes; -- Generate the indexes used in the dimension loops @@ -5492,9 +5493,7 @@ package body Exp_Ch7 is -- Generate the block which houses the adjust or finalize call: - -- ; -- No_Exception_Propagation - - -- begin -- Exception handlers allowed + -- begin -- -- exception @@ -5567,7 +5566,7 @@ package body Exp_Ch7 is -- begin -- - -- if Raised and then not Abort then -- Expection handlers OK + -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; -- end; @@ -5575,8 +5574,7 @@ package body Exp_Ch7 is Stmts := New_List (Core_Loop); if Exceptions_OK then - Append_To (Stmts, - Build_Raise_Statement (Finalizer_Data)); + Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); end if; return @@ -5593,11 +5591,14 @@ package body Exp_Ch7 is --------------------------------- function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Final_List : constant List_Id := New_List; - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Final_List : constant List_Id := New_List; + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Counter_Id : Entity_Id; Dim : Int; F : Node_Id; @@ -5611,9 +5612,6 @@ package body Exp_Ch7 is Loop_Id : Node_Id; Stmts : List_Id; - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - function Build_Counter_Assignment return Node_Id; -- Generate the following assignment: -- Counter := V'Length (1) * @@ -5751,9 +5749,7 @@ package body Exp_Ch7 is -- if Counter > 0 then -- Counter := Counter - 1; -- else - -- [Deep_]Finalize (V (F1, ..., FN)); -- No_Except_Propagation - - -- begin -- Exceptions allowed + -- begin -- [Deep_]Finalize (V (F1, ..., FN)); -- exception -- when others => @@ -5852,18 +5848,17 @@ package body Exp_Ch7 is -- - -- if Raised and then not Abort then -- Exception handlers OK + -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); -- end if; - -- raise; -- Exception handlers OK + -- raise; -- end; Stmts := New_List (Build_Counter_Assignment, Final_Loop); if Exceptions_OK then - Append_To (Stmts, - Build_Raise_Statement (Finalizer_Data)); + Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); Append_To (Stmts, Make_Raise_Statement (Loc)); end if; @@ -6243,17 +6238,17 @@ package body Exp_Ch7 is ----------------------------- function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; Finalizer_Data : Finalization_Exception_Data; Finalizer_Decls : List_Id := No_List; Rec_Def : Node_Id; Var_Case : Node_Id; - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - function Process_Component_List_For_Adjust (Comps : Node_Id) return List_Id; -- Build all necessary adjust statements for a single component list @@ -6285,11 +6280,9 @@ package body Exp_Ch7 is Adj_Stmt : Node_Id; begin - -- Generate: - -- [Deep_]Adjust (V.Id); -- No_Exception_Propagation - - -- begin -- Exception handlers allowed + -- begin -- [Deep_]Adjust (V.Id); + -- exception -- when others => -- if not Raised then @@ -6523,10 +6516,9 @@ package body Exp_Ch7 is Skip_Self => True); -- Generate: - -- Deep_Adjust (V._parent, False); -- No_Except_Propagat - - -- begin -- Exceptions OK + -- begin -- Deep_Adjust (V._parent, False); + -- exception -- when Id : others => -- if not Raised then @@ -6568,10 +6560,9 @@ package body Exp_Ch7 is -- Generate: -- if F then - -- Adjust (V); -- No_Exception_Propagation - - -- begin -- Exception handlers allowed + -- begin -- Adjust (V); + -- exception -- when others => -- if not Raised then @@ -6635,8 +6626,7 @@ package body Exp_Ch7 is else if Exceptions_OK then - Append_To (Bod_Stmts, - Build_Raise_Statement (Finalizer_Data)); + Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); end if; return @@ -6654,8 +6644,11 @@ package body Exp_Ch7 is ------------------------------- function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; Counter : Int := 0; Finalizer_Data : Finalization_Exception_Data; @@ -6663,9 +6656,6 @@ package body Exp_Ch7 is Rec_Def : Node_Id; Var_Case : Node_Id; - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - function Process_Component_List_For_Finalize (Comps : Node_Id) return List_Id; -- Build all necessary finalization statements for a single component @@ -7096,10 +7086,9 @@ package body Exp_Ch7 is Skip_Self => True); -- Generate: - -- Deep_Finalize (V._parent, False); -- No_Except_Propag - - -- begin -- Exceptions OK + -- begin -- Deep_Finalize (V._parent, False); + -- exception -- when Id : others => -- if not Raised then @@ -7142,10 +7131,9 @@ package body Exp_Ch7 is -- Generate: -- if F then - -- Finalize (V); -- No_Exception_Propagation - -- begin -- Finalize (V); + -- exception -- when others => -- if not Raised then @@ -7207,8 +7195,7 @@ package body Exp_Ch7 is else if Exceptions_OK then - Append_To (Bod_Stmts, - Build_Raise_Statement (Finalizer_Data)); + Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data)); end if; return diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 0c9419e24e4..07dfb9bdc3e 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4315,15 +4315,18 @@ package body Exp_Ch9 is if Nkind (Op_Spec) = N_Function_Specification then if Exc_Safe then R := Make_Temporary (Loc, 'R'); + Unprot_Call := Make_Object_Declaration (Loc, Defining_Identifier => R, - Constant_Present => True, - Object_Definition => New_Copy (Result_Definition (N_Op_Spec)), - Expression => + Constant_Present => True, + Object_Definition => + New_Copy (Result_Definition (N_Op_Spec)), + Expression => Make_Function_Call (Loc, - Name => Make_Identifier (Loc, - Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Name => + Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), Parameter_Associations => Uactuals)); Return_Stmt := @@ -4331,12 +4334,14 @@ package body Exp_Ch9 is Expression => New_Occurrence_Of (R, Loc)); else - Unprot_Call := Make_Simple_Return_Statement (Loc, - Expression => Make_Function_Call (Loc, - Name => - Make_Identifier (Loc, - Chars => Chars (Defining_Unit_Name (N_Op_Spec))), - Parameter_Associations => Uactuals)); + Unprot_Call := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); end if; Lock_Kind := RE_Lock_Read_Only; @@ -4344,7 +4349,7 @@ package body Exp_Ch9 is else Unprot_Call := Make_Procedure_Call_Statement (Loc, - Name => + Name => Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), Parameter_Associations => Uactuals); @@ -4354,10 +4359,11 @@ package body Exp_Ch9 is -- Wrap call in block that will be covered by an at_end handler if not Exc_Safe then - Unprot_Call := Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Unprot_Call))); + Unprot_Call := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Unprot_Call))); end if; -- Make the protected subprogram body. This locks the protected @@ -4379,21 +4385,20 @@ package body Exp_Ch9 is Object_Parm := Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uObject), Selector_Name => Make_Identifier (Loc, Name_uObject)), Attribute_Name => Name_Unchecked_Access); - Lock_Stmt := Make_Procedure_Call_Statement (Loc, - Name => Lock_Name, - Parameter_Associations => New_List (Object_Parm)); + Lock_Stmt := + Make_Procedure_Call_Statement (Loc, + Name => Lock_Name, + Parameter_Associations => New_List (Object_Parm)); if Abort_Allowed then Stmts := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), - Parameter_Associations => Empty_List), + Build_Runtime_Call (Loc, RE_Abort_Defer), Lock_Stmt); else @@ -4417,20 +4422,21 @@ package body Exp_Ch9 is Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); if Nkind (Op_Spec) = N_Function_Specification then - Append (Return_Stmt, Stmts); - Append (Make_Block_Statement (Loc, - Declarations => New_List (Unprot_Call), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts)), Pre_Stmts); + Append_To (Stmts, Return_Stmt); + Append_To (Pre_Stmts, + Make_Block_Statement (Loc, + Declarations => New_List (Unprot_Call), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); Stmts := Pre_Stmts; end if; end if; Sub_Body := Make_Subprogram_Body (Loc, - Declarations => Empty_List, - Specification => P_Op_Spec, + Declarations => Empty_List, + Specification => P_Op_Spec, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); @@ -4594,11 +4600,7 @@ package body Exp_Ch9 is -- Abort_Undefer; if Abort_Allowed then - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => Empty_List)); + Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); end if; end Build_Protected_Subprogram_Call_Cleanup; @@ -7169,6 +7171,8 @@ package body Exp_Ch9 is Name => New_Occurrence_Of (Proc, Loc))); end Rewrite_Abortable_Part; + -- Start of processing for Expand_N_Asynchronous_Select + begin Process_Statements_For_Controlled_Objects (Trig); Process_Statements_For_Controlled_Objects (Abrt); @@ -7426,23 +7430,19 @@ package body Exp_Ch9 is Name_uDisp_Asynchronous_Select), Loc), - Parameter_Associations => - New_List ( - New_Copy_Tree (Obj), -- - New_Occurrence_Of (S, Loc), -- S - Make_Attribute_Reference (Loc, -- P'Address - Prefix => New_Occurrence_Of (P, Loc), - Attribute_Name => Name_Address), - Make_Identifier (Loc, Name_uD), -- D - New_Occurrence_Of (B, Loc)))); -- B + Parameter_Associations => New_List ( + New_Copy_Tree (Obj), -- + New_Occurrence_Of (S, Loc), -- S + Make_Attribute_Reference (Loc, -- P'Address + Prefix => New_Occurrence_Of (P, Loc), + Attribute_Name => Name_Address), + Make_Identifier (Loc, Name_uD), -- D + New_Occurrence_Of (B, Loc)))); -- B -- Generate: -- Abort_Defer; - Prepend_To (TaskE_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), - Parameter_Associations => No_List)); + Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); -- Generate: -- Abort_Undefer; @@ -7450,10 +7450,8 @@ package body Exp_Ch9 is Cleanup_Stmts := New_Copy_List_Tree (Astats); - Prepend_To (Cleanup_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => No_List)); + Prepend_To + (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions -- will generate a _clean for the additional status flag. @@ -7640,9 +7638,7 @@ package body Exp_Ch9 is Hdle := New_List (Build_Abort_Block_Handler (Loc)); - Prepend_To (Astats, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc))); + Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); Abortable_Block := Make_Block_Statement (Loc, @@ -7788,17 +7784,14 @@ package body Exp_Ch9 is Has_Created_Identifier => True, Is_Asynchronous_Call_Block => True); - if Exception_Mechanism = Back_End_Exceptions then - - -- Aborts are not deferred at beginning of exception handlers - -- in ZCX. + -- Aborts are not deferred at beginning of exception handlers in + -- ZCX. + if Exception_Mechanism = Back_End_Exceptions then Handler_Stmt := Make_Null_Statement (Loc); else - Handler_Stmt := Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => No_List); + Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer); end if; Stmts := New_List ( @@ -7881,9 +7874,7 @@ package body Exp_Ch9 is Hdle := New_List (Build_Abort_Block_Handler (Loc)); - Prepend_To (Astats, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc))); + Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); Abortable_Block := Make_Block_Statement (Loc, @@ -7927,10 +7918,7 @@ package body Exp_Ch9 is -- Protected the call against abort - Prepend_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), - Parameter_Associations => Empty_List)); + Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); end if; Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); @@ -10762,9 +10750,7 @@ package body Exp_Ch9 is -- analysis with unknown calls, so don't do it. if not CodePeer_Mode then - Call := - Make_Procedure_Call_Statement (Eloc, - Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Eloc)); + Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); Insert_Before (First (Statements (Handled_Statement_Sequence (Accept_Statement (Alt)))), diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index a76486b4432..ab30c1f6a05 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1022,6 +1022,7 @@ package body Exp_Intr is Abrt_Blk : Node_Id := Empty; Abrt_Blk_Id : Entity_Id; + Abrt_HSS : Node_Id; AUD : Entity_Id; Fin_Blk : Node_Id; Fin_Call : Node_Id; @@ -1031,10 +1032,6 @@ package body Exp_Intr is Gen_Code : Node_Id; Obj_Ref : Node_Id; - Dummy : Entity_Id; - -- This variable captures an unused dummy internal entity, see the - -- comment associated with its use. - begin -- Nothing to do if we know the argument is null @@ -1048,10 +1045,10 @@ package body Exp_Intr is -- Ex : Exception_Occurrence; -- Raised : Boolean := False; - -- begin -- aborts allowed + -- begin -- Abort_Defer; - -- begin -- exception propagation allowed + -- begin -- [Deep_]Finalize (Obj_Ref); -- exception @@ -1121,50 +1118,51 @@ package body Exp_Intr is Exception_Handlers => New_List ( Build_Exception_Handler (Fin_Data)))); - -- The finalization action must be protected by an abort defer - -- undefer pair when aborts are allowed. Generate: + -- Otherwise exception propagation is not allowed - -- begin - -- Abort_Defer; - -- - -- at end - -- Abort_Undefer_Direct; - -- end; + else + Fin_Blk := Fin_Call; + end if; - if Abort_Allowed then - AUD := RTE (RE_Abort_Undefer_Direct); + -- The finalization action must be protected by an abort defer and + -- undefer pair when aborts are allowed. Generate: - Abrt_Blk := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Build_Runtime_Call (Loc, RE_Abort_Defer), - Fin_Blk), - At_End_Proc => New_Occurrence_Of (AUD, Loc))); + -- begin + -- Abort_Defer; + -- + -- at end + -- Abort_Undefer_Direct; + -- end; - Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); + if Abort_Allowed then + AUD := RTE (RE_Abort_Undefer_Direct); - -- Present the Abort_Undefer_Direct function to the backend so - -- that it can inline the call to the function. + Abrt_HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Build_Runtime_Call (Loc, RE_Abort_Defer), + Fin_Blk), + At_End_Proc => New_Occurrence_Of (AUD, Loc)); - Add_Inlined_Body (AUD, N); - Append_To (Stmts, Abrt_Blk); + Abrt_Blk := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => Abrt_HSS); - -- Otherwise aborts are not allowed. Generate a dummy entity to - -- ensure that the internal symbols are in sync when a unit is - -- compiled with and without aborts. + Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); + Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id); - else - Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); - Append_To (Stmts, Fin_Blk); - end if; + -- Present the Abort_Undefer_Direct function to the backend so + -- that it can inline the call to the function. - -- Otherwise exception propagation is not allowed + Add_Inlined_Body (AUD, N); + + -- Otherwise aborts are not allowed else - Append_To (Stmts, Fin_Call); + Abrt_Blk := Fin_Blk; end if; + + Append_To (Stmts, Abrt_Blk); end if; -- For a task type, call Free_Task before freeing the ATCB. We used to @@ -1174,8 +1172,8 @@ package body Exp_Intr is -- (the task will be freed once it terminates). if Is_Task_Type (Desig_Typ) then - Append_To - (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); + Append_To (Stmts, + Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); -- For composite types that contain tasks, recurse over the structure -- to build the selectors for the task subcomponents. @@ -1411,15 +1409,6 @@ package body Exp_Intr is Rewrite (N, Gen_Code); Analyze (N); - - -- If we generated a block with an At_End_Proc, expand the exception - -- handler. We need to wait until after everything else is analyzed. - - if Present (Abrt_Blk) then - Expand_At_End_Handler - (HSS => Handled_Statement_Sequence (Abrt_Blk), - Blk_Id => Entity (Identifier (Abrt_Blk))); - end if; end Expand_Unc_Deallocation; ----------------------- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 5810dd58636..3d534bdcec5 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9453,19 +9453,4 @@ package body Exp_Util is and then not Is_Predicate_Function_M (S); end Within_Internal_Subprogram; - ---------------------------- - -- Wrap_Cleanup_Procedure -- - ---------------------------- - - procedure Wrap_Cleanup_Procedure (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Stseq : constant Node_Id := Handled_Statement_Sequence (N); - Stmts : constant List_Id := Statements (Stseq); - begin - if Abort_Allowed then - Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); - end if; - end Wrap_Cleanup_Procedure; - end Exp_Util; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 10fd70c7981..1357b3b1a97 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -1020,15 +1020,6 @@ package Exp_Util is -- predefined primitive operation. Some expansion activity (e.g. predicate -- checks) is disabled in such. - procedure Wrap_Cleanup_Procedure (N : Node_Id); - -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer call - -- at the start of the statement sequence, and an Abort_Undefer call at the - -- end of the statement sequence. All cleanup routines (i.e. those that are - -- called from "at end" handlers) must defer abort on entry and undefer - -- abort on exit. Note that it is assumed that the code for the procedure - -- does not contain any return statements which would allow the flow of - -- control to escape doing the undefer call. - private pragma Inline (Duplicate_Subexpr); pragma Inline (Force_Evaluation);