Skip to content

R
riscv-gcc-1
Commit 7bf911b5 by Hristian Kirtchev Committed by Arnaud Charlet
Options

re PR ada/66242 (Front-end error if exception propagation disabled) 

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.

From-SVN: r230531
parent 8ebcad86
Showing with 55 additions and 104 deletions
gcc/ada/exp_ch9.adb
......@@ -4315,14 +4315,17 @@ 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)),
Object_Definition =>
New_Copy (Result_Definition (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
......@@ -4331,8 +4334,10 @@ package body Exp_Ch9 is
Expression => New_Occurrence_Of (R, Loc));
else
Unprot_Call := Make_Simple_Return_Statement (Loc,
Expression => Make_Function_Call (Loc,
Unprot_Call :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
......@@ -4354,7 +4359,8 @@ 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,
Unprot_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call)));
......@@ -4385,15 +4391,14 @@ package body Exp_Ch9 is
Selector_Name => Make_Identifier (Loc, Name_uObject)),
Attribute_Name => Name_Unchecked_Access);
Lock_Stmt := Make_Procedure_Call_Statement (Loc,
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,12 +4422,13 @@ 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,
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)), Pre_Stmts);
Statements => Stmts)));
Stmts := Pre_Stmts;
end if;
end if;
......@@ -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,8 +7430,7 @@ package body Exp_Ch9 is
Name_uDisp_Asynchronous_Select),
Loc),
Parameter_Associations =>
New_List (
Parameter_Associations => New_List (
New_Copy_Tree (Obj), -- <object>
New_Occurrence_Of (S, Loc), -- S
Make_Attribute_Reference (Loc, -- P'Address
......@@ -7439,10 +7442,7 @@ package body Exp_Ch9 is
-- 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)))),
......
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,7 +1118,13 @@ package body Exp_Intr is
Exception_Handlers => New_List (
Build_Exception_Handler (Fin_Data))));
-- The finalization action must be protected by an abort defer
-- Otherwise exception propagation is not allowed
else
Fin_Blk := Fin_Call;
end if;
-- The finalization action must be protected by an abort defer and
-- undefer pair when aborts are allowed. Generate:
-- begin
......@@ -1134,37 +1137,32 @@ package body Exp_Intr is
if Abort_Allowed then
AUD := RTE (RE_Abort_Undefer_Direct);
Abrt_Blk :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
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)));
At_End_Proc => New_Occurrence_Of (AUD, Loc));
Abrt_Blk :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence => Abrt_HSS);
Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
-- Present the Abort_Undefer_Direct function to the backend so
-- that it can inline the call to the function.
Add_Inlined_Body (AUD, N);
Append_To (Stmts, Abrt_Blk);
-- 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.
-- Otherwise aborts are not allowed
else
Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
Append_To (Stmts, Fin_Blk);
Abrt_Blk := Fin_Blk;
end if;
-- Otherwise exception propagation is not allowed
else
Append_To (Stmts, Fin_Call);
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;
-----------------------
......
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;
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);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment