diff options
Diffstat (limited to 'gcc/ada/raise-gcc.c')
| -rw-r--r-- | gcc/ada/raise-gcc.c | 1150 |
1 files changed, 1150 insertions, 0 deletions
diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c new file mode 100644 index 00000000000..0f9b94c7cd9 --- /dev/null +++ b/gcc/ada/raise-gcc.c @@ -0,0 +1,1150 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * R A I S E - G C C * + * * + * C Implementation File * + * * + * Copyright (C) 1992-2005, 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 2, 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. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * + * * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* Code related to the integration of the GCC mechanism for exception + handling. */ + +#ifdef IN_RTS +#include "tconfig.h" +/* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2 + it does. To avoid branching raise.c just for that purpose, we kludge by + looking for a symbol always defined by tm.h and if it's not defined, + we include it. */ +#ifndef FIRST_PSEUDO_REGISTER +#include "coretypes.h" +#include "tm.h" +#endif +#include "tsystem.h" +#include <sys/stat.h> +typedef char bool; +# define true 1 +# define false 0 +#else +#include "config.h" +#include "system.h" +#endif + +#include "adaint.h" +#include "raise.h" + +/* The names of a couple of "standard" routines for unwinding/propagation + actually vary depending on the underlying GCC scheme for exception handling + (SJLJ or DWARF). We need a consistently named interface to import from + a-except, so wrappers are defined here. + + Besides, eventhough the compiler is never setup to use the GCC propagation + circuitry, it still relies on exceptions internally and part of the sources + to handle to exceptions are shared with the run-time library. We need + dummy definitions for the wrappers to satisfy the linker in this case. + + The types to be used by those wrappers in the run-time library are target + types exported by unwind.h. We used to piggyback on them for the compiler + stubs, but there is no guarantee that unwind.h is always in sight so we + define our own set below. These are dummy types as the wrappers are never + called in the compiler case. */ + +#ifdef IN_RTS + +#include "unwind.h" + +typedef struct _Unwind_Context _Unwind_Context; +typedef struct _Unwind_Exception _Unwind_Exception; + +#else + +typedef void _Unwind_Context; +typedef void _Unwind_Exception; +typedef int _Unwind_Reason_Code; + +#endif + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *); + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); + + +#ifdef IN_RTS /* For eh personality routine */ + +#include "dwarf2.h" +#include "unwind-dw2-fde.h" +#include "unwind-pe.h" + + +/* -------------------------------------------------------------- + -- The DB stuff below is there for debugging purposes only. -- + -------------------------------------------------------------- */ + +#define DB_PHASES 0x1 +#define DB_CSITE 0x2 +#define DB_ACTIONS 0x4 +#define DB_REGIONS 0x8 + +#define DB_ERR 0x1000 + +/* The "action" stuff below is also there for debugging purposes only. */ + +typedef struct +{ + _Unwind_Action phase; + char * description; +} phase_descriptor; + +static phase_descriptor phase_descriptors[] + = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" }, + { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" }, + { _UA_HANDLER_FRAME, "HANDLER_FRAME" }, + { _UA_FORCE_UNWIND, "FORCE_UNWIND" }, + { -1, 0}}; + +static int +db_accepted_codes (void) +{ + static int accepted_codes = -1; + + if (accepted_codes == -1) + { + char * db_env = (char *) getenv ("EH_DEBUG"); + + accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0; + /* Arranged for ERR stuff to always be visible when the variable + is defined. One may just set the variable to 0 to see the ERR + stuff only. */ + } + + return accepted_codes; +} + +#define DB_INDENT_INCREASE 0x01 +#define DB_INDENT_DECREASE 0x02 +#define DB_INDENT_OUTPUT 0x04 +#define DB_INDENT_NEWLINE 0x08 +#define DB_INDENT_RESET 0x10 + +#define DB_INDENT_UNIT 8 + +static void +db_indent (int requests) +{ + static int current_indentation_level = 0; + + if (requests & DB_INDENT_RESET) + { + current_indentation_level = 0; + } + + if (requests & DB_INDENT_INCREASE) + { + current_indentation_level ++; + } + + if (requests & DB_INDENT_DECREASE) + { + current_indentation_level --; + } + + if (requests & DB_INDENT_NEWLINE) + { + fprintf (stderr, "\n"); + } + + if (requests & DB_INDENT_OUTPUT) + { + fprintf (stderr, "%*s", + current_indentation_level * DB_INDENT_UNIT, " "); + } + +} + +static void ATTRIBUTE_PRINTF_2 +db (int db_code, char * msg_format, ...) +{ + if (db_accepted_codes () & db_code) + { + va_list msg_args; + + db_indent (DB_INDENT_OUTPUT); + + va_start (msg_args, msg_format); + vfprintf (stderr, msg_format, msg_args); + va_end (msg_args); + } +} + +static void +db_phases (int phases) +{ + phase_descriptor *a = phase_descriptors; + + if (! (db_accepted_codes() & DB_PHASES)) + return; + + db (DB_PHASES, "\n"); + + for (; a->description != 0; a++) + if (phases & a->phase) + db (DB_PHASES, "%s ", a->description); + + db (DB_PHASES, " :\n"); +} + + +/* --------------------------------------------------------------- + -- Now come a set of useful structures and helper routines. -- + --------------------------------------------------------------- */ + +/* There are three major runtime tables involved, generated by the + GCC back-end. Contents slightly vary depending on the underlying + implementation scheme (dwarf zero cost / sjlj). + + ======================================= + * Tables for the dwarf zero cost case * + ======================================= + + call_site [] + ------------------------------------------------------------------- + * region-start | region-length | landing-pad | first-action-index * + ------------------------------------------------------------------- + + Identify possible actions to be taken and where to resume control + for that when an exception propagates through a pc inside the region + delimited by start and length. + + A null landing-pad indicates that nothing is to be done. + + Otherwise, first-action-index provides an entry into the action[] + table which heads a list of possible actions to be taken (see below). + + If it is determined that indeed an action should be taken, that + is, if one action filter matches the exception being propagated, + then control should be transfered to landing-pad. + + A null first-action-index indicates that there are only cleanups + to run there. + + action [] + ------------------------------- + * action-filter | next-action * + ------------------------------- + + This table contains lists (called action chains) of possible actions + associated with call-site entries described in the call-site [] table. + There is at most one action list per call-site entry. + + A null action-filter indicates a cleanup. + + Non null action-filters provide an index into the ttypes [] table + (see below), from which information may be retrieved to check if it + matches the exception being propagated. + + action-filter > 0 means there is a regular handler to be run, + + action-filter < 0 means there is a some "exception_specification" + data to retrieve, which is only relevant for C++ + and should never show up for Ada. + + next-action indexes the next entry in the list. 0 indicates there is + no other entry. + + ttypes [] + --------------- + * ttype-value * + --------------- + + A null value indicates a catch-all handler in C++, and an "others" + handler in Ada. + + Non null values are used to match the exception being propagated: + In C++ this is a pointer to some rtti data, while in Ada this is an + exception id. + + The special id value 1 indicates an "all_others" handler. + + For C++, this table is actually also used to store "exception + specification" data. The differentiation between the two kinds + of entries is made by the sign of the associated action filter, + which translates into positive or negative offsets from the + so called base of the table: + + Exception Specification data is stored at positive offsets from + the ttypes table base, which Exception Type data is stored at + negative offsets: + + --------------------------------------------------------------------------- + + Here is a quick summary of the tables organization: + + +-- Unwind_Context (pc, ...) + | + |(pc) + | + | CALL-SITE[] + | + | +=============================================================+ + | | region-start + length | landing-pad | first-action-index | + | +=============================================================+ + +-> | pc range 0 => no-action 0 => cleanups only | + | !0 => jump @ N --+ | + +====================================================== | ====+ + | + | + ACTION [] | + | + +==========================================================+ | + | action-filter | next-action | | + +==========================================================+ | + | 0 => cleanup | | + | >0 => ttype index for handler ------+ 0 => end of chain | <-+ + | <0 => ttype index for spec data | | + +==================================== | ===================+ + | + | + TTYPES [] | + | Offset negated from + +=====================+ | the actual base. + | ttype-value | | + +============+=====================+ | + | | 0 => "others" | | + | ... | 1 => "all others" | <---+ + | | X => exception id | + | handlers +---------------------+ + | | ... | + | ... | ... | + | | ... | + +============+=====================+ <<------ Table base + | ... | ... | + | specs | ... | (should not see negative filter + | ... | ... | values for Ada). + +============+=====================+ + + + ============================ + * Tables for the sjlj case * + ============================ + + So called "function contexts" are pushed on a context stack by calls to + _Unwind_SjLj_Register on function entry, and popped off at exit points by + calls to _Unwind_SjLj_Unregister. The current call_site for a function is + updated in the function context as the function's code runs along. + + The generic unwinding engine in _Unwind_RaiseException walks the function + context stack and not the actual call chain. + + The ACTION and TTYPES tables remain unchanged, which allows to search them + during the propagation phase to determine wether or not the propagated + exception is handled somewhere. When it is, we only "jump" up once directly + to the context where the handler will be found. Besides, this allows "break + exception unhandled" to work also + + The CALL-SITE table is setup differently, though: the pc attached to the + unwind context is a direct index into the table, so the entries in this + table do not hold region bounds any more. + + A special index (-1) is used to indicate that no action is possibly + connected with the context at hand, so null landing pads cannot appear + in the table. + + Additionally, landing pad values in the table do not represent code address + to jump at, but so called "dispatch" indices used by a common landing pad + for the function to switch to the appropriate post-landing-pad. + + +-- Unwind_Context (pc, ...) + | + | pc = call-site index + | 0 => terminate (should not see this for Ada) + | -1 => no-action + | + | CALL-SITE[] + | + | +=====================================+ + | | landing-pad | first-action-index | + | +=====================================+ + +-> | 0 => cleanups only | + | dispatch index N | + +=====================================+ + + + =================================== + * Basic organization of this unit * + =================================== + + The major point of this unit is to provide an exception propagation + personality routine for Ada. This is __gnat_eh_personality. + + It is provided with a pointer to the propagated exception, an unwind + context describing a location the propagation is going through, and a + couple of other arguments including a description of the current + propagation phase. + + It shall return to the generic propagation engine what is to be performed + next, after possible context adjustments, depending on what it finds in the + traversed context (a handler for the exception, a cleanup, nothing, ...), + and on the propagation phase. + + A number of structures and subroutines are used for this purpose, as + sketched below: + + o region_descriptor: General data associated with the context (base pc, + call-site table, action table, ttypes table, ...) + + o action_descriptor: Data describing the action to be taken for the + propagated exception in the provided context (kind of action: nothing, + handler, cleanup; pointer to the action table entry, ...). + + raise + | + ... (a-except.adb) + | + Propagate_Exception (a-exexpr.adb) + | + | + _Unwind_RaiseException (libgcc) + | + | (Ada frame) + | + +--> __gnat_eh_personality (context, exception) + | + +--> get_region_descriptor_for (context) + | + +--> get_action_descriptor_for (context, exception, region) + | | + | +--> get_call_site_action_for (context, region) + | (one version for each underlying scheme) + | + +--> setup_to_install (context) + + This unit is inspired from the C++ version found in eh_personality.cc, + part of libstdc++-v3. + +*/ + + +/* This is an incomplete "proxy" of the structure of exception objects as + built by the GNAT runtime library. Accesses to other fields than the common + header are performed through subprogram calls to alleviate the need of an + exact counterpart here and potential alignment/size issues for the common + header. See a-exexpr.adb. */ + +typedef struct +{ + _Unwind_Exception common; + /* ABI header, maximally aligned. */ +} _GNAT_Exception; + +/* The two constants below are specific ttype identifiers for special + exception ids. Their type should match what a-exexpr exports. */ + +extern const int __gnat_others_value; +#define GNAT_OTHERS ((_Unwind_Ptr) &__gnat_others_value) + +extern const int __gnat_all_others_value; +#define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value) + +/* Describe the useful region data associated with an unwind context. */ + +typedef struct +{ + /* The base pc of the region. */ + _Unwind_Ptr base; + + /* Pointer to the Language Specific Data for the region. */ + _Unwind_Ptr lsda; + + /* Call-Site data associated with this region. */ + unsigned char call_site_encoding; + const unsigned char *call_site_table; + + /* The base to which are relative landing pad offsets inside the call-site + entries . */ + _Unwind_Ptr lp_base; + + /* Action-Table associated with this region. */ + const unsigned char *action_table; + + /* Ttype data associated with this region. */ + unsigned char ttype_encoding; + const unsigned char *ttype_table; + _Unwind_Ptr ttype_base; + +} region_descriptor; + +static void +db_region_for (region_descriptor *region, _Unwind_Context *uw_context) +{ + _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1; + + if (! (db_accepted_codes () & DB_REGIONS)) + return; + + db (DB_REGIONS, "For ip @ 0x%08x => ", ip); + + if (region->lsda) + db (DB_REGIONS, "lsda @ 0x%x", region->lsda); + else + db (DB_REGIONS, "no lsda"); + + db (DB_REGIONS, "\n"); +} + +/* Retrieve the ttype entry associated with FILTER in the REGION's + ttype table. */ + +static const _Unwind_Ptr +get_ttype_entry_for (region_descriptor *region, long filter) +{ + _Unwind_Ptr ttype_entry; + + filter *= size_of_encoded_value (region->ttype_encoding); + read_encoded_value_with_base + (region->ttype_encoding, region->ttype_base, + region->ttype_table - filter, &ttype_entry); + + return ttype_entry; +} + +/* Fill out the REGION descriptor for the provided UW_CONTEXT. */ + +static void +get_region_description_for (_Unwind_Context *uw_context, + region_descriptor *region) +{ + const unsigned char * p; + _Unwind_Word tmp; + unsigned char lpbase_encoding; + + /* Get the base address of the lsda information. If the provided context + is null or if there is no associated language specific data, there's + nothing we can/should do. */ + region->lsda + = (_Unwind_Ptr) (uw_context + ? _Unwind_GetLanguageSpecificData (uw_context) : 0); + + if (! region->lsda) + return; + + /* Parse the lsda and fill the region descriptor. */ + p = (char *)region->lsda; + + region->base = _Unwind_GetRegionStart (uw_context); + + /* Find @LPStart, the base to which landing pad offsets are relative. */ + lpbase_encoding = *p++; + if (lpbase_encoding != DW_EH_PE_omit) + p = read_encoded_value + (uw_context, lpbase_encoding, p, ®ion->lp_base); + else + region->lp_base = region->base; + + /* Find @TType, the base of the handler and exception spec type data. */ + region->ttype_encoding = *p++; + if (region->ttype_encoding != DW_EH_PE_omit) + { + p = read_uleb128 (p, &tmp); + region->ttype_table = p + tmp; + } + else + region->ttype_table = 0; + + region->ttype_base + = base_of_encoded_value (region->ttype_encoding, uw_context); + + /* Get the encoding and length of the call-site table; the action table + immediately follows. */ + region->call_site_encoding = *p++; + region->call_site_table = read_uleb128 (p, &tmp); + + region->action_table = region->call_site_table + tmp; +} + + +/* Describe an action to be taken when propagating an exception up to + some context. */ + +typedef enum +{ + /* Found some call site base data, but need to analyze further + before being able to decide. */ + unknown, + + /* There is nothing relevant in the context at hand. */ + nothing, + + /* There are only cleanups to run in this context. */ + cleanup, + + /* There is a handler for the exception in this context. */ + handler +} action_kind; + +/* filter value for cleanup actions. */ +const int cleanup_filter = 0; + +typedef struct +{ + /* The kind of action to be taken. */ + action_kind kind; + + /* A pointer to the action record entry. */ + const unsigned char *table_entry; + + /* Where we should jump to actually take an action (trigger a cleanup or an + exception handler). */ + _Unwind_Ptr landing_pad; + + /* If we have a handler matching our exception, these are the filter to + trigger it and the corresponding id. */ + _Unwind_Sword ttype_filter; + _Unwind_Ptr ttype_entry; + +} action_descriptor; + +static void +db_action_for (action_descriptor *action, _Unwind_Context *uw_context) +{ + _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1; + + db (DB_ACTIONS, "For ip @ 0x%08x => ", ip); + + switch (action->kind) + { + case unknown: + db (DB_ACTIONS, "lpad @ 0x%x, record @ 0x%x\n", + action->landing_pad, action->table_entry); + break; + + case nothing: + db (DB_ACTIONS, "Nothing\n"); + break; + + case cleanup: + db (DB_ACTIONS, "Cleanup\n"); + break; + + case handler: + db (DB_ACTIONS, "Handler, filter = %d\n", action->ttype_filter); + break; + + default: + db (DB_ACTIONS, "Err? Unexpected action kind !\n"); + break; + } + + return; +} + + +/* Search the call_site_table of REGION for an entry appropriate for the + UW_CONTEXT's ip. If one is found, store the associated landing_pad and + action_table entry, and set the ACTION kind to unknown for further + analysis. Otherwise, set the ACTION kind to nothing. + + There are two variants of this routine, depending on the underlying + mechanism (dwarf/sjlj), which account for differences in the tables + organization. +*/ + +#ifdef __USING_SJLJ_EXCEPTIONS__ + +#define __builtin_eh_return_data_regno(x) x + +static void +get_call_site_action_for (_Unwind_Context *uw_context, + region_descriptor *region, + action_descriptor *action) +{ + _Unwind_Ptr call_site + = _Unwind_GetIP (uw_context) - 1; + /* Subtract 1 because GetIP returns the actual call_site value + 1. */ + + /* call_site is a direct index into the call-site table, with two special + values : -1 for no-action and 0 for "terminate". The latter should never + show up for Ada. To test for the former, beware that _Unwind_Ptr might be + unsigned. */ + + if ((int)call_site < 0) + { + action->kind = nothing; + return; + } + else if (call_site == 0) + { + db (DB_ERR, "========> Err, null call_site for Ada/sjlj\n"); + action->kind = nothing; + return; + } + else + { + _Unwind_Word cs_lp, cs_action; + + /* Let the caller know there may be an action to take, but let it + determine the kind. */ + action->kind = unknown; + + /* We have a direct index into the call-site table, but this table is + made of leb128 values, the encoding length of which is variable. We + can't merely compute an offset from the index, then, but have to read + all the entries before the one of interest. */ + + const unsigned char * p = region->call_site_table; + + do { + p = read_uleb128 (p, &cs_lp); + p = read_uleb128 (p, &cs_action); + } while (--call_site); + + + action->landing_pad = cs_lp + 1; + + if (cs_action) + action->table_entry = region->action_table + cs_action - 1; + else + action->table_entry = 0; + + return; + } +} + +#else +/* ! __USING_SJLJ_EXCEPTIONS__ */ + +static void +get_call_site_action_for (_Unwind_Context *uw_context, + region_descriptor *region, + action_descriptor *action) +{ + _Unwind_Ptr ip + = _Unwind_GetIP (uw_context) - 1; + /* Subtract 1 because GetIP yields a call return address while we are + interested in information for the call point. This does not always yield + the exact call instruction address but always brings the ip back within + the corresponding region. + + ??? When unwinding up from a signal handler triggered by a trap on some + instruction, we usually have the faulting instruction address here and + subtracting 1 might get us into the wrong region. */ + + const unsigned char * p + = region->call_site_table; + + /* Unless we are able to determine otherwise ... */ + action->kind = nothing; + + db (DB_CSITE, "\n"); + + while (p < region->action_table) + { + _Unwind_Ptr cs_start, cs_len, cs_lp; + _Unwind_Word cs_action; + + /* Note that all call-site encodings are "absolute" displacements. */ + p = read_encoded_value (0, region->call_site_encoding, p, &cs_start); + p = read_encoded_value (0, region->call_site_encoding, p, &cs_len); + p = read_encoded_value (0, region->call_site_encoding, p, &cs_lp); + p = read_uleb128 (p, &cs_action); + + db (DB_CSITE, + "c_site @ 0x%08x (+0x%03x), len = %3d, lpad @ 0x%08x (+0x%03x)\n", + region->base+cs_start, cs_start, cs_len, + region->lp_base+cs_lp, cs_lp); + + /* The table is sorted, so if we've passed the ip, stop. */ + if (ip < region->base + cs_start) + break; + + /* If we have a match, fill the ACTION fields accordingly. */ + else if (ip < region->base + cs_start + cs_len) + { + /* Let the caller know there may be an action to take, but let it + determine the kind. */ + action->kind = unknown; + + if (cs_lp) + action->landing_pad = region->lp_base + cs_lp; + else + action->landing_pad = 0; + + if (cs_action) + action->table_entry = region->action_table + cs_action - 1; + else + action->table_entry = 0; + + db (DB_CSITE, "+++\n"); + return; + } + } + + db (DB_CSITE, "---\n"); +} + +#endif + +/* With CHOICE an exception choice representing an "exception - when" + argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated + occurrence, return true iif the latter matches the former, that is, if + PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE. + This takes care of the special Non_Ada_Error case on VMS. */ + +#define Is_Handled_By_Others __gnat_is_handled_by_others +#define Language_For __gnat_language_for +#define Import_Code_For __gnat_import_code_for +#define EID_For __gnat_eid_for +#define Adjust_N_Cleanups_For __gnat_adjust_n_cleanups_for + +extern bool Is_Handled_By_Others (_Unwind_Ptr eid); +extern char Language_For (_Unwind_Ptr eid); + +extern Exception_Code Import_Code_For (_Unwind_Ptr eid); + +extern Exception_Id EID_For (_GNAT_Exception * e); +extern void Adjust_N_Cleanups_For (_GNAT_Exception * e, int n); + +static int +is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception) +{ + /* Pointer to the GNAT exception data corresponding to the propagated + occurrence. */ + _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception); + + /* Base matching rules: An exception data (id) matches itself, "when + all_others" matches anything and "when others" matches anything unless + explicitly stated otherwise in the propagated occurrence. */ + + bool is_handled = + choice == E + || choice == GNAT_ALL_OTHERS + || (choice == GNAT_OTHERS && Is_Handled_By_Others (E)); + + /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we + may have different exception data pointers that should match for the + same condition code, if both an export and an import have been + registered. The import code for both the choice and the propagated + occurrence are expected to have been masked off regarding severity + bits already (at registration time for the former and from within the + low level exception vector for the latter). */ +#ifdef VMS + #define Non_Ada_Error system__aux_dec__non_ada_error + extern struct Exception_Data Non_Ada_Error; + + is_handled |= + (Language_For (E) == 'V' + && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS + && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0 + && Import_Code_For (choice) == Import_Code_For (E)) + || choice == (_Unwind_Ptr)&Non_Ada_Error)); +#endif + + return is_handled; +} + +/* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to + UW_CONTEXT in REGION. */ + +static void +get_action_description_for (_Unwind_Context *uw_context, + _Unwind_Exception *uw_exception, + region_descriptor *region, + action_descriptor *action) +{ + _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception; + + /* Search the call site table first, which may get us a landing pad as well + as the head of an action record list. */ + get_call_site_action_for (uw_context, region, action); + db_action_for (action, uw_context); + + /* If there is not even a call_site entry, we are done. */ + if (action->kind == nothing) + return; + + /* Otherwise, check what we have at the place of the call site. */ + + /* No landing pad => no cleanups or handlers. */ + if (action->landing_pad == 0) + { + action->kind = nothing; + return; + } + + /* Landing pad + null table entry => only cleanups. */ + else if (action->table_entry == 0) + { + action->kind = cleanup; + action->ttype_filter = cleanup_filter; + /* The filter initialization is not strictly necessary, as cleanup-only + landing pads don't look at the filter value. It is there to ensure + we don't pass random values and so trigger potential confusion when + installing the context later on. */ + return; + } + + /* Landing pad + Table entry => handlers + possible cleanups. */ + else + { + const unsigned char * p = action->table_entry; + + _Unwind_Sword ar_filter, ar_disp; + + action->kind = nothing; + + while (1) + { + p = read_sleb128 (p, &ar_filter); + read_sleb128 (p, &ar_disp); + /* Don't assign p here, as it will be incremented by ar_disp + below. */ + + /* Null filters are for cleanups. */ + if (ar_filter == cleanup_filter) + { + action->kind = cleanup; + action->ttype_filter = cleanup_filter; + /* The filter initialization is required here, to ensure + the target landing pad branches to the cleanup code if + we happen not to find a matching handler. */ + } + + /* Positive filters are for regular handlers. */ + else if (ar_filter > 0) + { + /* See if the filter we have is for an exception which matches + the one we are propagating. */ + _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter); + + if (is_handled_by (choice, gnat_exception)) + { + action->kind = handler; + action->ttype_filter = ar_filter; + action->ttype_entry = choice; + return; + } + } + + /* Negative filter values are for C++ exception specifications. + Should not be there for Ada :/ */ + else + db (DB_ERR, "========> Err, filter < 0 for Ada/dwarf\n"); + + if (ar_disp == 0) + return; + + p += ar_disp; + } + } +} + +/* Setup in UW_CONTEXT the eh return target IP and data registers, which will + be restored with the others and retrieved by the landing pad once the jump + occurred. */ + +static void +setup_to_install (_Unwind_Context *uw_context, + _Unwind_Exception *uw_exception, + _Unwind_Ptr uw_landing_pad, + int uw_filter) +{ +#ifndef EH_RETURN_DATA_REGNO + /* We should not be called if the appropriate underlying support is not + there. */ + abort (); +#else + /* 1/ exception object pointer, which might be provided back to + _Unwind_Resume (and thus to this personality routine) if we are jumping + to a cleanup. */ + _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (0), + (_Unwind_Word)uw_exception); + + /* 2/ handler switch value register, which will also be used by the target + landing pad to decide what action it shall take. */ + _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (1), + (_Unwind_Word)uw_filter); + + /* Setup the address we should jump at to reach the code where there is the + "something" we found. */ + _Unwind_SetIP (uw_context, uw_landing_pad); +#endif +} + +/* The following is defined from a-except.adb. Its purpose is to enable + automatic backtraces upon exception raise, as provided through the + GNAT.Traceback facilities. */ +extern void __gnat_notify_handled_exception (void); +extern void __gnat_notify_unhandled_exception (void); + +/* Below is the eh personality routine per se. We currently assume that only + GNU-Ada exceptions are met. */ + +_Unwind_Reason_Code +__gnat_eh_personality (int uw_version, + _Unwind_Action uw_phases, + _Unwind_Exception_Class uw_exception_class, + _Unwind_Exception *uw_exception, + _Unwind_Context *uw_context) +{ + _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception; + + region_descriptor region; + action_descriptor action; + + if (uw_version != 1) + return _URC_FATAL_PHASE1_ERROR; + + db_indent (DB_INDENT_RESET); + db_phases (uw_phases); + db_indent (DB_INDENT_INCREASE); + + /* Get the region description for the context we were provided with. This + will tell us if there is some lsda, call_site, action and/or ttype data + for the associated ip. */ + get_region_description_for (uw_context, ®ion); + db_region_for (®ion, uw_context); + + /* No LSDA => no handlers or cleanups => we shall unwind further up. */ + if (! region.lsda) + return _URC_CONTINUE_UNWIND; + + /* Search the call-site and action-record tables for the action associated + with this IP. */ + get_action_description_for (uw_context, uw_exception, ®ion, &action); + db_action_for (&action, uw_context); + + /* Whatever the phase, if there is nothing relevant in this frame, + unwinding should just go on. */ + if (action.kind == nothing) + return _URC_CONTINUE_UNWIND; + + /* If we found something in search phase, we should return a code indicating + what to do next depending on what we found. If we only have cleanups + around, we shall try to unwind further up to find a handler, otherwise, + tell we have a handler, which will trigger the second phase. */ + if (uw_phases & _UA_SEARCH_PHASE) + { + if (action.kind == cleanup) + { + Adjust_N_Cleanups_For (gnat_exception, 1); + return _URC_CONTINUE_UNWIND; + } + else + { + /* Trigger the appropriate notification routines before the second + phase starts, which ensures the stack is still intact. */ + __gnat_notify_handled_exception (); + + return _URC_HANDLER_FOUND; + } + } + + /* We found something in cleanup/handler phase, which might be the handler + or a cleanup for a handled occurrence, or a cleanup for an unhandled + occurrence (we are in a FORCED_UNWIND phase in this case). Install the + context to get there. */ + + /* If we are going to install a cleanup context, decrement the cleanup + count. This is required in a FORCED_UNWINDing phase (for an unhandled + exception), as this is used from the forced unwinding handler in + Ada.Exceptions.Exception_Propagation to decide wether unwinding should + proceed further or Unhandled_Exception_Terminate should be called. */ + if (action.kind == cleanup) + Adjust_N_Cleanups_For (gnat_exception, -1); + + setup_to_install + (uw_context, uw_exception, action.landing_pad, action.ttype_filter); + + return _URC_INSTALL_CONTEXT; +} + +/* Define the consistently named wrappers imported by Propagate_Exception. */ + +#ifdef __USING_SJLJ_EXCEPTIONS__ + +#undef _Unwind_RaiseException + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *e) +{ + return _Unwind_SjLj_RaiseException (e); +} + + +#undef _Unwind_ForcedUnwind + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, + void * handler, + void * argument) +{ + return _Unwind_SjLj_ForcedUnwind (e, handler, argument); +} + + +#else /* __USING_SJLJ_EXCEPTIONS__ */ + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *e) +{ + return _Unwind_RaiseException (e); +} + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e, + void * handler, + void * argument) +{ + return _Unwind_ForcedUnwind (e, handler, argument); +} + +#endif /* __USING_SJLJ_EXCEPTIONS__ */ + +#else +/* ! IN_RTS */ + +/* Define the corresponding stubs for the compiler. */ + +/* We don't want fancy_abort here. */ +#undef abort + +_Unwind_Reason_Code +__gnat_Unwind_RaiseException (_Unwind_Exception *e ATTRIBUTE_UNUSED) +{ + abort (); +} + + +_Unwind_Reason_Code +__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED, + void * handler ATTRIBUTE_UNUSED, + void * argument ATTRIBUTE_UNUSED) +{ + abort (); +} + +#endif /* IN_RTS */ |