summaryrefslogtreecommitdiff
path: root/gcc/ada/a-exexpr-gcc.adb
blob: 358f6fa2f407558c23d0ed047bff2d3472f3f6b3 (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
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--  A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is the version using the GCC EH mechanism

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;

with System.Storage_Elements;  use System.Storage_Elements;

separate (Ada.Exceptions)
package body Exception_Propagation is

   ------------------------------------------------
   -- Entities to interface with the GCC runtime --
   ------------------------------------------------

   --  These come from "C++ ABI for Itanium: Exception handling", which is
   --  the reference for GCC. They are used only when we are relying on
   --  back-end tables for exception propagation, which in turn is currently
   --  only the case for Zero_Cost_Exceptions in GNAT5.

   --  Return codes from the GCC runtime functions used to propagate
   --  an exception.

   type Unwind_Reason_Code is
     (URC_NO_REASON,
      URC_FOREIGN_EXCEPTION_CAUGHT,
      URC_PHASE2_ERROR,
      URC_PHASE1_ERROR,
      URC_NORMAL_STOP,
      URC_END_OF_STACK,
      URC_HANDLER_FOUND,
      URC_INSTALL_CONTEXT,
      URC_CONTINUE_UNWIND);

   pragma Unreferenced
     (URC_FOREIGN_EXCEPTION_CAUGHT,
      URC_PHASE2_ERROR,
      URC_PHASE1_ERROR,
      URC_NORMAL_STOP,
      URC_END_OF_STACK,
      URC_HANDLER_FOUND,
      URC_INSTALL_CONTEXT,
      URC_CONTINUE_UNWIND);

   pragma Convention (C, Unwind_Reason_Code);

   --  Phase identifiers

   type Unwind_Action is
     (UA_SEARCH_PHASE,
      UA_CLEANUP_PHASE,
      UA_HANDLER_FRAME,
      UA_FORCE_UNWIND);

   for Unwind_Action use
      (UA_SEARCH_PHASE  => 1,
       UA_CLEANUP_PHASE => 2,
       UA_HANDLER_FRAME => 4,
       UA_FORCE_UNWIND  => 8);

   pragma Convention (C, Unwind_Action);

   --  Mandatory common header for any exception object handled by the
   --  GCC unwinding runtime.

   type Exception_Class is mod 2 ** 64;

   GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
   --  "GNU-Ada\0"

   type Unwind_Word is mod 2 ** System.Word_Size;
   for Unwind_Word'Size use System.Word_Size;
   --  Map the corresponding C type used in Unwind_Exception below

   type Unwind_Exception is record
      Class    : Exception_Class := GNAT_Exception_Class;
      Cleanup  : System.Address  := System.Null_Address;
      Private1 : Unwind_Word;
      Private2 : Unwind_Word;
   end record;
   --  Map the GCC struct used for exception handling

   for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
   --  The C++ ABI mandates the common exception header to be at least
   --  doubleword aligned, and the libGCC implementation actually makes it
   --  maximally aligned (see unwind.h). See additional comments on the
   --  alignment below.

   --------------------------------------------------------------
   -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
   --------------------------------------------------------------

   --  A GNAT exception object to be dealt with by the personality routine
   --  called by the GCC unwinding runtime.

   type GNAT_GCC_Exception is record
      Header : Unwind_Exception;
      --  ABI Exception header first

      Id : Exception_Id;
      --  GNAT Exception identifier.  This is filled by Propagate_Exception
      --  and then used by the personality routine to determine if the context
      --  it examines contains a handler for the exception being propagated.

      N_Cleanups_To_Trigger : Integer;
      --  Number of cleanup only frames encountered in SEARCH phase.  This is
      --  initialized to 0 by Propagate_Exception and maintained by the
      --  personality routine to control a forced unwinding phase triggering
      --  all the cleanups before calling Unhandled_Exception_Terminate when
      --  an exception is not handled.

      Next_Exception : EOA;
      --  Used to create a linked list of exception occurrences
   end record;

   pragma Convention (C, GNAT_GCC_Exception);

   --  There is a subtle issue with the common header alignment, since the C
   --  version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
   --  Standard'Maximum_Alignment, and those two values don't quite represent
   --  the same concepts and so may be decoupled someday. One typical reason
   --  is that BIGGEST_ALIGNMENT may be larger than what the underlying system
   --  allocator guarantees, and there are extra costs involved in allocating
   --  objects aligned to such factors.

   --  To deal with the potential alignment differences between the C and Ada
   --  representations, the Ada part of the whole structure is only accessed
   --  by the personality routine through the accessors declared below.  Ada
   --  specific fields are thus always accessed through consistent layout, and
   --  we expect the actual alignment to always be large enough to avoid traps
   --  from the C accesses to the common header. Besides, accessors alleviate
   --  the need for a C struct whole counterpart, both painful and error-prone
   --  to maintain anyway.

   type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;

   function To_GNAT_GCC_Exception is new
     Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);

   procedure Free is new Unchecked_Deallocation
     (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);

   procedure Free is new Unchecked_Deallocation
     (Exception_Occurrence, EOA);

   function CleanupUnwind_Handler
     (UW_Version   : Integer;
      UW_Phases    : Unwind_Action;
      UW_Eclass    : Exception_Class;
      UW_Exception : not null access GNAT_GCC_Exception;
      UW_Context   : System.Address;
      UW_Argument  : System.Address) return Unwind_Reason_Code;
   --  Hook called at each step of the forced unwinding we perform to
   --  trigger cleanups found during the propagation of an unhandled
   --  exception.

   --  GCC runtime functions used. These are C non-void functions, actually,
   --  but we ignore the return values. See raise.c as to why we are using
   --  __gnat stubs for these.

   procedure Unwind_RaiseException
     (UW_Exception : not null access GNAT_GCC_Exception);
   pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");

   procedure Unwind_ForcedUnwind
     (UW_Exception : not null access GNAT_GCC_Exception;
      UW_Handler   : System.Address;
      UW_Argument  : System.Address);
   pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");

   ------------------------------------------------------------------
   -- Occurrence Stack Management Facilities for the GCC-EH Scheme --
   ------------------------------------------------------------------

   function Remove
     (Top   : EOA;
      Excep : GNAT_GCC_Exception_Access) return Boolean;
   --  Remove Excep from the stack starting at Top.
   --  Return True if Excep was found and removed, false otherwise.

   --  Hooks called when entering/leaving an exception handler for a given
   --  occurrence, aimed at handling the stack of active occurrences. The
   --  calls are generated by gigi in tree_transform/N_Exception_Handler.

   procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
   pragma Export (C, Begin_Handler, "__gnat_begin_handler");

   procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
   pragma Export (C, End_Handler, "__gnat_end_handler");

   Setup_Key : constant := 16#DEAD#;
   --  To handle the case of a task "transferring" an exception occurrence to
   --  another task, for instance via Exceptional_Complete_Rendezvous, we need
   --  to be able to identify occurrences which have been Setup and not yet
   --  Propagated. We hijack one of the common header fields for that purpose,
   --  setting it to a special key value during the setup process, clearing it
   --  at the very beginning of the propagation phase, and expecting it never
   --  to be reset to the special value later on. A 16-bit value is used rather
   --  than a 32-bit value for static compatibility with 16-bit targets such as
   --  AAMP (where type Unwind_Word will be 16 bits).

   function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;

   procedure Set_Setup_And_Not_Propagated (E : EOA);
   procedure Clear_Setup_And_Not_Propagated (E : EOA);

   procedure Save_Occurrence_And_Private
     (Target : out Exception_Occurrence;
      Source : Exception_Occurrence);
   --  Copy all the components of Source to Target as well as the
   --  Private_Data pointer.

   --------------------------------------------------------------------
   -- Accessors to Basic Components of a GNAT Exception Data Pointer --
   --------------------------------------------------------------------

   --  As of today, these are only used by the C implementation of the GCC
   --  propagation personality routine to avoid having to rely on a C
   --  counterpart of the whole exception_data structure, which is both
   --  painful and error prone. These subprograms could be moved to a more
   --  widely visible location if need be.

   function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
   pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
   pragma Warnings (Off, Is_Handled_By_Others);

   function Language_For (E : Exception_Data_Ptr) return Character;
   pragma Export (C, Language_For, "__gnat_language_for");

   function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
   pragma Export (C, Import_Code_For, "__gnat_import_code_for");

   function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access)
     return Exception_Id;
   pragma Export (C, EID_For, "__gnat_eid_for");

   procedure Adjust_N_Cleanups_For
     (GNAT_Exception : GNAT_GCC_Exception_Access;
      Adjustment     : Integer);
   pragma Export (C, Adjust_N_Cleanups_For, "__gnat_adjust_n_cleanups_for");

   ---------------------------------------------------------------------------
   -- Objects to materialize "others" and "all others" in the GCC EH tables --
   ---------------------------------------------------------------------------

   --  Currently, these only have their address taken and compared so there is
   --  no real point having whole exception data blocks allocated. In any case
   --  the types should match what gigi and the personality routine expect.
   --  The initial value is an arbitrary value that will not exceed the range
   --  of Integer on 16-bit targets (such as AAMP).

   Others_Value : constant Integer := 16#7FFF#;
   pragma Export (C, Others_Value, "__gnat_others_value");

   All_Others_Value : constant Integer := 16#7FFF#;
   pragma Export (C, All_Others_Value, "__gnat_all_others_value");

   ------------
   -- Remove --
   ------------

   function Remove
     (Top   : EOA;
      Excep : GNAT_GCC_Exception_Access) return Boolean
   is
      Prev          : GNAT_GCC_Exception_Access := null;
      Iter          : EOA := Top;
      GCC_Exception : GNAT_GCC_Exception_Access;

   begin
      --  Pop stack

      loop
         pragma Assert (Iter.Private_Data /= System.Null_Address);

         GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);

         if GCC_Exception = Excep then
            if Prev = null then

               --  Special case for the top of the stack: shift the contents
               --  of the next item to the top, since top is at a fixed
               --  location and can't be changed.

               Iter := GCC_Exception.Next_Exception;

               if Iter = null then

                  --  Stack is now empty

                  Top.Private_Data := System.Null_Address;

               else
                  Save_Occurrence_And_Private (Top.all, Iter.all);
                  Free (Iter);
               end if;

            else
               Prev.Next_Exception := GCC_Exception.Next_Exception;
               Free (Iter);
            end if;

            Free (GCC_Exception);

            return True;
         end if;

         exit when GCC_Exception.Next_Exception = null;

         Prev := GCC_Exception;
         Iter := GCC_Exception.Next_Exception;
      end loop;

      return False;
   end Remove;

   ---------------------------
   -- CleanupUnwind_Handler --
   ---------------------------

   function CleanupUnwind_Handler
     (UW_Version   : Integer;
      UW_Phases    : Unwind_Action;
      UW_Eclass    : Exception_Class;
      UW_Exception : not null access GNAT_GCC_Exception;
      UW_Context   : System.Address;
      UW_Argument  : System.Address) return Unwind_Reason_Code
   is
      pragma Unreferenced
        (UW_Version, UW_Phases, UW_Eclass, UW_Context, UW_Argument);

   begin
      --  Terminate as soon as we know there is nothing more to run. The
      --  count is maintained by the personality routine.

      if UW_Exception.N_Cleanups_To_Trigger = 0 then
         Unhandled_Exception_Terminate;
      end if;

      --  We know there is at least one cleanup further up. Return so that it
      --  is searched and entered, after which Unwind_Resume will be called
      --  and this hook will gain control (with an updated count) again.

      return URC_NO_REASON;
   end CleanupUnwind_Handler;

   ---------------------------------
   -- Is_Setup_And_Not_Propagated --
   ---------------------------------

   function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is
      GCC_E : constant GNAT_GCC_Exception_Access :=
                To_GNAT_GCC_Exception (E.Private_Data);
   begin
      return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;
   end Is_Setup_And_Not_Propagated;

   ------------------------------------
   -- Clear_Setup_And_Not_Propagated --
   ------------------------------------

   procedure Clear_Setup_And_Not_Propagated (E : EOA) is
      GCC_E : constant GNAT_GCC_Exception_Access :=
                To_GNAT_GCC_Exception (E.Private_Data);
   begin
      pragma Assert (GCC_E /= null);
      GCC_E.Header.Private1 := 0;
   end Clear_Setup_And_Not_Propagated;

   ----------------------------------
   -- Set_Setup_And_Not_Propagated --
   ----------------------------------

   procedure Set_Setup_And_Not_Propagated (E : EOA) is
      GCC_E : constant GNAT_GCC_Exception_Access :=
                To_GNAT_GCC_Exception (E.Private_Data);
   begin
      pragma Assert (GCC_E /= null);
      GCC_E.Header.Private1 := Setup_Key;
   end Set_Setup_And_Not_Propagated;

   --------------------------------
   -- Save_Occurrence_And_Private --
   --------------------------------

   procedure Save_Occurrence_And_Private
     (Target : out Exception_Occurrence;
      Source : Exception_Occurrence)
   is
   begin
      Save_Occurrence_No_Private (Target, Source);
      Target.Private_Data := Source.Private_Data;
   end Save_Occurrence_And_Private;

   ---------------------
   -- Setup_Exception --
   ---------------------

   --  In the GCC-EH implementation of the propagation scheme, this
   --  subprogram should be understood as: Setup the exception occurrence
   --  stack headed at Current for a forthcoming raise of Excep.

   procedure Setup_Exception
     (Excep    : EOA;
      Current  : EOA;
      Reraised : Boolean := False)
   is
      Top           : constant EOA := Current;
      Next          : EOA;
      GCC_Exception : GNAT_GCC_Exception_Access;

   begin
      --  The exception Excep is soon to be propagated, and the
      --  storage used for that will be the occurrence statically allocated
      --  for the current thread. This storage might currently be used for a
      --  still active occurrence, so we need to push it on the thread's
      --  occurrence stack (headed at that static occurrence) before it gets
      --  clobbered.

      --  What we do here is to trigger this push when need be, and allocate a
      --  Private_Data block for the forthcoming Propagation.

      --  Some tasking rendez-vous attempts lead to an occurrence transfer
      --  from the server to the client (see Exceptional_Complete_Rendezvous).
      --  In those cases Setup is called twice for the very same occurrence
      --  before it gets propagated: once from the server, because this is
      --  where the occurrence contents is elaborated and known, and then
      --  once from the client when it detects the case and actually raises
      --  the exception in its own context.

      --  The Is_Setup_And_Not_Propagated predicate tells us when we are in
      --  the second call to Setup for a Transferred occurrence, and there is
      --  nothing to be done here in this situation. This predicate cannot be
      --  True if we are dealing with a Reraise, and we may even be called
      --  with a raw uninitialized Excep occurrence in this case so we should
      --  not check anyway. Observe the front-end expansion for a "raise;" to
      --  see that happening. We get a local occurrence and a direct call to
      --  Save_Occurrence without the intermediate init-proc call.

      if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then
         return;
      end if;

      --  Allocate what will be the Private_Data block for the exception
      --  to be propagated.

      GCC_Exception := new GNAT_GCC_Exception;

      --  If the Top of the occurrence stack is not currently used for an
      --  active exception (the stack is empty) we just need to setup the
      --  Private_Data pointer.

      --  Otherwise, we also need to shift the contents of the Top of the
      --  stack in a freshly allocated entry and link everything together.

      if Top.Private_Data /= System.Null_Address then
         Next := new Exception_Occurrence;
         Save_Occurrence_And_Private (Next.all, Top.all);

         GCC_Exception.Next_Exception := Next;
         Top.Private_Data := GCC_Exception.all'Address;
      end if;

      Top.Private_Data := GCC_Exception.all'Address;

      Set_Setup_And_Not_Propagated (Top);
   end Setup_Exception;

   -------------------
   -- Begin_Handler --
   -------------------

   procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
      pragma Unreferenced (GCC_Exception);

   begin
      --  Every necessary operation related to the occurrence stack has
      --  already been performed by Propagate_Exception. This hook remains for
      --  potential future necessity in optimizing the overall scheme, as well
      --  a useful debugging tool.

      null;
   end Begin_Handler;

   -----------------
   -- End_Handler --
   -----------------

   procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
      Removed : Boolean;
   begin
      Removed := Remove (Get_Current_Excep.all, GCC_Exception);
      pragma Assert (Removed);
   end End_Handler;

   -------------------------
   -- Propagate_Exception --
   -------------------------

   --  Build an object suitable for the libgcc processing and call
   --  Unwind_RaiseException to actually throw, taking care of handling
   --  the two phase scheme it implements.

   procedure Propagate_Exception
     (E                   : Exception_Id;
      From_Signal_Handler : Boolean)
   is
      pragma Inspection_Point (E);
      pragma Unreferenced (From_Signal_Handler);

      Excep         : constant EOA := Get_Current_Excep.all;
      GCC_Exception : GNAT_GCC_Exception_Access;

   begin
      pragma Assert (Excep.Private_Data /= System.Null_Address);

      --  Retrieve the Private_Data for this occurrence and set the useful
      --  flags for the personality routine, which will be called for each
      --  frame via Unwind_RaiseException below.

      GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);

      Clear_Setup_And_Not_Propagated (Excep);

      GCC_Exception.Id := Excep.Id;
      GCC_Exception.N_Cleanups_To_Trigger := 0;

      --  Compute the backtrace for this occurrence if the corresponding
      --  binder option has been set. Call_Chain takes care of the reraise
      --  case.

      --  ??? Using Call_Chain here means we are going to walk up the stack
      --  once only for backtracing purposes before doing it again for the
      --  propagation per se.

      --  The first inspection is much lighter, though, as it only requires
      --  partial unwinding of each frame. Additionally, although we could use
      --  the personality routine to record the addresses while propagating,
      --  this method has two drawbacks:

      --  1) the trace is incomplete if the exception is handled since we
      --  don't walk past the frame with the handler,

      --    and

      --  2) we would miss the frames for which our personality routine is not
      --  called, e.g. if C or C++ calls are on the way.

      Call_Chain (Excep);

      --  Perform a standard raise first. If a regular handler is found, it
      --  will be entered after all the intermediate cleanups have run. If
      --  there is no regular handler, control will get back to after the
      --  call, with N_Cleanups_To_Trigger set to the number of frames with
      --  cleanups found on the way up, and none of these already run.

      Unwind_RaiseException (GCC_Exception);

      --  If we get here we know the exception is not handled, as otherwise
      --  Unwind_RaiseException arranges for the handler to be entered. Take
      --  the necessary steps to enable the debugger to gain control while the
      --  stack is still intact.

      Notify_Unhandled_Exception;

      --  Now, if cleanups have been found, run a forced unwind to trigger
      --  them. Control should not resume there, as the unwinding hook calls
      --  Unhandled_Exception_Terminate as soon as the last cleanup has been
      --  triggered.

      if GCC_Exception.N_Cleanups_To_Trigger /= 0 then
         Unwind_ForcedUnwind (GCC_Exception,
                              CleanupUnwind_Handler'Address,
                              System.Null_Address);
      end if;

      --  We get here when there is no handler or cleanup to be run at all.
      --  The debugger has been notified before the second step above.

      Unhandled_Exception_Terminate;
   end Propagate_Exception;

   ---------------------------
   -- Adjust_N_Cleanups_For --
   ---------------------------

   procedure Adjust_N_Cleanups_For
     (GNAT_Exception : GNAT_GCC_Exception_Access;
      Adjustment     : Integer)
   is
   begin
      GNAT_Exception.N_Cleanups_To_Trigger :=
        GNAT_Exception.N_Cleanups_To_Trigger + Adjustment;
   end Adjust_N_Cleanups_For;

   -------------
   -- EID_For --
   -------------

   function EID_For
     (GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id
   is
   begin
      return GNAT_Exception.Id;
   end EID_For;

   ---------------------
   -- Import_Code_For --
   ---------------------

   function Import_Code_For
     (E : SSL.Exception_Data_Ptr) return Exception_Code
   is
   begin
      return E.all.Import_Code;
   end Import_Code_For;

   --------------------------
   -- Is_Handled_By_Others --
   --------------------------

   function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
   begin
      return not E.all.Not_Handled_By_Others;
   end Is_Handled_By_Others;

   ------------------
   -- Language_For --
   ------------------

   function Language_For (E : SSL.Exception_Data_Ptr) return Character is
   begin
      return E.all.Lang;
   end Language_For;

   -----------
   -- Notes --
   -----------

   --  The current model implemented for the stack of occurrences is a
   --  simplification of previous attempts, which all proved to be flawed or
   --  would have needed significant additional circuitry to be made to work
   --  correctly.

   --  We now represent every propagation by a new entry on the stack, which
   --  means that an exception occurrence may appear more than once (e.g. when
   --  it is reraised during the course of its own handler).

   --  This may seem overcostly compared to the C++ model as implemented in
   --  the g++ v3 libstd. This is actually understandable when one considers
   --  the extra variations of possible run-time configurations induced by the
   --  freedom offered by the Save_Occurrence/Reraise_Occurrence public
   --  interface.

   --  The basic point is that arranging for an occurrence to always appear at
   --  most once on the stack requires a way to determine if a given occurrence
   --  is already there, which is not as easy as it might seem.

   --  An attempt was made to use the Private_Data pointer for this purpose.
   --  It did not work because:

   --  1) The Private_Data has to be saved by Save_Occurrence to be usable
   --     as a key in case of a later reraise,

   --  2) There is no easy way to synchronize End_Handler for an occurrence
   --     and the data attached to potential copies, so these copies may end
   --     up pointing to stale data. Moreover ...

   --  3) The same address may be reused for different occurrences, which
   --     defeats the idea of using it as a key.

   --  The example below illustrates:

   --  Saved_CE : Exception_Occurrence;

   --  begin
   --    raise Constraint_Error;
   --  exception
   --    when CE: others =>
   --      Save_Occurrence (Saved_CE, CE);      <= Saved_CE.PDA = CE.PDA
   --  end;

   --                                           <= Saved_CE.PDA is stale (!)

   --  begin
   --    raise Program_Error;                   <= Saved_CE.PDA = PE.PDA (!!)
   --  exception
   --    when others =>
   --      Reraise_Occurrence (Saved_CE);
   --  end;

   --  Not releasing the Private_Data via End_Handler could be an option,
   --  but making this to work while still avoiding memory leaks is far
   --  from trivial.

   --  The current scheme has the advantage of being simple, and induces
   --  extra costs only in reraise cases which is acceptable.

end Exception_Propagation;