+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.
+
+2011-08-29 Thomas Quinot <quinot@adacore.com>
+
+ * sem_util.ads (Get_Enum_Lit_From_Pos): Clarify documentation.
+
2011-08-29 Robert Dewar <dewar@adacore.com>
* snames.adb-tmpl, sem_ch13.adb: Minor reformatting
-- 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;
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;
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);
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;
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;
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;
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);
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);
-- 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
(Others_Choice
and then
All_Others (First (Exception_Choices (Handler))))
- and then Abort_Allowed
then
Prepend_Call_To_Handler (RE_Abort_Undefer);
end if;
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;
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
-- 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,
-- 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 (
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
-- 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,
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 --
-------------
-- --
-- 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- --
-- 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;
-- --
-- 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- --
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.
--
-- The argument is the address of the exception data
+private
+ ZCX_By_Default : constant Boolean := System.ZCX_By_Default;
+
end System.Exceptions;
-- --
-- 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- --
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;
Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
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;
-- --
-- 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- --
-- 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);
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;
(T : Entity_Id;
Pos : Uint;
Loc : Source_Ptr) return Node_Id;
- -- This function obtains the E_Enumeration_Literal entity for the specified
- -- value from the enumeration type or subtype T and returns an identifier
- -- node referencing this value. The second argument is the Pos value, which
- -- is assumed to be in range. The third argument supplies a source location
- -- for constructed nodes returned by this function.
+ -- This function returns an identifier denoting the E_Enumeration_Literal
+ -- entity for the specified value from the enumeration type or subtype T.
+ -- The second argument is the Pos value, which is assumed to be in range.
+ -- The third argument supplies a source location for constructed nodes
+ -- returned by this function.
procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id);
-- Retrieve the fully expanded name of the library unit declared by
procedure Set_Current_Entity (E : Entity_Id);
pragma Inline (Set_Current_Entity);
-- Establish the entity E as the currently visible definition of its
- -- associated name (i.e. the Node_Id associated with its name)
+ -- associated name (i.e. the Node_Id associated with its name).
procedure Set_Debug_Info_Needed (T : Entity_Id);
-- Sets the Debug_Info_Needed flag on entity T , and also on any entities
projects / platform / upstream / gcc.git / commitdiff