------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2022, 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- This is the version using the GCC EH mechanism, which could rely on -- different underlying unwinding engines, for example DWARF or ARM unwind -- info based. Here is a sketch of the most prominent data structures -- involved: -- (s-excmac.ads) -- GNAT_GCC_Exception: -- *-----------------------------------* -- o-->| (s-excmac.ads) | -- | | Header : | -- | | - Class | -- | | ... | Constraint_Error: -- | |-----------------------------------* Program_Error: -- | | (a-except.ads) | Foreign_Exception: -- | | Occurrence : Exception_Occurrence | -- | | | (s-stalib. ads) -- | | - Id : Exception_Id --------------> Exception_Data -- o------ - Machine_Occurrence | *------------------------* -- | - Msg | | Not_Handled_By_Others | -- | - Traceback | | Lang | -- | ... | | Foreign_Data --o | -- *-----------------------------------* | Full_Name | | -- || | ... | | -- || foreign rtti blob *----------------|-------* -- || *---------------* | -- || | ... ... |<-------------------------o -- || *---------------* -- || -- Setup_Current_Excep() -- || -- || Latch into ATCB or -- || environment Current Exception Buffer: -- || -- vv -- <> : Exception_Occurrence -- *---------------------------* -- | ... ... ... ... ... ... * --- Get_Current_Excep() ----> -- *---------------------------* -- On "raise" events, the runtime allocates a new GNAT_GCC_Exception -- instance and eventually calls into libgcc's Unwind_RaiseException. -- This part handles the object through the header part only. -- During execution, Get_Current_Excep provides a pointer to the -- Exception_Occurrence being raised or last raised by the current task. -- This is actually the address of a statically allocated -- Exception_Occurrence attached to the current ATCB or to the environment -- thread into which an occurrence being raised is synchronized at critical -- points during the raise process, via Setup_Current_Excep. with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with System.Storage_Elements; use System.Storage_Elements; with System.Exceptions.Machine; use System.Exceptions.Machine; separate (Ada.Exceptions) package body Exception_Propagation is use Exception_Traces; type bool is new Boolean; pragma Convention (C, bool); Foreign_Exception : aliased System.Standard_Library.Exception_Data; pragma Import (Ada, Foreign_Exception, "system__exceptions__foreign_exception"); -- Id for foreign exceptions -------------------------------------------------------------- -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- -------------------------------------------------------------- -- Phase identifiers (Unwind Actions) type Unwind_Action is new Integer; pragma Convention (C, Unwind_Action); UA_SEARCH_PHASE : constant Unwind_Action := 1; UA_CLEANUP_PHASE : constant Unwind_Action := 2; UA_HANDLER_FRAME : constant Unwind_Action := 4; UA_FORCE_UNWIND : constant Unwind_Action := 8; UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension pragma Unreferenced (UA_HANDLER_FRAME, UA_FORCE_UNWIND, UA_END_OF_STACK); procedure GNAT_GCC_Exception_Cleanup (Reason : Unwind_Reason_Code; Excep : not null GNAT_GCC_Exception_Access); pragma Convention (C, GNAT_GCC_Exception_Cleanup); -- Procedure called when a GNAT GCC exception is free. procedure Propagate_GCC_Exception (GCC_Exception : not null GCC_Exception_Access); pragma No_Return (Propagate_GCC_Exception); -- Propagate a GCC exception procedure Reraise_GCC_Exception (GCC_Exception : not null GCC_Exception_Access); pragma No_Return (Reraise_GCC_Exception); pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); -- Called to implement raise without exception, ie reraise. Called -- directly from gigi. function Setup_Current_Excep (GCC_Exception : not null GCC_Exception_Access; Phase : Unwind_Action) return EOA; pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); -- Acknowledge GCC_Exception as the current exception object being -- raised, which could be an Ada or a foreign exception object. Return -- a pointer to the embedded Ada occurrence for an Ada exception object, -- to the current exception buffer otherwise. -- -- Synchronize the current exception buffer as needed for possible -- accesses through Get_Current_Except.all afterwards, depending on the -- Phase bits, received either from the personality routine, from a -- forced_unwind cleanup handler, or just before the start of propagation -- for an Ada exception (Phase 0 in this case). procedure Unhandled_Except_Handler (GCC_Exception : not null GCC_Exception_Access); pragma No_Return (Unhandled_Except_Handler); pragma Export (C, Unhandled_Except_Handler, "__gnat_unhandled_except_handler"); -- Called for handle unhandled exceptions, ie the last chance handler -- on platforms (such as SEH) that never returns after throwing an -- exception. Called directly by gigi. function CleanupUnwind_Handler (UW_Version : Integer; UW_Phases : Unwind_Action; UW_Eclass : Exception_Class; UW_Exception : not null GCC_Exception_Access; UW_Context : System.Address; UW_Argument : System.Address) return Unwind_Reason_Code; pragma Import (C, CleanupUnwind_Handler, "__gnat_cleanupunwind_handler"); -- Hook called at each step of the forced unwinding we perform to trigger -- cleanups found during the propagation of an unhandled exception. -- GCC runtime functions used. These are C non-void functions, actually, -- but we ignore the return values. See raise.c as to why we are using -- __gnat stubs for these. procedure Unwind_RaiseException (UW_Exception : not null GCC_Exception_Access); pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); procedure Unwind_ForcedUnwind (UW_Exception : not null GCC_Exception_Access; UW_Handler : System.Address; UW_Argument : System.Address); pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); procedure Set_Exception_Parameter (Excep : EOA; GCC_Exception : not null GCC_Exception_Access); pragma Export (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); -- Called inserted by gigi to set the exception choice parameter from the -- gcc occurrence. procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); -- Utility routine to initialize occurrence Excep from a foreign exception -- whose machine occurrence is Mo. The message is empty, the backtrace -- is empty too and the exception identity is Foreign_Exception. -- Hooks called when entering/leaving an exception handler for a -- given occurrence. The calls are generated by gigi in -- Exception_Handler_to_gnu_gcc. -- Begin_Handler_v1, called when entering an exception handler, -- claims responsibility for the handler to release the -- GCC_Exception occurrence. End_Handler_v1, called when -- leaving the handler, releases the occurrence, unless the -- occurrence is propagating further up, or the handler is -- dynamically nested in the context of another handler that -- claimed responsibility for releasing that occurrence. -- Responsibility is claimed by changing the Cleanup field to -- Claimed_Cleanup, which enables claimed exceptions to be -- recognized, and avoids accidental releases even by foreign -- handlers. function Begin_Handler_v1 (GCC_Exception : not null GCC_Exception_Access) return System.Address; pragma Export (C, Begin_Handler_v1, "__gnat_begin_handler_v1"); -- Called when entering an exception handler. Claim -- responsibility for releasing GCC_Exception, by setting the -- cleanup/release function to Claimed_Cleanup, and return the -- address of the previous cleanup/release function. procedure End_Handler_v1 (GCC_Exception : not null GCC_Exception_Access; Saved_Cleanup : System.Address; Propagating_Exception : GCC_Exception_Access); pragma Export (C, End_Handler_v1, "__gnat_end_handler_v1"); -- Called when leaving an exception handler. Restore the -- Saved_Cleanup in the GCC_Exception occurrence, and then release -- it, unless it remains claimed by an enclosing handler, or -- GCC_Exception and Propagating_Exception are the same -- occurrence. Propagating_Exception could be either an -- occurrence (re)raised within the handler of GCC_Exception, when -- we're executing as an exceptional cleanup, or null, if we're -- completing the handler of GCC_Exception normally. procedure Claimed_Cleanup (Reason : Unwind_Reason_Code; GCC_Exception : not null GCC_Exception_Access); pragma Export (C, Claimed_Cleanup, "__gnat_claimed_cleanup"); -- A do-nothing placeholder installed as GCC_Exception.Cleanup -- while handling GCC_Exception, to claim responsibility for -- releasing it, and to stop it from being accidentally released. -- The following are version 0 implementations of the version 1 -- hooks above. They remain in place for compatibility with the -- output of compilers that still use version 0, such as those -- used during bootstrap. They are interoperable with the v1 -- hooks, except that the older versions may malfunction when -- handling foreign exceptions passed to Reraise_Occurrence. procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); pragma Export (C, Begin_Handler, "__gnat_begin_handler"); -- Called when entering an exception handler translated by an old -- compiler. It does nothing. procedure End_Handler (GCC_Exception : GCC_Exception_Access); pragma Export (C, End_Handler, "__gnat_end_handler"); -- Called when leaving an exception handler translated by an old -- compiler. It releases GCC_Exception, unless it is null. It is -- only ever null when the handler has a 'raise;' translated by a -- v0-using compiler. The artificial handler variable passed to -- End_Handler was set to null to tell End_Handler to refrain from -- releasing the reraised exception. In v1 safer ways are used to -- accomplish that. -------------------------------------------------------------------- -- Accessors to Basic Components of a GNAT Exception Data Pointer -- -------------------------------------------------------------------- -- As of today, these are only used by the C implementation of the GCC -- propagation personality routine to avoid having to rely on a C -- counterpart of the whole exception_data structure, which is both -- painful and error prone. These subprograms could be moved to a more -- widely visible location if need be. function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool; pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); function Language_For (E : Exception_Data_Ptr) return Character; pragma Export (C, Language_For, "__gnat_language_for"); function Foreign_Data_For (E : Exception_Data_Ptr) return Address; pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for"); function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id; pragma Export (C, EID_For, "__gnat_eid_for"); --------------------------------------------------------------------------- -- Objects to materialize "others" and "all others" in the GCC EH tables -- --------------------------------------------------------------------------- -- Currently, these only have their address taken and compared so there is -- no real point having whole exception data blocks allocated. Note that -- there are corresponding declarations in gigi (trans.c) which must be -- kept properly synchronized. Others_Value : constant Character := 'O'; pragma Export (C, Others_Value, "__gnat_others_value"); All_Others_Value : constant Character := 'A'; pragma Export (C, All_Others_Value, "__gnat_all_others_value"); Unhandled_Others_Value : constant Character := 'U'; pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); -- Special choice (emitted by gigi) to catch and notify unhandled -- exceptions on targets which always handle exceptions (such as SEH). -- The handler will simply call Unhandled_Except_Handler. ------------------------- -- Allocate_Occurrence -- ------------------------- function Allocate_Occurrence return EOA is Res : GNAT_GCC_Exception_Access; begin Res := New_Occurrence; Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address; Res.Occurrence.Machine_Occurrence := Res.all'Address; return Res.Occurrence'Access; end Allocate_Occurrence; -------------------------------- -- GNAT_GCC_Exception_Cleanup -- -------------------------------- procedure GNAT_GCC_Exception_Cleanup (Reason : Unwind_Reason_Code; Excep : not null GNAT_GCC_Exception_Access) is pragma Unreferenced (Reason); procedure Free is new Unchecked_Deallocation (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); Copy : GNAT_GCC_Exception_Access := Excep; begin -- Simply free the memory Free (Copy); end GNAT_GCC_Exception_Cleanup; ---------------------------- -- Set_Foreign_Occurrence -- ---------------------------- procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is begin Excep.all := ( Id => Foreign_Exception'Access, Machine_Occurrence => Mo, Msg => <>, Msg_Length => 0, Exception_Raised => True, Pid => Local_Partition_ID, Num_Tracebacks => 0, Tracebacks => <>); end Set_Foreign_Occurrence; ------------------------- -- Setup_Current_Excep -- ------------------------- function Setup_Current_Excep (GCC_Exception : not null GCC_Exception_Access; Phase : Unwind_Action) return EOA is Excep : constant EOA := Get_Current_Excep.all; begin if GCC_Exception.Class = GNAT_Exception_Class then -- Ada exception : latch the occurrence data in the Current -- Exception Buffer if needed and return a pointer to the original -- Ada exception object. This particular object was specifically -- allocated for this raise and is thus more precise than the fixed -- Current Exception Buffer address. declare GNAT_Occurrence : constant GNAT_GCC_Exception_Access := To_GNAT_GCC_Exception (GCC_Exception); begin -- When reaching here during SEARCH_PHASE, no need to -- replicate the copy performed at the propagation start. if Phase /= UA_SEARCH_PHASE then Excep.all := GNAT_Occurrence.Occurrence; end if; return GNAT_Occurrence.Occurrence'Access; end; else -- Foreign exception (caught by Ada handler, reaching here from -- personality routine) : The original exception object doesn't hold -- an Ada occurrence info. Set the foreign data pointer in the -- Current Exception Buffer and return the address of the latter. Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); return Excep; end if; end Setup_Current_Excep; ---------------------- -- Begin_Handler_v1 -- ---------------------- function Begin_Handler_v1 (GCC_Exception : not null GCC_Exception_Access) return System.Address is Saved_Cleanup : constant System.Address := GCC_Exception.Cleanup; begin -- Claim responsibility for releasing this exception, and stop -- others from releasing it. GCC_Exception.Cleanup := Claimed_Cleanup'Address; return Saved_Cleanup; end Begin_Handler_v1; -------------------- -- End_Handler_v1 -- -------------------- procedure End_Handler_v1 (GCC_Exception : not null GCC_Exception_Access; Saved_Cleanup : System.Address; Propagating_Exception : GCC_Exception_Access) is begin GCC_Exception.Cleanup := Saved_Cleanup; -- Restore the Saved_Cleanup, so that it is either used to -- release GCC_Exception below, or transferred to the next -- handler of the Propagating_Exception occurrence. The -- following test ensures that an occurrence is only released -- once, even after reraises. -- -- The idea is that the GCC_Exception is not to be released -- unless it had an unclaimed Cleanup when the handler started -- (see Begin_Handler_v1 above), but if we propagate across its -- handler a reraise of the same exception, we transfer to the -- Propagating_Exception the responsibility for running the -- Saved_Cleanup when its handler completes. -- -- This ownership transfer mechanism ensures safety, as in -- single release and no dangling pointers, because there is no -- way to hold on to the Machine_Occurrence of an -- Exception_Occurrence: the only situations in which another -- Exception_Occurrence gets the same Machine_Occurrence are -- through Reraise_Occurrence, and plain reraise, and so we -- have the following possibilities: -- -- - Reraise_Occurrence is handled within the running handler, -- and so when completing the dynamically nested handler, we -- must NOT release the exception. A Claimed_Cleanup upon -- entry of the nested handler, installed when entering the -- enclosing handler, ensures the exception will not be -- released by the nested handler, but rather by the enclosing -- handler. -- -- - Reraise_Occurrence/reraise escapes the running handler, -- and we run as an exceptional cleanup for GCC_Exception. The -- Saved_Cleanup was reinstalled, but since we're propagating -- the same machine occurrence, we do not release it. Instead, -- we transfer responsibility for releasing it to the eventual -- handler of the propagating exception. -- -- - An unrelated exception propagates through the running -- handler. We restored GCC_Exception.Saved_Cleanup above. -- Since we're propagating a different exception, we proceed to -- release GCC_Exception, unless Saved_Cleanup was -- Claimed_Cleanup, because then we know we're not in the -- outermost handler for GCC_Exception. -- -- - The handler completes normally, so it reinstalls the -- Saved_Cleanup and runs it, unless it was Claimed_Cleanup. -- If Saved_Cleanup is null, Unwind_DeleteException (currently) -- has no effect, so we could skip it, but if it is ever -- changed to do more in this case, we're ready for that, -- calling it exactly once. if Saved_Cleanup /= Claimed_Cleanup'Address and then Propagating_Exception /= GCC_Exception then declare Current : constant EOA := Get_Current_Excep.all; Cur_Occ : constant GCC_Exception_Access := To_GCC_Exception (Current.Machine_Occurrence); begin -- If we are releasing the Machine_Occurrence of the current -- exception, reset the access to it, so that it is no -- longer accessible. if Cur_Occ = GCC_Exception then Current.Machine_Occurrence := System.Null_Address; end if; end; Unwind_DeleteException (GCC_Exception); end if; end End_Handler_v1; --------------------- -- Claimed_Cleanup -- --------------------- procedure Claimed_Cleanup (Reason : Unwind_Reason_Code; GCC_Exception : not null GCC_Exception_Access) is pragma Unreferenced (Reason); pragma Unreferenced (GCC_Exception); begin -- This procedure should never run. If it does, it's either a -- version 0 handler or a foreign handler, attempting to -- release an exception while a version 1 handler that claimed -- responsibility for releasing the exception remains still -- active. This placeholder stops GCC_Exception from being -- released by them. -- We could get away with just Null_Address instead, with -- nearly the same effect, but with this placeholder we can -- detect and report unexpected releases, and we can tell apart -- a GCC_Exception without a Cleanup, from one with another -- active handler, so as to still call Unwind_DeleteException -- exactly once: currently, Unwind_DeleteException does nothing -- when the Cleanup is null, but should it ever be changed to -- do more, we'll still be safe. null; end Claimed_Cleanup; ------------------- -- Begin_Handler -- ------------------- procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is pragma Unreferenced (GCC_Exception); begin null; end Begin_Handler; ----------------- -- End_Handler -- ----------------- procedure End_Handler (GCC_Exception : GCC_Exception_Access) is begin if GCC_Exception /= null then -- The exception might have been reraised, in this case the cleanup -- mustn't be called. Unwind_DeleteException (GCC_Exception); end if; end End_Handler; ----------------------------- -- Reraise_GCC_Exception -- ----------------------------- procedure Reraise_GCC_Exception (GCC_Exception : not null GCC_Exception_Access) is begin -- Simply propagate it Propagate_GCC_Exception (GCC_Exception); end Reraise_GCC_Exception; ----------------------------- -- Propagate_GCC_Exception -- ----------------------------- -- Call Unwind_RaiseException to actually throw, taking care of handling -- the two phase scheme it implements. procedure Propagate_GCC_Exception (GCC_Exception : not null GCC_Exception_Access) is -- Acknowledge the current exception info now, before unwinding -- starts so it is available even from C++ handlers involved before -- our personality routine. Excep : constant EOA := Setup_Current_Excep (GCC_Exception, Phase => 0); begin -- Perform a standard raise first. If a regular handler is found, it -- will be entered after all the intermediate cleanups have run. If -- there is no regular handler, it will return. Unwind_RaiseException (GCC_Exception); -- If we get here we know the exception is not handled, as otherwise -- Unwind_RaiseException arranges for the handler to be entered. Take -- the necessary steps to enable the debugger to gain control while the -- stack is still intact. Notify_Unhandled_Exception (Excep); -- Now, un a forced unwind to trigger cleanups. Control should not -- resume there, if there are cleanups and in any cases as the -- unwinding hook calls Unhandled_Exception_Terminate when end of -- stack is reached. Unwind_ForcedUnwind (GCC_Exception, CleanupUnwind_Handler'Address, System.Null_Address); -- We get here in case of error. The debugger has been notified before -- the second step above. Unhandled_Except_Handler (GCC_Exception); end Propagate_GCC_Exception; ------------------------- -- Propagate_Exception -- ------------------------- procedure Propagate_Exception (Excep : Exception_Occurrence) is begin Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); end Propagate_Exception; ----------------------------- -- Set_Exception_Parameter -- ----------------------------- procedure Set_Exception_Parameter (Excep : EOA; GCC_Exception : not null GCC_Exception_Access) is begin -- Setup the exception occurrence if GCC_Exception.Class = GNAT_Exception_Class then -- From the GCC exception declare GNAT_Occurrence : constant GNAT_GCC_Exception_Access := To_GNAT_GCC_Exception (GCC_Exception); begin Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence); end; else -- A default one Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); end if; end Set_Exception_Parameter; ------------------------------ -- Unhandled_Except_Handler -- ------------------------------ procedure Unhandled_Except_Handler (GCC_Exception : not null GCC_Exception_Access) is Excep : EOA; begin Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE); Unhandled_Exception_Terminate (Excep); end Unhandled_Except_Handler; ------------- -- EID_For -- ------------- function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id is begin return GNAT_Exception.Occurrence.Id; end EID_For; ---------------------- -- Foreign_Data_For -- ---------------------- function Foreign_Data_For (E : Exception_Data_Ptr) return Address is begin return E.Foreign_Data; end Foreign_Data_For; -------------------------- -- Is_Handled_By_Others -- -------------------------- function Is_Handled_By_Others (E : Exception_Data_Ptr) return bool is begin return not bool (E.all.Not_Handled_By_Others); end Is_Handled_By_Others; ------------------ -- Language_For -- ------------------ function Language_For (E : Exception_Data_Ptr) return Character is begin return E.all.Lang; end Language_For; end Exception_Propagation;