Aborts are deferred just before propagating an exception and undefered at the
beginning of usual exception handler. But this mechanism is not necessary
if ZCX propagation is used (as aborts are synchronous in this case) and
prevents from using foreign (eg C++) exceptions are aborts won't be always
deferred before entering in the exception handlers.
No functionnal changes so no testcase.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-29 Tristan Gingold <ging...@adacore.com>
* exp_sel.ads (Build_Abort_BLock_Handler): New function spec.
Adjust comment.
* exp_sel.adb (Build_Abort_Block): Use Build_Abort_Block_Handler.
(Build_Abort_Block_Handler): New function to build an Abort_Signal
exception handler.
* exp_ch9.adb (Expand_N_Asynchronous_Select): Call
Build_Abort_Block_Handler to build the exception handler. Do not
undefer aborts for the Abort_Signal exception handler if back-end
exception mechanism.
* exp_ch11.adb (Expand_Exception_Handlers): Do not undefer aborts if
back_end exceptions for all others and abort_signal.
* s-except.ads (ZCX_By_Default): New constant.
* a-except-2005.adb (Raise_Exception): Do not defer abort if ZCX.
(Raise_Exception_Always): Ditto.
(Raise_From_Signal_Handler): Ditto.
(Raise_With_Location_And_Msg): Ditto.
(Raise_With_Msg): Ditto.
(Reraise): Ditto.
(Reraise_Occurence): Ditto.
(Reraise_Occurrence_Always): Ditto.
* s-tasren.adb (Exceptional_Complete_Rendezvous): Defer aborts if ZCX.
* s-tpobop.adb: (Exceptional_Complete_Body): Undefer abort if ZCX.
* s-interr-hwint.adb (Interrupt_Manager): Defer abort if ZCX.
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 178179)
+++ exp_ch9.adb (working copy)
@@ -5848,6 +5848,7 @@
Enqueue_Call : Node_Id;
Formals : List_Id;
Hdle : List_Id;
+ Handler_Stmt : Node_Id;
Index : Node_Id;
Lim_Typ_Stmts : List_Id;
N_Orig : Node_Id;
@@ -5859,9 +5860,7 @@
ProtP_Stmts : List_Id;
Stmt : Node_Id;
Stmts : List_Id;
- Target_Undefer : RE_Id;
TaskE_Stmts : List_Id;
- Undefer_Args : List_Id := No_List;
B : Entity_Id; -- Call status flag
Bnn : Entity_Id; -- Communication block
@@ -6352,13 +6351,7 @@
-- Create the inner block to protect the abortable part
- Hdle := New_List (
- Make_Implicit_Exception_Handler (Loc,
- Exception_Choices =>
- New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
+ Hdle := New_List (Build_Abort_Block_Handler (Loc));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
@@ -6513,13 +6506,21 @@
-- See 4jexcept.ads for an explanation.
if VM_Target = No_VM then
- Target_Undefer := RE_Abort_Undefer;
+ if Exception_Mechanism = Back_End_Exceptions then
+ -- Aborts are not deferred at beginning of exception handlers
+ -- in ZCX.
+ Handler_Stmt := Make_Null_Statement (Loc);
+ else
+ Handler_Stmt := Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
+ Parameter_Associations => No_List);
+ end if;
else
- Target_Undefer := RE_Update_Exception;
- Undefer_Args :=
- New_List (Make_Function_Call (Loc,
- Name => New_Occurrence_Of
- (RTE (RE_Current_Target_Exception), Loc)));
+ Handler_Stmt := Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Update_Exception), Loc),
+ Parameter_Associations => New_List (Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Current_Target_Exception),
+ Loc))));
end if;
Stmts := New_List (
@@ -6542,11 +6543,7 @@
Exception_Choices =>
New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (
- RTE (Target_Undefer), Loc),
- Parameter_Associations => Undefer_Args)))))),
+ Statements => New_List (Handler_Stmt))))),
-- if not Cancelled (Bnn) then
-- triggered statements
@@ -6602,14 +6599,7 @@
-- Create the inner block to protect the abortable part
- Hdle := New_List (
- Make_Implicit_Exception_Handler (Loc,
- Exception_Choices =>
- New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
- Statements =>
- New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)))));
+ Hdle := New_List (Build_Abort_Block_Handler (Loc));
Prepend_To (Astats,
Make_Procedure_Call_Statement (Loc,
Index: s-tasren.adb
===================================================================
--- s-tasren.adb (revision 178155)
+++ s-tasren.adb (working copy)
@@ -553,6 +553,11 @@
end if;
Initialization.Defer_Abort_Nestable (Self_Id);
+
+ elsif ZCX_By_Default then
+ -- With ZCX, aborts are not automatically deferred in handlers
+
+ Initialization.Defer_Abort_Nestable (Self_Id);
end if;
-- We need to clean up any accepts which Self may have
Index: exp_sel.adb
===================================================================
--- exp_sel.adb (revision 178155)
+++ exp_sel.adb (working copy)
@@ -64,20 +64,38 @@
Blk),
Exception_Handlers =>
- New_List (
- Make_Implicit_Exception_Handler (Loc,
- Exception_Choices =>
- New_List (
- New_Reference_To (Stand.Abort_Signal, Loc)),
- Statements =>
- New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (
- RE_Abort_Undefer), Loc),
- Parameter_Associations => No_List))))));
+ New_List (Build_Abort_Block_Handler (Loc))));
end Build_Abort_Block;
+ -------------------------------
+ -- Build_Abort_Block_Handler --
+ -------------------------------
+
+ function Build_Abort_Block_Handler
+ (Loc : Source_Ptr) return Node_Id
+ is
+ Stmt : Node_Id;
+ begin
+ if Exception_Mechanism = Back_End_Exceptions then
+ -- With ZCX, aborts are not defered in handlers.
+
+ Stmt := Make_Null_Statement (Loc);
+ else
+ -- With FE SJLJ, aborts are defered at the beginning of Abort_Signal
+ -- handlers.
+
+ Stmt := Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc),
+ Parameter_Associations => No_List);
+ end if;
+
+ return Make_Implicit_Exception_Handler (Loc,
+ Exception_Choices =>
+ New_List (New_Reference_To (Stand.Abort_Signal, Loc)),
+ Statements =>
+ New_List (Stmt));
+ end Build_Abort_Block_Handler;
+
-------------
-- Build_B --
-------------
Index: exp_sel.ads
===================================================================
--- exp_sel.ads (revision 178155)
+++ exp_sel.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -39,11 +39,23 @@
-- begin
-- Blk
-- exception
- -- when Abort_Signal => Abort_Undefer;
+ -- when Abort_Signal => Abort_Undefer / null;
-- end;
-- Abr_Blk_Ent is the name of the generated block, Cln_Blk_Ent is the name
-- of the encapsulated cleanup block, Blk is the actual block name.
+ -- The exception handler code is built by Build_Abort_Block_Handler.
+ function Build_Abort_Block_Handler
+ (Loc : Source_Ptr) return Node_Id;
+ -- Generate if front-end exception:
+ -- when others =>
+ -- Abort_Under;
+ -- or if back-end exception:
+ -- when others =>
+ -- null;
+ -- This is an exception handler to stop propagation of aborts, without
+ -- modifying the deferal level.
+
function Build_B
(Loc : Source_Ptr;
Decls : List_Id) return Entity_Id;
Index: exp_ch11.adb
===================================================================
--- exp_ch11.adb (revision 178155)
+++ exp_ch11.adb (working copy)
@@ -1097,7 +1097,9 @@
-- any case this entire handling is relevant only if aborts
-- are allowed!
- elsif Abort_Allowed then
+ elsif Abort_Allowed
+ and then Exception_Mechanism /= Back_End_Exceptions
+ then
-- There are some special cases in which we do not do the
-- undefer. In particular a finalization (AT END) handler
@@ -1122,7 +1124,6 @@
(Others_Choice
and then
All_Others (First (Exception_Choices (Handler))))
- and then Abort_Allowed
then
Prepend_Call_To_Handler (RE_Abort_Undefer);
end if;
Index: s-interr-hwint.adb
===================================================================
--- s-interr-hwint.adb (revision 178155)
+++ s-interr-hwint.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -1025,6 +1025,10 @@
exception
when Standard'Abort_Signal =>
+ if ZCX_By_Default then
+ Initialization.Defer_Abort_Nestable (STPO.Self);
+ end if;
+
-- Flush interrupt server semaphores, so they can terminate
Finalize_Interrupt_Servers;
raise;
Index: a-except-2005.adb
===================================================================
--- a-except-2005.adb (revision 178155)
+++ a-except-2005.adb (working copy)
@@ -855,7 +855,9 @@
-- Go ahead and raise appropriate exception
Exception_Data.Set_Exception_Msg (EF, Message);
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Raise_Current_Excep (EF);
end Raise_Exception;
@@ -869,7 +871,9 @@
is
begin
Exception_Data.Set_Exception_Msg (E, Message);
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Raise_Current_Excep (E);
end Raise_Exception_Always;
@@ -944,7 +948,9 @@
is
begin
Exception_Data.Set_Exception_C_Msg (E, M);
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E));
Exception_Propagation.Propagate_Exception
(E => E, From_Signal_Handler => True);
@@ -1015,7 +1021,9 @@
is
begin
Exception_Data.Set_Exception_C_Msg (E, F, L, C, M);
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Raise_Current_Excep (E);
end Raise_With_Location_And_Msg;
@@ -1034,7 +1042,9 @@
Excep.Num_Tracebacks := 0;
Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Raise_Current_Excep (E);
end Raise_With_Msg;
@@ -1276,7 +1286,9 @@
procedure Reraise is
Excep : constant EOA := Get_Current_Excep.all;
begin
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Exception_Propagation.Setup_Exception (Excep, Excep, Reraised => True);
Raise_Current_Excep (Excep.Id);
end Reraise;
@@ -1288,7 +1300,9 @@
procedure Reraise_Occurrence (X : Exception_Occurrence) is
begin
if X.Id /= null then
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Exception_Propagation.Setup_Exception
(X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True);
Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
@@ -1302,7 +1316,9 @@
procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
begin
- Abort_Defer.all;
+ if not ZCX_By_Default then
+ Abort_Defer.all;
+ end if;
Exception_Propagation.Setup_Exception
(X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True);
Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
Index: s-except.ads
===================================================================
--- s-except.ads (revision 178155)
+++ s-except.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2011, 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- --
@@ -42,6 +42,9 @@
pragma Preelaborate_05;
-- To let Ada.Exceptions "with" us and let us "with" Standard_Library
+ ZCX_By_Default : constant Boolean;
+ -- Visible copy to allow Ada.Exceptions to know the exception model.
+
package SSL renames System.Standard_Library;
-- To let some of the hooks below have formal parameters typed in
-- accordance with what GDB expects.
@@ -75,4 +78,7 @@
--
-- The argument is the address of the exception data
+private
+ ZCX_By_Default : constant Boolean := System.ZCX_By_Default;
+
end System.Exceptions;
Index: s-tpobop.adb
===================================================================
--- s-tpobop.adb (revision 178155)
+++ s-tpobop.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -258,7 +258,9 @@
-- enabled for its remaining life.
Self_Id := STPO.Self;
- Initialization.Undefer_Abort_Nestable (Self_Id);
+ if not ZCX_By_Default then
+ Initialization.Undefer_Abort_Nestable (Self_Id);
+ end if;
Transfer_Occurrence
(Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
Self_Id.Common.Compiler_Data.Current_Excep);
@@ -270,6 +272,7 @@
end if;
if Runtime_Traces then
+ -- ??? Entry_Call can be null
Send_Trace_Info (PO_Done, Entry_Call.Self);
end if;
end Exceptional_Complete_Entry_Body;
