------------------------------------------------------------------------------
-- --
-- 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;