| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2012, 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 -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- 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 |
| |
| with Ada.Unchecked_Conversion; |
| with Ada.Unchecked_Deallocation; |
| |
| with System.Storage_Elements; use System.Storage_Elements; |
| |
| separate (Ada.Exceptions) |
| package body Exception_Propagation is |
| |
| use Exception_Traces; |
| |
| ------------------------------------------------ |
| -- Entities to interface with the GCC runtime -- |
| ------------------------------------------------ |
| |
| -- These come from "C++ ABI for Itanium: Exception handling", which is |
| -- the reference for GCC. |
| |
| -- Return codes from the GCC runtime functions used to propagate |
| -- an exception. |
| |
| type Unwind_Reason_Code is |
| (URC_NO_REASON, |
| URC_FOREIGN_EXCEPTION_CAUGHT, |
| URC_PHASE2_ERROR, |
| URC_PHASE1_ERROR, |
| URC_NORMAL_STOP, |
| URC_END_OF_STACK, |
| URC_HANDLER_FOUND, |
| URC_INSTALL_CONTEXT, |
| URC_CONTINUE_UNWIND); |
| |
| pragma Unreferenced |
| (URC_NO_REASON, |
| URC_FOREIGN_EXCEPTION_CAUGHT, |
| URC_PHASE2_ERROR, |
| URC_PHASE1_ERROR, |
| URC_NORMAL_STOP, |
| URC_END_OF_STACK, |
| URC_HANDLER_FOUND, |
| URC_INSTALL_CONTEXT, |
| URC_CONTINUE_UNWIND); |
| |
| pragma Convention (C, Unwind_Reason_Code); |
| |
| -- Phase identifiers |
| |
| 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_SEARCH_PHASE, |
| UA_CLEANUP_PHASE, |
| UA_HANDLER_FRAME, |
| UA_FORCE_UNWIND, |
| UA_END_OF_STACK); |
| |
| -- Mandatory common header for any exception object handled by the |
| -- GCC unwinding runtime. |
| |
| type Exception_Class is mod 2 ** 64; |
| |
| GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#; |
| -- "GNU-Ada\0" |
| |
| type Unwind_Word is mod 2 ** System.Word_Size; |
| for Unwind_Word'Size use System.Word_Size; |
| -- Map the corresponding C type used in Unwind_Exception below |
| |
| type Unwind_Exception is record |
| Class : Exception_Class; |
| Cleanup : System.Address; |
| Private1 : Unwind_Word; |
| Private2 : Unwind_Word; |
| |
| -- Usual exception structure has only two private fields, but the SEH |
| -- one has six. To avoid making this file more complex, we use six |
| -- fields on all platforms, wasting a few bytes on some. |
| |
| Private3 : Unwind_Word; |
| Private4 : Unwind_Word; |
| Private5 : Unwind_Word; |
| Private6 : Unwind_Word; |
| end record; |
| pragma Convention (C, Unwind_Exception); |
| -- Map the GCC struct used for exception handling |
| |
| for Unwind_Exception'Alignment use Standard'Maximum_Alignment; |
| -- The C++ ABI mandates the common exception header to be at least |
| -- doubleword aligned, and the libGCC implementation actually makes it |
| -- maximally aligned (see unwind.h). See additional comments on the |
| -- alignment below. |
| |
| type GCC_Exception_Access is access all Unwind_Exception; |
| -- Pointer to a GCC exception. Do not use convention C as on VMS this |
| -- would imply the use of 32-bits pointers. |
| |
| procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); |
| pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); |
| -- Procedure to free any GCC exception |
| |
| 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 -- |
| -------------------------------------------------------------- |
| |
| -- A GNAT exception object to be dealt with by the personality routine |
| -- called by the GCC unwinding runtime. |
| |
| type GNAT_GCC_Exception is record |
| Header : Unwind_Exception; |
| -- ABI Exception header first |
| |
| Occurrence : aliased Exception_Occurrence; |
| -- The Ada occurrence |
| end record; |
| |
| pragma Convention (C, GNAT_GCC_Exception); |
| |
| -- There is a subtle issue with the common header alignment, since the C |
| -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on |
| -- Standard'Maximum_Alignment, and those two values don't quite represent |
| -- the same concepts and so may be decoupled someday. One typical reason |
| -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system |
| -- allocator guarantees, and there are extra costs involved in allocating |
| -- objects aligned to such factors. |
| |
| -- To deal with the potential alignment differences between the C and Ada |
| -- representations, the Ada part of the whole structure is only accessed |
| -- by the personality routine through the accessors declared below. Ada |
| -- specific fields are thus always accessed through consistent layout, and |
| -- we expect the actual alignment to always be large enough to avoid traps |
| -- from the C accesses to the common header. Besides, accessors alleviate |
| -- the need for a C struct whole counterpart, both painful and error-prone |
| -- to maintain anyway. |
| |
| type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; |
| |
| function To_GCC_Exception is new |
| Unchecked_Conversion (System.Address, GCC_Exception_Access); |
| |
| function To_GNAT_GCC_Exception is new |
| Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access); |
| |
| 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) return EOA; |
| pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); |
| -- Write Get_Current_Excep.all from GCC_Exception |
| |
| 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"); |
| |
| -- Hooks called when entering/leaving an exception handler for a given |
| -- occurrence, aimed at handling the stack of active occurrences. The |
| -- calls are generated by gigi in tree_transform/N_Exception_Handler. |
| |
| procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); |
| pragma Export (C, Begin_Handler, "__gnat_begin_handler"); |
| |
| procedure End_Handler (GCC_Exception : GCC_Exception_Access); |
| pragma Export (C, End_Handler, "__gnat_end_handler"); |
| |
| -------------------------------------------------------------------- |
| -- 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 Boolean; |
| pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); |
| pragma Warnings (Off, Is_Handled_By_Others); |
| |
| function Language_For (E : Exception_Data_Ptr) return Character; |
| pragma Export (C, Language_For, "__gnat_language_for"); |
| |
| function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code; |
| pragma Export (C, Import_Code_For, "__gnat_import_code_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. In any case |
| -- the types should match what gigi and the personality routine expect. |
| -- The initial value is an arbitrary value that will not exceed the range |
| -- of Integer on 16-bit targets (such as AAMP). |
| |
| Others_Value : constant Integer := 16#7FFF#; |
| pragma Export (C, Others_Value, "__gnat_others_value"); |
| |
| All_Others_Value : constant Integer := 16#7FFF#; |
| pragma Export (C, All_Others_Value, "__gnat_all_others_value"); |
| |
| Unhandled_Others_Value : constant Integer := 16#7FFF#; |
| 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 GNAT_GCC_Exception' |
| (Header => (Class => GNAT_Exception_Class, |
| Cleanup => GNAT_GCC_Exception_Cleanup'Address, |
| others => 0), |
| Occurrence => (others => <>)); |
| 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; |
| |
| ------------------------- |
| -- Setup_Current_Excep -- |
| ------------------------- |
| |
| function Setup_Current_Excep |
| (GCC_Exception : not null GCC_Exception_Access) return EOA |
| is |
| Excep : constant EOA := Get_Current_Excep.all; |
| |
| 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 |
| Excep.all := GNAT_Occurrence.Occurrence; |
| |
| return GNAT_Occurrence.Occurrence'Access; |
| end; |
| else |
| |
| -- A default one |
| |
| Excep.Id := Foreign_Exception'Access; |
| Excep.Machine_Occurrence := GCC_Exception.all'Address; |
| Excep.Msg_Length := 0; |
| Excep.Exception_Raised := True; |
| Excep.Pid := Local_Partition_ID; |
| Excep.Num_Tracebacks := 0; |
| |
| return Excep; |
| end if; |
| end Setup_Current_Excep; |
| |
| ------------------- |
| -- 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 |
| Excep : EOA; |
| |
| 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. |
| |
| Excep := Setup_Current_Excep (GCC_Exception); |
| 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 : EOA) is |
| begin |
| Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); |
| end Propagate_Exception; |
| |
| ------------------------------ |
| -- Unhandled_Except_Handler -- |
| ------------------------------ |
| |
| procedure Unhandled_Except_Handler |
| (GCC_Exception : not null GCC_Exception_Access) |
| is |
| Excep : EOA; |
| begin |
| Excep := Setup_Current_Excep (GCC_Exception); |
| 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; |
| |
| --------------------- |
| -- Import_Code_For -- |
| --------------------- |
| |
| function Import_Code_For |
| (E : SSL.Exception_Data_Ptr) return Exception_Code |
| is |
| begin |
| return E.all.Import_Code; |
| end Import_Code_For; |
| |
| -------------------------- |
| -- Is_Handled_By_Others -- |
| -------------------------- |
| |
| function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is |
| begin |
| return not E.all.Not_Handled_By_Others; |
| end Is_Handled_By_Others; |
| |
| ------------------ |
| -- Language_For -- |
| ------------------ |
| |
| function Language_For (E : SSL.Exception_Data_Ptr) return Character is |
| begin |
| return E.all.Lang; |
| end Language_For; |
| |
| end Exception_Propagation; |
