summaryrefslogtreecommitdiff
path: root/gcc/ada/raise-gcc.c
blob: 9c6aef930a9479ab806d92c66568abe39cc2b4de (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
/****************************************************************************
 *                                                                          *
 *                         GNAT COMPILER COMPONENTS                         *
 *                                                                          *
 *                            R A I S E - G C C                             *
 *                                                                          *
 *                          C Implementation File                           *
 *                                                                          *
 *             Copyright (C) 1992-2010, 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.      *
 *                                                                          *
 ****************************************************************************/

/* Code related to the integration of the GCC mechanism for exception
   handling.  */

#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.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 <sys/stat.h>
#include <stdarg.h>
typedef char bool;
# define true 1
# define false 0
#else
#include "config.h"
#include "system.h"
#endif

#include "adaint.h"
#include "raise.h"

#ifdef __APPLE__
/* On MacOS X, versions older than 10.5 don't export _Unwind_GetIPInfo.  */
#undef HAVE_GETIPINFO
#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ >= 1050
#define HAVE_GETIPINFO 1
#endif
#endif

/* 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, even though 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 whether 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_personality_v0.

   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_personality_v0 (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)
{
  int ip_before_insn = 0;
#ifdef HAVE_GETIPINFO
  _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn);
#else
  _Unwind_Ptr ip = _Unwind_GetIP (uw_context);
#endif
  if (!ip_before_insn)
    ip--;

  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;
  _uleb128_t 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, &region->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)
{
  int ip_before_insn = 0;
#ifdef HAVE_GETIPINFO
  _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn);
#else
  _Unwind_Ptr ip = _Unwind_GetIP (uw_context);
#endif
  if (!ip_before_insn)
    ip--;

  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.  */

#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)
{
  int ip_before_insn = 0;
#ifdef HAVE_GETIPINFO
  _Unwind_Ptr call_site = _Unwind_GetIPInfo (uw_context, &ip_before_insn);
#else
  _Unwind_Ptr call_site = _Unwind_GetIP (uw_context);
#endif
  /* Subtract 1 if necessary because GetIPInfo returns the actual call site
     value + 1 in this case.  */
  if (!ip_before_insn)
    call_site--;

  /* 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
    {
      _uleb128_t 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)
{
  const unsigned char *p = region->call_site_table;
  int ip_before_insn = 0;
#ifdef HAVE_GETIPINFO
  _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn);
#else
  _Unwind_Ptr ip = _Unwind_GetIP (uw_context);
#endif
  /* Subtract 1 if necessary because GetIPInfo yields a call return address
     in this case, 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.  */
  if (!ip_before_insn)
    ip--;

  /* 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;
      _uleb128_t 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 /* __USING_SJLJ_EXCEPTIONS__  */

/* With CHOICE an exception choice representing an "exception - when"
   argument, and PROPAGATED_EXCEPTION a pointer to the currently propagated
   occurrence, return true if 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;

      _sleb128_t 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.  */

#ifdef __USING_SJLJ_EXCEPTIONS__
#define PERSONALITY_FUNCTION    __gnat_personality_sj0
#else
#define PERSONALITY_FUNCTION    __gnat_personality_v0
#endif

/* Major tweak for ia64-vms : the CHF propagation phase calls this personality
   routine with sigargs/mechargs arguments and has very specific expectations
   on possible return values.

   We handle this with a number of specific tricks:

   1. We tweak the personality routine prototype to have the "version" and
      "phases" two first arguments be void * instead of int and _Unwind_Action
      as nominally expected in the GCC context.

      This allows us to access the full range of bits passed in every case and
      has no impact on the callers side since each argument remains assigned
      the same single 64bit slot.

   2. We retrieve the corresponding int and _Unwind_Action values within the
      routine for regular use with truncating conversions. This is a noop when
      called from the libgcc unwinder.

   3. We assume we're called by the VMS CHF when unexpected bits are set in
      both those values. The incoming arguments are then real sigargs and
      mechargs pointers, which we then redirect to __gnat_handle_vms_condition
      for proper processing.
*/
#if defined (VMS) && defined (__IA64)
typedef void * version_arg_t;
typedef void * phases_arg_t;
#else
typedef int version_arg_t;
typedef _Unwind_Action phases_arg_t;
#endif

_Unwind_Reason_Code
PERSONALITY_FUNCTION (version_arg_t version_arg,
                      phases_arg_t phases_arg,
                      _Unwind_Exception_Class uw_exception_class,
                      _Unwind_Exception *uw_exception,
                      _Unwind_Context *uw_context)
{
  /* Fetch the version and phases args with their nominal ABI types for later
     use. This is a noop everywhere except on ia64-vms when called from the
     Condition Handling Facility.  */
  int uw_version = (int) version_arg;
  _Unwind_Action uw_phases = (_Unwind_Action) phases_arg;

  _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;

  region_descriptor region;
  action_descriptor action;

  /* Check that we're called from the ABI context we expect, with a major
     possible variation on VMS for IA64.  */
  if (uw_version != 1)
    {
      #if defined (VMS) && defined (__IA64)

      /* Assume we're called with sigargs/mechargs arguments if really
	 unexpected bits are set in our first two formals.  Redirect to the
	 GNAT condition handling code in this case.  */

      extern long __gnat_handle_vms_condition (void *, void *);

      unsigned int version_unexpected_bits_mask = 0xffffff00U;
      unsigned int phases_unexpected_bits_mask  = 0xffffff00U;

      if ((unsigned int)uw_version & version_unexpected_bits_mask
	  && (unsigned int)uw_phases & phases_unexpected_bits_mask)
	return __gnat_handle_vms_condition (version_arg, phases_arg);
      #endif

      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, &region);
  db_region_for (&region, 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, &region, &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 whether 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 */