[Ada] PR ada/66242 Finalization with restriction No_Exception_Propagation
Arnaud Charlet
charlet@adacore.com
Wed Nov 18 10:32:00 GMT 2015
This patch adds abort defer / undefer pairs for partial finalization due to
failed initialization and as part of unchecked deallocation actions. The patch
also suppresses the generation of exception variables and handlers related to
finalization actions when restriction No_Exception_Propagation is in effect.
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-11-18 Hristian Kirtchev <kirtchev@adacore.com>
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.
-------------- next part --------------
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 230522)
+++ exp_ch7.adb (working copy)
@@ -1323,13 +1323,6 @@
----------------------
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 @@
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 @@
-- 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 @@
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 @@
else
-- Generate:
- -- [Deep_]Finalize (Obj); -- No_Exception_Propagation
-
- -- begin -- Exception handlers allowed
+ -- begin
-- [Deep_]Finalize (Obj);
-- exception
@@ -4727,6 +4729,8 @@
-- Raised : Boolean := False;
-- begin
+ -- Abort_Defer;
+
-- begin
-- Hook_N := null;
-- [Deep_]Finalize (Ctrl_Trans_Obj_N);
@@ -4752,26 +4756,8 @@
-- 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 @@
-- 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 @@
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 @@
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 @@
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 @@
-- Generate the block which houses the adjust or finalize call:
- -- <adjust or finalize call>; -- No_Exception_Propagation
-
- -- begin -- Exception handlers allowed
+ -- begin
-- <adjust or finalize call>
-- exception
@@ -5567,7 +5566,7 @@
-- begin
-- <core loop>
- -- 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 @@
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 @@
---------------------------------
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 @@
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 @@
-- 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 @@
-- <final loop>
- -- 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 @@
-----------------------------
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 @@
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 @@
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 @@
-- 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 @@
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 @@
-------------------------------
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 @@
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 @@
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 @@
-- Generate:
-- if F then
- -- Finalize (V); -- No_Exception_Propagation
-
-- begin
-- Finalize (V);
+
-- exception
-- when others =>
-- if not Raised then
@@ -7207,8 +7195,7 @@
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
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 230525)
+++ exp_util.adb (working copy)
@@ -9453,19 +9453,4 @@
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;
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 230524)
+++ exp_util.ads (working copy)
@@ -1020,15 +1020,6 @@
-- 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);
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 230529)
+++ exp_ch9.adb (working copy)
@@ -4315,15 +4315,18 @@
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 @@
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 @@
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 @@
-- 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 @@
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 @@
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 @@
-- 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 @@
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 @@
Name_uDisp_Asynchronous_Select),
Loc),
- Parameter_Associations =>
- New_List (
- New_Copy_Tree (Obj), -- <object>
- 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), -- <object>
+ 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 @@
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 @@
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 @@
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 @@
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 @@
-- 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 @@
-- 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)))),
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 230522)
+++ exp_intr.adb (working copy)
@@ -1022,6 +1022,7 @@
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 @@
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 @@
-- 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 @@
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;
- -- <Fin_Blk>
- -- 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;
+ -- <Fin_Blk>
+ -- 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 @@
-- (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 @@
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;
-----------------------
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 230522)
+++ exp_ch3.adb (working copy)
@@ -201,9 +201,9 @@
-- 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 @@
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 @@
-- 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;
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
- Dummy : Entity_Id;
- -- This variable captures a dummy internal entity, see the comment
- -- associated with its use.
+ 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,20 +6111,26 @@
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;
+ -- begin
+ -- Abort_Defer;
+ -- Type_Init_Proc (Obj);
- -- Step 2: Initialize the components of the object
+ -- begin
+ -- [Deep_]Initialize (Obj);
- -- Do not initialize the components if their initialization is
- -- prohibited.
+ -- exception
+ -- when others =>
+ -- [Deep_]Finalize (Obj, Self => False);
+ -- raise;
+ -- end;
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+ -- Initialize the components of the object
+
if Has_Non_Null_Base_Init_Proc (Typ)
and then not No_Initialization (N)
and then not Initialization_Suppressed (Typ)
@@ -6154,7 +6159,8 @@
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,42 +6188,36 @@
Analyze_And_Resolve (Expression (N), Typ);
end if;
- -- Step 3: Add partial finalization and abort actions, generate:
+ -- Initialize the object, generate:
+ -- [Deep_]Initialize (Obj);
- -- Type_Init_Proc (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:
+
-- begin
- -- Deep_Initialize (Obj);
+ -- <Obj_Init>
+
-- exception
-- when others =>
- -- Deep_Finalize (Obj, Self => False);
+ -- <Fin_Call>
-- 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);
+ Init_Stmts := Comp_Init;
- Fin_Stmts := Comp_Init;
-
- -- Generate:
- -- begin
- -- Deep_Initialize (Obj);
- -- exception
- -- when others =>
- -- Deep_Finalize (Obj, Self => False);
- -- raise;
- -- end;
-
Fin_Call :=
Make_Final_Call
(Obj_Ref => New_Object_Reference,
@@ -6232,7 +6232,7 @@
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 @@
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)
+ -- Build an abort block to protect the initialization calls
- -- The abort block is required when aborts are allowed in order to
- -- protect both initialization calls.
+ if Abort_Allowed
+ and then Present (Comp_Init)
+ and then Present (Obj_Init)
+ then
+ -- Generate:
+ -- Abort_Defer;
- if Present (Comp_Init) and then Present (Obj_Init) then
- if Abort_Allowed then
+ Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
- -- Generate:
- -- Abort_Defer;
+ -- When exceptions are propagated, abort deferral must take place
+ -- in the presence of initialization or finalization exceptions.
+ -- Generate:
- Prepend_To
- (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+ -- begin
+ -- Abort_Defer;
+ -- <Init_Stmts>
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
- -- Generate:
- -- begin
- -- Abort_Defer;
- -- <finalization statements>
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
+ if Exceptions_OK then
+ AUD := RTE (RE_Abort_Undefer_Direct);
- declare
- AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
+ Abrt_HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Init_Stmts,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
- begin
- Abrt_HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Fin_Stmts,
- At_End_Proc => New_Occurrence_Of (AUD, Loc));
-
- -- Present the Abort_Undefer_Direct function to the backend
- -- so that it can inline the call to the function.
-
- Add_Inlined_Body (AUD, N);
- end;
-
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;
+ -- <Init_Stmts>
+ -- 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;
More information about the Gcc-patches
mailing list