Mark ChangeLog
[official-gcc.git] / gcc / ada / raise.c
blob7de1f7754b799f981081f60b6464ab77b103519a
1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * R A I S E *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2004, Free Software Foundation, Inc. *
10 * *
11 * GNAT is free software; you can redistribute it and/or modify it under *
12 * terms of the GNU General Public License as published by the Free Soft- *
13 * ware Foundation; either version 2, or (at your option) any later ver- *
14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
17 * for more details. You should have received a copy of the GNU General *
18 * Public License distributed with GNAT; see file COPYING. If not, write *
19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
20 * MA 02111-1307, USA. *
21 * *
22 * As a special exception, if you link this file with other files to *
23 * produce an executable, this file does not by itself cause the resulting *
24 * executable to be covered by the GNU General Public License. This except- *
25 * ion does not however invalidate any other reasons why the executable *
26 * file might be covered by the GNU Public License. *
27 * *
28 * GNAT was originally developed by the GNAT team at New York University. *
29 * Extensive contributions were provided by Ada Core Technologies Inc. *
30 * *
31 ****************************************************************************/
33 /* Routines to support runtime exception handling */
35 #ifdef IN_RTS
36 #include "tconfig.h"
37 /* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2
38 it does. To avoid branching raise.c just for that purpose, we kludge by
39 looking for a symbol always defined by tm.h and if it's not defined,
40 we include it. */
41 #ifndef FIRST_PSEUDO_REGISTER
42 #include "coretypes.h"
43 #include "tm.h"
44 #endif
45 #include "tsystem.h"
46 #include <sys/stat.h>
47 typedef char bool;
48 # define true 1
49 # define false 0
50 #else
51 #include "config.h"
52 #include "system.h"
53 #endif
55 #include "adaint.h"
56 #include "raise.h"
58 /* We have not yet figured out how to import this directly */
60 void
61 _gnat_builtin_longjmp (void *ptr, int flag ATTRIBUTE_UNUSED)
63 __builtin_longjmp (ptr, 1);
66 /* When an exception is raised for which no handler exists, the procedure
67 Ada.Exceptions.Unhandled_Exception is called, which performs the call to
68 adafinal to complete finalization, and then prints out the error messages
69 for the unhandled exception. The final step is to call this routine, which
70 performs any system dependent cleanup required. */
72 void
73 __gnat_unhandled_terminate (void)
75 /* Special termination handling for VMS */
77 #ifdef VMS
79 long prvhnd;
81 /* Remove the exception vector so it won't intercept any errors
82 in the call to exit, and go into and endless loop */
84 SYS$SETEXV (1, 0, 3, &prvhnd);
85 __gnat_os_exit (1);
88 /* Termination handling for all other systems. */
90 #elif !defined (__RT__)
91 __gnat_os_exit (1);
92 #endif
95 /* Below is the code related to the integration of the GCC mechanism for
96 exception handling. */
98 #include "unwind.h"
100 /* The names of a couple of "standard" routines for unwinding/propagation
101 actually vary depending on the underlying GCC scheme for exception handling
102 (SJLJ or DWARF). We need a consistently named interface to import from
103 a-except, so stubs are defined here. */
105 typedef struct _Unwind_Context _Unwind_Context;
106 typedef struct _Unwind_Exception _Unwind_Exception;
108 _Unwind_Reason_Code
109 __gnat_Unwind_RaiseException (_Unwind_Exception *);
111 _Unwind_Reason_Code
112 __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
115 #ifdef IN_RTS /* For eh personality routine */
117 #include "dwarf2.h"
118 #include "unwind-dw2-fde.h"
119 #include "unwind-pe.h"
122 /* --------------------------------------------------------------
123 -- The DB stuff below is there for debugging purposes only. --
124 -------------------------------------------------------------- */
126 #define DB_PHASES 0x1
127 #define DB_CSITE 0x2
128 #define DB_ACTIONS 0x4
129 #define DB_REGIONS 0x8
131 #define DB_ERR 0x1000
133 /* The "action" stuff below is also there for debugging purposes only. */
135 typedef struct
137 _Unwind_Action phase;
138 char * description;
139 } phase_descriptor;
141 static phase_descriptor phase_descriptors[]
142 = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" },
143 { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" },
144 { _UA_HANDLER_FRAME, "HANDLER_FRAME" },
145 { _UA_FORCE_UNWIND, "FORCE_UNWIND" },
146 { -1, 0}};
148 static int
149 db_accepted_codes (void)
151 static int accepted_codes = -1;
153 if (accepted_codes == -1)
155 char * db_env = (char *) getenv ("EH_DEBUG");
157 accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0;
158 /* Arranged for ERR stuff to always be visible when the variable
159 is defined. One may just set the variable to 0 to see the ERR
160 stuff only. */
163 return accepted_codes;
166 #define DB_INDENT_INCREASE 0x01
167 #define DB_INDENT_DECREASE 0x02
168 #define DB_INDENT_OUTPUT 0x04
169 #define DB_INDENT_NEWLINE 0x08
170 #define DB_INDENT_RESET 0x10
172 #define DB_INDENT_UNIT 8
174 static void
175 db_indent (int requests)
177 static int current_indentation_level = 0;
179 if (requests & DB_INDENT_RESET)
181 current_indentation_level = 0;
184 if (requests & DB_INDENT_INCREASE)
186 current_indentation_level ++;
189 if (requests & DB_INDENT_DECREASE)
191 current_indentation_level --;
194 if (requests & DB_INDENT_NEWLINE)
196 fprintf (stderr, "\n");
199 if (requests & DB_INDENT_OUTPUT)
201 fprintf (stderr, "%*s",
202 current_indentation_level * DB_INDENT_UNIT, " ");
207 static void
208 db (int db_code, char * msg_format, ...)
210 if (db_accepted_codes () & db_code)
212 va_list msg_args;
214 db_indent (DB_INDENT_OUTPUT);
216 va_start (msg_args, msg_format);
217 vfprintf (stderr, msg_format, msg_args);
218 va_end (msg_args);
222 static void
223 db_phases (int phases)
225 phase_descriptor *a = phase_descriptors;
227 if (! (db_accepted_codes() & DB_PHASES))
228 return;
230 db (DB_PHASES, "\n");
232 for (; a->description != 0; a++)
233 if (phases & a->phase)
234 db (DB_PHASES, "%s ", a->description);
236 db (DB_PHASES, " :\n");
240 /* ---------------------------------------------------------------
241 -- Now come a set of useful structures and helper routines. --
242 --------------------------------------------------------------- */
244 /* There are three major runtime tables involved, generated by the
245 GCC back-end. Contents slightly vary depending on the underlying
246 implementation scheme (dwarf zero cost / sjlj).
248 =======================================
249 * Tables for the dwarf zero cost case *
250 =======================================
252 call_site []
253 -------------------------------------------------------------------
254 * region-start | region-length | landing-pad | first-action-index *
255 -------------------------------------------------------------------
257 Identify possible actions to be taken and where to resume control
258 for that when an exception propagates through a pc inside the region
259 delimited by start and length.
261 A null landing-pad indicates that nothing is to be done.
263 Otherwise, first-action-index provides an entry into the action[]
264 table which heads a list of possible actions to be taken (see below).
266 If it is determined that indeed an action should be taken, that
267 is, if one action filter matches the exception beeing propagated,
268 then control should be transfered to landing-pad.
270 A null first-action-index indicates that there are only cleanups
271 to run there.
273 action []
274 -------------------------------
275 * action-filter | next-action *
276 -------------------------------
278 This table contains lists (called action chains) of possible actions
279 associated with call-site entries described in the call-site [] table.
280 There is at most one action list per call-site entry.
282 A null action-filter indicates a cleanup.
284 Non null action-filters provide an index into the ttypes [] table
285 (see below), from which information may be retrieved to check if it
286 matches the exception beeing propagated.
288 action-filter > 0 means there is a regular handler to be run,
290 action-filter < 0 means there is a some "exception_specification"
291 data to retrieve, which is only relevant for C++
292 and should never show up for Ada.
294 next-action indexes the next entry in the list. 0 indicates there is
295 no other entry.
297 ttypes []
298 ---------------
299 * ttype-value *
300 ---------------
302 A null value indicates a catch-all handler in C++, and an "others"
303 handler in Ada.
305 Non null values are used to match the exception beeing propagated:
306 In C++ this is a pointer to some rtti data, while in Ada this is an
307 exception id.
309 The special id value 1 indicates an "all_others" handler.
311 For C++, this table is actually also used to store "exception
312 specification" data. The differentiation between the two kinds
313 of entries is made by the sign of the associated action filter,
314 which translates into positive or negative offsets from the
315 so called base of the table:
317 Exception Specification data is stored at positive offsets from
318 the ttypes table base, which Exception Type data is stored at
319 negative offsets:
321 ---------------------------------------------------------------------------
323 Here is a quick summary of the tables organization:
325 +-- Unwind_Context (pc, ...)
327 |(pc)
329 | CALL-SITE[]
331 | +=============================================================+
332 | | region-start + length | landing-pad | first-action-index |
333 | +=============================================================+
334 +-> | pc range 0 => no-action 0 => cleanups only |
335 | !0 => jump @ N --+ |
336 +====================================================== | ====+
339 ACTION [] |
341 +==========================================================+ |
342 | action-filter | next-action | |
343 +==========================================================+ |
344 | 0 => cleanup | |
345 | >0 => ttype index for handler ------+ 0 => end of chain | <-+
346 | <0 => ttype index for spec data | |
347 +==================================== | ===================+
350 TTYPES [] |
351 | Offset negated from
352 +=====================+ | the actual base.
353 | ttype-value | |
354 +============+=====================+ |
355 | | 0 => "others" | |
356 | ... | 1 => "all others" | <---+
357 | | X => exception id |
358 | handlers +---------------------+
359 | | ... |
360 | ... | ... |
361 | | ... |
362 +============+=====================+ <<------ Table base
363 | ... | ... |
364 | specs | ... | (should not see negative filter
365 | ... | ... | values for Ada).
366 +============+=====================+
369 ============================
370 * Tables for the sjlj case *
371 ============================
373 So called "function contexts" are pushed on a context stack by calls to
374 _Unwind_SjLj_Register on function entry, and popped off at exit points by
375 calls to _Unwind_SjLj_Unregister. The current call_site for a function is
376 updated in the function context as the function's code runs along.
378 The generic unwinding engine in _Unwind_RaiseException walks the function
379 context stack and not the actual call chain.
381 The ACTION and TTYPES tables remain unchanged, which allows to search them
382 during the propagation phase to determine wether or not the propagated
383 exception is handled somewhere. When it is, we only "jump" up once directly
384 to the context where the handler will be found. Besides, this allows "break
385 exception unhandled" to work also
387 The CALL-SITE table is setup differently, though: the pc attached to the
388 unwind context is a direct index into the table, so the entries in this
389 table do not hold region bounds any more.
391 A special index (-1) is used to indicate that no action is possibly
392 connected with the context at hand, so null landing pads cannot appear
393 in the table.
395 Additionally, landing pad values in the table do not represent code address
396 to jump at, but so called "dispatch" indices used by a common landing pad
397 for the function to switch to the appropriate post-landing-pad.
399 +-- Unwind_Context (pc, ...)
401 | pc = call-site index
402 | 0 => terminate (should not see this for Ada)
403 | -1 => no-action
405 | CALL-SITE[]
407 | +=====================================+
408 | | landing-pad | first-action-index |
409 | +=====================================+
410 +-> | 0 => cleanups only |
411 | dispatch index N |
412 +=====================================+
415 ===================================
416 * Basic organization of this unit *
417 ===================================
419 The major point of this unit is to provide an exception propagation
420 personality routine for Ada. This is __gnat_eh_personality.
422 It is provided with a pointer to the propagated exception, an unwind
423 context describing a location the propagation is going through, and a
424 couple of other arguments including a description of the current
425 propagation phase.
427 It shall return to the generic propagation engine what is to be performed
428 next, after possible context adjustments, depending on what it finds in the
429 traversed context (a handler for the exception, a cleanup, nothing, ...),
430 and on the propagation phase.
432 A number of structures and subroutines are used for this purpose, as
433 sketched below:
435 o region_descriptor: General data associated with the context (base pc,
436 call-site table, action table, ttypes table, ...)
438 o action_descriptor: Data describing the action to be taken for the
439 propagated exception in the provided context (kind of action: nothing,
440 handler, cleanup; pointer to the action table entry, ...).
442 raise
444 ... (a-except.adb)
446 Propagate_Exception (a-exexpr.adb)
449 _Unwind_RaiseException (libgcc)
451 | (Ada frame)
453 +--> __gnat_eh_personality (context, exception)
455 +--> get_region_descriptor_for (context)
457 +--> get_action_descriptor_for (context, exception, region)
459 | +--> get_call_site_action_for (context, region)
460 | (one version for each underlying scheme)
462 +--> setup_to_install (context)
464 This unit is inspired from the C++ version found in eh_personality.cc,
465 part of libstdc++-v3.
470 /* This is an incomplete "proxy" of the structure of exception objects as
471 built by the GNAT runtime library. Accesses to other fields than the common
472 header are performed through subprogram calls to aleviate the need of an
473 exact counterpart here and potential alignment/size issues for the common
474 header. See a-exexpr.adb. */
476 typedef struct
478 _Unwind_Exception common;
479 /* ABI header, maximally aligned. */
480 } _GNAT_Exception;
482 /* The two constants below are specific ttype identifiers for special
483 exception ids. Their type should match what a-exexpr exports. */
485 extern const int __gnat_others_value;
486 #define GNAT_OTHERS ((_Unwind_Ptr) &__gnat_others_value)
488 extern const int __gnat_all_others_value;
489 #define GNAT_ALL_OTHERS ((_Unwind_Ptr) &__gnat_all_others_value)
491 /* Describe the useful region data associated with an unwind context. */
493 typedef struct
495 /* The base pc of the region. */
496 _Unwind_Ptr base;
498 /* Pointer to the Language Specific Data for the region. */
499 _Unwind_Ptr lsda;
501 /* Call-Site data associated with this region. */
502 unsigned char call_site_encoding;
503 const unsigned char *call_site_table;
505 /* The base to which are relative landing pad offsets inside the call-site
506 entries . */
507 _Unwind_Ptr lp_base;
509 /* Action-Table associated with this region. */
510 const unsigned char *action_table;
512 /* Ttype data associated with this region. */
513 unsigned char ttype_encoding;
514 const unsigned char *ttype_table;
515 _Unwind_Ptr ttype_base;
517 } region_descriptor;
519 static void
520 db_region_for (region_descriptor *region, _Unwind_Context *uw_context)
522 _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
524 if (! (db_accepted_codes () & DB_REGIONS))
525 return;
527 db (DB_REGIONS, "For ip @ 0x%08x => ", ip);
529 if (region->lsda)
530 db (DB_REGIONS, "lsda @ 0x%x", region->lsda);
531 else
532 db (DB_REGIONS, "no lsda");
534 db (DB_REGIONS, "\n");
537 /* Retrieve the ttype entry associated with FILTER in the REGION's
538 ttype table. */
540 static const _Unwind_Ptr
541 get_ttype_entry_for (region_descriptor *region, long filter)
543 _Unwind_Ptr ttype_entry;
545 filter *= size_of_encoded_value (region->ttype_encoding);
546 read_encoded_value_with_base
547 (region->ttype_encoding, region->ttype_base,
548 region->ttype_table - filter, &ttype_entry);
550 return ttype_entry;
553 /* Fill out the REGION descriptor for the provided UW_CONTEXT. */
555 static void
556 get_region_description_for (_Unwind_Context *uw_context,
557 region_descriptor *region)
559 const unsigned char * p;
560 _Unwind_Word tmp;
561 unsigned char lpbase_encoding;
563 /* Get the base address of the lsda information. If the provided context
564 is null or if there is no associated language specific data, there's
565 nothing we can/should do. */
566 region->lsda
567 = (_Unwind_Ptr) (uw_context
568 ? _Unwind_GetLanguageSpecificData (uw_context) : 0);
570 if (! region->lsda)
571 return;
573 /* Parse the lsda and fill the region descriptor. */
574 p = (char *)region->lsda;
576 region->base = _Unwind_GetRegionStart (uw_context);
578 /* Find @LPStart, the base to which landing pad offsets are relative. */
579 lpbase_encoding = *p++;
580 if (lpbase_encoding != DW_EH_PE_omit)
581 p = read_encoded_value
582 (uw_context, lpbase_encoding, p, &region->lp_base);
583 else
584 region->lp_base = region->base;
586 /* Find @TType, the base of the handler and exception spec type data. */
587 region->ttype_encoding = *p++;
588 if (region->ttype_encoding != DW_EH_PE_omit)
590 p = read_uleb128 (p, &tmp);
591 region->ttype_table = p + tmp;
593 else
594 region->ttype_table = 0;
596 region->ttype_base
597 = base_of_encoded_value (region->ttype_encoding, uw_context);
599 /* Get the encoding and length of the call-site table; the action table
600 immediately follows. */
601 region->call_site_encoding = *p++;
602 region->call_site_table = read_uleb128 (p, &tmp);
604 region->action_table = region->call_site_table + tmp;
608 /* Describe an action to be taken when propagating an exception up to
609 some context. */
611 typedef enum
613 /* Found some call site base data, but need to analyze further
614 before beeing able to decide. */
615 unknown,
617 /* There is nothing relevant in the context at hand. */
618 nothing,
620 /* There are only cleanups to run in this context. */
621 cleanup,
623 /* There is a handler for the exception in this context. */
624 handler
625 } action_kind;
628 typedef struct
630 /* The kind of action to be taken. */
631 action_kind kind;
633 /* A pointer to the action record entry. */
634 const unsigned char *table_entry;
636 /* Where we should jump to actually take an action (trigger a cleanup or an
637 exception handler). */
638 _Unwind_Ptr landing_pad;
640 /* If we have a handler matching our exception, these are the filter to
641 trigger it and the corresponding id. */
642 _Unwind_Sword ttype_filter;
643 _Unwind_Ptr ttype_entry;
645 } action_descriptor;
648 static void
649 db_action_for (action_descriptor *action, _Unwind_Context *uw_context)
651 _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
653 db (DB_ACTIONS, "For ip @ 0x%08x => ", ip);
655 switch (action->kind)
657 case unknown:
658 db (DB_ACTIONS, "lpad @ 0x%x, record @ 0x%x\n",
659 action->landing_pad, action->table_entry);
660 break;
662 case nothing:
663 db (DB_ACTIONS, "Nothing\n");
664 break;
666 case cleanup:
667 db (DB_ACTIONS, "Cleanup\n");
668 break;
670 case handler:
671 db (DB_ACTIONS, "Handler, filter = %d\n", action->ttype_filter);
672 break;
674 default:
675 db (DB_ACTIONS, "Err? Unexpected action kind !\n");
676 break;
679 return;
683 /* Search the call_site_table of REGION for an entry appropriate for the
684 UW_CONTEXT's ip. If one is found, store the associated landing_pad and
685 action_table entry, and set the ACTION kind to unknown for further
686 analysis. Otherwise, set the ACTION kind to nothing.
688 There are two variants of this routine, depending on the underlying
689 mechanism (dwarf/sjlj), which account for differences in the tables
690 organization.
693 #ifdef __USING_SJLJ_EXCEPTIONS__
695 #define __builtin_eh_return_data_regno(x) x
697 static void
698 get_call_site_action_for (_Unwind_Context *uw_context,
699 region_descriptor *region,
700 action_descriptor *action)
702 _Unwind_Ptr call_site
703 = _Unwind_GetIP (uw_context) - 1;
704 /* Subtract 1 because GetIP returns the actual call_site value + 1. */
706 /* call_site is a direct index into the call-site table, with two special
707 values : -1 for no-action and 0 for "terminate". The latter should never
708 show up for Ada. To test for the former, beware that _Unwind_Ptr might be
709 unsigned. */
711 if ((int)call_site < 0)
713 action->kind = nothing;
714 return;
716 else if (call_site == 0)
718 db (DB_ERR, "========> Err, null call_site for Ada/sjlj\n");
719 action->kind = nothing;
720 return;
722 else
724 _Unwind_Word cs_lp, cs_action;
726 /* Let the caller know there may be an action to take, but let it
727 determine the kind. */
728 action->kind = unknown;
730 /* We have a direct index into the call-site table, but this table is
731 made of leb128 values, the encoding length of which is variable. We
732 can't merely compute an offset from the index, then, but have to read
733 all the entries before the one of interest. */
735 const unsigned char * p = region->call_site_table;
737 do {
738 p = read_uleb128 (p, &cs_lp);
739 p = read_uleb128 (p, &cs_action);
740 } while (--call_site);
743 action->landing_pad = cs_lp + 1;
745 if (cs_action)
746 action->table_entry = region->action_table + cs_action - 1;
747 else
748 action->table_entry = 0;
750 return;
754 #else
755 /* ! __USING_SJLJ_EXCEPTIONS__ */
757 static void
758 get_call_site_action_for (_Unwind_Context *uw_context,
759 region_descriptor *region,
760 action_descriptor *action)
762 _Unwind_Ptr ip
763 = _Unwind_GetIP (uw_context) - 1;
764 /* Substract 1 because GetIP yields a call return address while we are
765 interested in information for the call point. This does not always yield
766 the exact call instruction address but always brings the ip back within
767 the corresponding region.
769 ??? When unwinding up from a signal handler triggered by a trap on some
770 instruction, we usually have the faulting instruction address here and
771 subtracting 1 might get us into the wrong region. */
773 const unsigned char * p
774 = region->call_site_table;
776 /* Unless we are able to determine otherwise ... */
777 action->kind = nothing;
779 db (DB_CSITE, "\n");
781 while (p < region->action_table)
783 _Unwind_Ptr cs_start, cs_len, cs_lp;
784 _Unwind_Word cs_action;
786 /* Note that all call-site encodings are "absolute" displacements. */
787 p = read_encoded_value (0, region->call_site_encoding, p, &cs_start);
788 p = read_encoded_value (0, region->call_site_encoding, p, &cs_len);
789 p = read_encoded_value (0, region->call_site_encoding, p, &cs_lp);
790 p = read_uleb128 (p, &cs_action);
792 db (DB_CSITE,
793 "c_site @ 0x%08x (+0x%03x), len = %3d, lpad @ 0x%08x (+0x%03x)\n",
794 region->base+cs_start, cs_start, cs_len,
795 region->lp_base+cs_lp, cs_lp);
797 /* The table is sorted, so if we've passed the ip, stop. */
798 if (ip < region->base + cs_start)
799 break;
801 /* If we have a match, fill the ACTION fields accordingly. */
802 else if (ip < region->base + cs_start + cs_len)
804 /* Let the caller know there may be an action to take, but let it
805 determine the kind. */
806 action->kind = unknown;
808 if (cs_lp)
809 action->landing_pad = region->lp_base + cs_lp;
810 else
811 action->landing_pad = 0;
813 if (cs_action)
814 action->table_entry = region->action_table + cs_action - 1;
815 else
816 action->table_entry = 0;
818 db (DB_CSITE, "+++\n");
819 return;
823 db (DB_CSITE, "---\n");
826 #endif
828 /* With CHOICE an exception choice representing an "exception - when"
829 argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated
830 occurrence, return true iif the latter matches the former, that is, if
831 PROPAGATED_EXCEPTION is caught by the handling code controlled by CHOICE.
832 This takes care of the special Non_Ada_Error case on VMS. */
834 #define Is_Handled_By_Others __gnat_is_handled_by_others
835 #define Language_For __gnat_language_for
836 #define Import_Code_For __gnat_import_code_for
837 #define EID_For __gnat_eid_for
838 #define Adjust_N_Cleanups_For __gnat_adjust_n_cleanups_for
840 extern bool Is_Handled_By_Others (_Unwind_Ptr eid);
841 extern char Language_For (_Unwind_Ptr eid);
843 extern Exception_Code Import_Code_For (_Unwind_Ptr eid);
845 extern Exception_Id EID_For (_GNAT_Exception * e);
846 extern void Adjust_N_Cleanups_For (_GNAT_Exception * e, int n);
848 static int
849 is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
851 /* Pointer to the GNAT exception data corresponding to the propagated
852 occurrence. */
853 _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
855 /* Base matching rules: An exception data (id) matches itself, "when
856 all_others" matches anything and "when others" matches anything unless
857 explicitely stated otherwise in the propagated occurrence. */
859 bool is_handled =
860 choice == E
861 || choice == GNAT_ALL_OTHERS
862 || (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
864 /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
865 may have different exception data pointers that should match for the
866 same condition code, if both an export and an import have been
867 registered. The import code for both the choice and the propagated
868 occurrence are expected to have been masked off regarding severity
869 bits already (at registration time for the former and from within the
870 low level exception vector for the latter). */
871 #ifdef VMS
872 #define Non_Ada_Error system__aux_dec__non_ada_error
873 extern struct Exception_Data Non_Ada_Error;
875 is_handled |=
876 (Language_For (E) == 'V'
877 && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
878 && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
879 && Import_Code_For (choice) == Import_Code_For (E))
880 || choice == (_Unwind_Ptr)&Non_Ada_Error));
881 #endif
883 return is_handled;
886 /* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to
887 UW_CONTEXT in REGION. */
889 static void
890 get_action_description_for (_Unwind_Context *uw_context,
891 _Unwind_Exception *uw_exception,
892 region_descriptor *region,
893 action_descriptor *action)
895 _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
897 /* Search the call site table first, which may get us a landing pad as well
898 as the head of an action record list. */
899 get_call_site_action_for (uw_context, region, action);
900 db_action_for (action, uw_context);
902 /* If there is not even a call_site entry, we are done. */
903 if (action->kind == nothing)
904 return;
906 /* Otherwise, check what we have at the place of the call site */
908 /* No landing pad => no cleanups or handlers. */
909 if (action->landing_pad == 0)
911 action->kind = nothing;
912 return;
915 /* Landing pad + null table entry => only cleanups. */
916 else if (action->table_entry == 0)
918 action->kind = cleanup;
919 return;
922 /* Landing pad + Table entry => handlers + possible cleanups. */
923 else
925 const unsigned char * p = action->table_entry;
927 _Unwind_Sword ar_filter, ar_disp;
929 action->kind = nothing;
931 while (1)
933 p = read_sleb128 (p, &ar_filter);
934 read_sleb128 (p, &ar_disp);
935 /* Don't assign p here, as it will be incremented by ar_disp
936 below. */
938 /* Null filters are for cleanups. */
939 if (ar_filter == 0)
940 action->kind = cleanup;
942 /* Positive filters are for regular handlers. */
943 else if (ar_filter > 0)
945 /* See if the filter we have is for an exception which matches
946 the one we are propagating. */
947 _Unwind_Ptr choice = get_ttype_entry_for (region, ar_filter);
949 if (is_handled_by (choice, gnat_exception))
951 action->ttype_filter = ar_filter;
952 action->ttype_entry = choice;
953 action->kind = handler;
954 return;
958 /* Negative filter values are for C++ exception specifications.
959 Should not be there for Ada :/ */
960 else
961 db (DB_ERR, "========> Err, filter < 0 for Ada/dwarf\n");
963 if (ar_disp == 0)
964 return;
966 p += ar_disp;
971 /* Setup in UW_CONTEXT the eh return target IP and data registers, which will
972 be restored with the others and retrieved by the landing pad once the jump
973 occured. */
975 static void
976 setup_to_install (_Unwind_Context *uw_context,
977 _Unwind_Exception *uw_exception,
978 _Unwind_Ptr uw_landing_pad,
979 int uw_filter)
981 #ifndef EH_RETURN_DATA_REGNO
982 /* We should not be called if the appropriate underlying support is not
983 there. */
984 abort ();
985 #else
986 /* 1/ exception object pointer, which might be provided back to
987 _Unwind_Resume (and thus to this personality routine) if we are jumping
988 to a cleanup. */
989 _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (0),
990 (_Unwind_Word)uw_exception);
992 /* 2/ handler switch value register, which will also be used by the target
993 landing pad to decide what action it shall take. */
994 _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (1),
995 (_Unwind_Word)uw_filter);
997 /* Setup the address we should jump at to reach the code where there is the
998 "something" we found. */
999 _Unwind_SetIP (uw_context, uw_landing_pad);
1000 #endif
1003 /* The following is defined from a-except.adb. Its purpose is to enable
1004 automatic backtraces upon exception raise, as provided through the
1005 GNAT.Traceback facilities. */
1006 extern void __gnat_notify_handled_exception (void);
1007 extern void __gnat_notify_unhandled_exception (void);
1009 /* Below is the eh personality routine per se. We currently assume that only
1010 GNU-Ada exceptions are met. */
1012 _Unwind_Reason_Code
1013 __gnat_eh_personality (int uw_version,
1014 _Unwind_Action uw_phases,
1015 _Unwind_Exception_Class uw_exception_class,
1016 _Unwind_Exception *uw_exception,
1017 _Unwind_Context *uw_context)
1019 _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
1021 region_descriptor region;
1022 action_descriptor action;
1024 if (uw_version != 1)
1025 return _URC_FATAL_PHASE1_ERROR;
1027 db_indent (DB_INDENT_RESET);
1028 db_phases (uw_phases);
1029 db_indent (DB_INDENT_INCREASE);
1031 /* Get the region description for the context we were provided with. This
1032 will tell us if there is some lsda, call_site, action and/or ttype data
1033 for the associated ip. */
1034 get_region_description_for (uw_context, &region);
1035 db_region_for (&region, uw_context);
1037 /* No LSDA => no handlers or cleanups => we shall unwind further up. */
1038 if (! region.lsda)
1039 return _URC_CONTINUE_UNWIND;
1041 /* Search the call-site and action-record tables for the action associated
1042 with this IP. */
1043 get_action_description_for (uw_context, uw_exception, &region, &action);
1044 db_action_for (&action, uw_context);
1046 /* Whatever the phase, if there is nothing relevant in this frame,
1047 unwinding should just go on. */
1048 if (action.kind == nothing)
1049 return _URC_CONTINUE_UNWIND;
1051 /* If we found something in search phase, we should return a code indicating
1052 what to do next depending on what we found. If we only have cleanups
1053 around, we shall try to unwind further up to find a handler, otherwise,
1054 tell we have a handler, which will trigger the second phase. */
1055 if (uw_phases & _UA_SEARCH_PHASE)
1057 if (action.kind == cleanup)
1059 Adjust_N_Cleanups_For (gnat_exception, 1);
1060 return _URC_CONTINUE_UNWIND;
1062 else
1064 /* Trigger the appropriate notification routines before the second
1065 phase starts, which ensures the stack is still intact. */
1066 __gnat_notify_handled_exception ();
1068 return _URC_HANDLER_FOUND;
1072 /* We found something in cleanup/handler phase, which might be the handler
1073 or a cleanup for a handled occurrence, or a cleanup for an unhandled
1074 occurrence (we are in a FORCED_UNWIND phase in this case). Install the
1075 context to get there. */
1077 /* If we are going to install a cleanup context, decrement the cleanup
1078 count. This is required in a FORCED_UNWINDing phase (for an unhandled
1079 exception), as this is used from the forced unwinding handler in
1080 Ada.Exceptions.Exception_Propagation to decide wether unwinding should
1081 proceed further or Unhandled_Exception_Terminate should be called. */
1082 if (action.kind == cleanup)
1083 Adjust_N_Cleanups_For (gnat_exception, -1);
1085 setup_to_install
1086 (uw_context, uw_exception, action.landing_pad, action.ttype_filter);
1088 return _URC_INSTALL_CONTEXT;
1091 /* Define the consistently named stubs imported by Propagate_Exception. */
1093 #ifdef __USING_SJLJ_EXCEPTIONS__
1095 #undef _Unwind_RaiseException
1097 _Unwind_Reason_Code
1098 __gnat_Unwind_RaiseException (_Unwind_Exception *e)
1100 return _Unwind_SjLj_RaiseException (e);
1104 #undef _Unwind_ForcedUnwind
1106 _Unwind_Reason_Code
1107 __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e,
1108 void * handler,
1109 void * argument)
1111 return _Unwind_SjLj_ForcedUnwind (e, handler, argument);
1115 #else /* __USING_SJLJ_EXCEPTIONS__ */
1117 _Unwind_Reason_Code
1118 __gnat_Unwind_RaiseException (_Unwind_Exception *e)
1120 return _Unwind_RaiseException (e);
1123 _Unwind_Reason_Code
1124 __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e,
1125 void * handler,
1126 void * argument)
1128 return _Unwind_ForcedUnwind (e, handler, argument);
1131 #endif /* __USING_SJLJ_EXCEPTIONS__ */
1133 #else
1134 /* ! IN_RTS */
1136 /* The calls to the GCC runtime interface for exception raising are currently
1137 issued from a-exexpr.adb, which is used by both the runtime library and the
1138 compiler.
1140 As the compiler binary is not linked against the GCC runtime library, we
1141 need also need stubs for this interface in the compiler case. We should not
1142 be using the GCC eh mechanism for the compiler, however, so expect these
1143 functions never to be called. */
1145 /* We don't want fancy_abort here. */
1146 #undef abort
1148 _Unwind_Reason_Code
1149 __gnat_Unwind_RaiseException (_Unwind_Exception *e ATTRIBUTE_UNUSED)
1151 abort ();
1155 _Unwind_Reason_Code
1156 __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED,
1157 void * handler ATTRIBUTE_UNUSED,
1158 void * argument ATTRIBUTE_UNUSED)
1160 abort ();
1163 #endif /* IN_RTS */