diff mbox

[Ada] Do not defer aborts while raising exceptions (ZCX)

Message ID 20110829103447.GA16989@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Aug. 29, 2011, 10:34 a.m. UTC 
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  <gingold@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.
diff mbox

Patch

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;