gcc/ada/a-exexpr-gcc.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --  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 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2006, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is the version using the GCC EH mechanism
  35
  36 with Ada.Unchecked_Conversion;
  37 with Ada.Unchecked_Deallocation;
  38
  39 with System.Storage_Elements;  use System.Storage_Elements;
  40
  41 separate (Ada.Exceptions)
  42 package body Exception_Propagation is
  43
  44    ------------------------------------------------
  45    -- Entities to interface with the GCC runtime --
  46    ------------------------------------------------
  47
  48    --  These come from "C++ ABI for Itanium: Exception handling", which is
  49    --  the reference for GCC. They are used only when we are relying on
  50    --  back-end tables for exception propagation, which in turn is currenly
  51    --  only the case for Zero_Cost_Exceptions in GNAT5.
  52
  53    --  Return codes from the GCC runtime functions used to propagate
  54    --  an exception.
  55
  56    type Unwind_Reason_Code is
  57      (URC_NO_REASON,
  58       URC_FOREIGN_EXCEPTION_CAUGHT,
  59       URC_PHASE2_ERROR,
  60       URC_PHASE1_ERROR,
  61       URC_NORMAL_STOP,
  62       URC_END_OF_STACK,
  63       URC_HANDLER_FOUND,
  64       URC_INSTALL_CONTEXT,
  65       URC_CONTINUE_UNWIND);
  66
  67    pragma Unreferenced
  68      (URC_FOREIGN_EXCEPTION_CAUGHT,
  69       URC_PHASE2_ERROR,
  70       URC_PHASE1_ERROR,
  71       URC_NORMAL_STOP,
  72       URC_END_OF_STACK,
  73       URC_HANDLER_FOUND,
  74       URC_INSTALL_CONTEXT,
  75       URC_CONTINUE_UNWIND);
  76
  77    pragma Convention (C, Unwind_Reason_Code);
  78
  79    --  Phase identifiers
  80
  81    type Unwind_Action is
  82      (UA_SEARCH_PHASE,
  83       UA_CLEANUP_PHASE,
  84       UA_HANDLER_FRAME,
  85       UA_FORCE_UNWIND);
  86
  87    for Unwind_Action use
  88       (UA_SEARCH_PHASE  => 1,
  89        UA_CLEANUP_PHASE => 2,
  90        UA_HANDLER_FRAME => 4,
  91        UA_FORCE_UNWIND  => 8);
  92
  93    pragma Convention (C, Unwind_Action);
  94
  95    --  Mandatory common header for any exception object handled by the
  96    --  GCC unwinding runtime.
  97
  98    type Exception_Class is mod 2 ** 64;
  99
 100    GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
 101    --  "GNU-Ada\0"
 102
 103    type Unwind_Word is mod 2 ** System.Word_Size;
 104    for Unwind_Word'Size use System.Word_Size;
 105    --  Map the corresponding C type used in Unwind_Exception below
 106
 107    type Unwind_Exception is record
 108       Class    : Exception_Class := GNAT_Exception_Class;
 109       Cleanup  : System.Address  := System.Null_Address;
 110       Private1 : Unwind_Word;
 111       Private2 : Unwind_Word;
 112    end record;
 113    --  Map the GCC struct used for exception handling
 114
 115    for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
 116    --  The C++ ABI mandates the common exception header to be at least
 117    --  doubleword aligned, and the libGCC implementation actually makes it
 118    --  maximally aligned (see unwind.h). See additional comments on the
 119    --  alignment below.
 120
 121    --------------------------------------------------------------
 122    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
 123    --------------------------------------------------------------
 124
 125    --  A GNAT exception object to be dealt with by the personality routine
 126    --  called by the GCC unwinding runtime.
 127
 128    type GNAT_GCC_Exception is record
 129       Header : Unwind_Exception;
 130       --  ABI Exception header first
 131
 132       Id : Exception_Id;
 133       --  GNAT Exception identifier.  This is filled by Propagate_Exception
 134       --  and then used by the personality routine to determine if the context
 135       --  it examines contains a handler for the exception beeing propagated.
 136
 137       N_Cleanups_To_Trigger : Integer;
 138       --  Number of cleanup only frames encountered in SEARCH phase.  This is
 139       --  initialized to 0 by Propagate_Exception and maintained by the
 140       --  personality routine to control a forced unwinding phase triggering
 141       --  all the cleanups before calling Unhandled_Exception_Terminate when
 142       --  an exception is not handled.
 143
 144       Next_Exception : EOA;
 145       --  Used to create a linked list of exception occurrences
 146    end record;
 147
 148    pragma Convention (C, GNAT_GCC_Exception);
 149
 150    --  There is a subtle issue with the common header alignment, since the C
 151    --  version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
 152    --  Standard'Maximum_Alignment, and those two values don't quite represent
 153    --  the same concepts and so may be decoupled someday. One typical reason
 154    --  is that BIGGEST_ALIGNMENT may be larger than what the underlying system
 155    --  allocator guarantees, and there are extra costs involved in allocating
 156    --  objects aligned to such factors.
 157
 158    --  To deal with the potential alignment differences between the C and Ada
 159    --  representations, the Ada part of the whole structure is only accessed
 160    --  by the personality routine through the accessors declared below.  Ada
 161    --  specific fields are thus always accessed through consistent layout, and
 162    --  we expect the actual alignment to always be large enough to avoid traps
 163    --  from the C accesses to the common header. Besides, accessors aleviate
 164    --  the need for a C struct whole conterpart, both painful and errorprone
 165    --  to maintain anyway.
 166
 167    type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
 168
 169    function To_GNAT_GCC_Exception is new
 170      Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);
 171
 172    procedure Free is new Unchecked_Deallocation
 173      (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 174
 175    procedure Free is new Unchecked_Deallocation
 176      (Exception_Occurrence, EOA);
 177
 178    function CleanupUnwind_Handler
 179      (UW_Version   : Integer;
 180       UW_Phases    : Unwind_Action;
 181       UW_Eclass    : Exception_Class;
 182       UW_Exception : not null access GNAT_GCC_Exception;
 183       UW_Context   : System.Address;
 184       UW_Argument  : System.Address) return Unwind_Reason_Code;
 185    --  Hook called at each step of the forced unwinding we perform to
 186    --  trigger cleanups found during the propagation of an unhandled
 187    --  exception.
 188
 189    --  GCC runtime functions used. These are C non-void functions, actually,
 190    --  but we ignore the return values. See raise.c as to why we are using
 191    --  __gnat stubs for these.
 192
 193    procedure Unwind_RaiseException
 194      (UW_Exception : not null access GNAT_GCC_Exception);
 195    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 196
 197    procedure Unwind_ForcedUnwind
 198      (UW_Exception : not null access GNAT_GCC_Exception;
 199       UW_Handler   : System.Address;
 200       UW_Argument  : System.Address);
 201    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 202
 203    ------------------------------------------------------------------
 204    -- Occurrence Stack Management Facilities for the GCC-EH Scheme --
 205    ------------------------------------------------------------------
 206
 207    function Remove
 208      (Top   : EOA;
 209       Excep : GNAT_GCC_Exception_Access) return Boolean;
 210    --  Remove Excep from the stack starting at Top.
 211    --  Return True if Excep was found and removed, false otherwise.
 212
 213    --  Hooks called when entering/leaving an exception handler for a given
 214    --  occurrence, aimed at handling the stack of active occurrences. The
 215    --  calls are generated by gigi in tree_transform/N_Exception_Handler.
 216
 217    procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
 218    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 219
 220    procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
 221    pragma Export (C, End_Handler, "__gnat_end_handler");
 222
 223    Setup_Key : constant := 16#DEAD#;
 224    --  To handle the case of a task "transferring" an exception occurrence to
 225    --  another task, for instance via Exceptional_Complete_Rendezvous, we need
 226    --  to be able to identify occurrences which have been Setup and not yet
 227    --  Propagated. We hijack one of the common header fields for that purpose,
 228    --  setting it to a special key value during the setup process, clearing it
 229    --  at the very beginning of the propagation phase, and expecting it never
 230    --  to be reset to the special value later on. A 16-bit value is used rather
 231    --  than a 32-bit value for static compatibility with 16-bit targets such as
 232    --  AAMP (where type Unwind_Word will be 16 bits).
 233
 234    function Is_Setup_And_Not_Propagated (E : EOA) return Boolean;
 235
 236    procedure Set_Setup_And_Not_Propagated (E : EOA);
 237    procedure Clear_Setup_And_Not_Propagated (E : EOA);
 238
 239    procedure Save_Occurrence_And_Private
 240      (Target : out Exception_Occurrence;
 241       Source : Exception_Occurrence);
 242    --  Copy all the components of Source to Target as well as the
 243    --  Private_Data pointer.
 244
 245    ------------------------------------------------------------
 246    -- Accessors to basic components of a GNAT exception data --
 247    ------------------------------------------------------------
 248
 249    --  As of today, these are only used by the C implementation of the
 250    --  GCC propagation personality routine to avoid having to rely on a C
 251    --  counterpart of the whole exception_data structure, which is both
 252    --  painful and error prone. These subprograms could be moved to a
 253    --  more widely visible location if need be.
 254
 255    function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
 256    pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
 257
 258    function Language_For (E : Exception_Data_Ptr) return Character;
 259    pragma Export (C, Language_For, "__gnat_language_for");
 260
 261    function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
 262    pragma Export (C, Import_Code_For, "__gnat_import_code_for");
 263
 264    function EID_For (GNAT_Exception : GNAT_GCC_Exception_Access)
 265      return Exception_Id;
 266    pragma Export (C, EID_For, "__gnat_eid_for");
 267
 268    procedure Adjust_N_Cleanups_For
 269      (GNAT_Exception : GNAT_GCC_Exception_Access;
 270       Adjustment     : Integer);
 271    pragma Export (C, Adjust_N_Cleanups_For, "__gnat_adjust_n_cleanups_for");
 272
 273    ---------------------------------------------------------------------------
 274    -- Objects to materialize "others" and "all others" in the GCC EH tables --
 275    ---------------------------------------------------------------------------
 276
 277    --  Currently, these only have their address taken and compared so there is
 278    --  no real point having whole exception data blocks allocated. In any case
 279    --  the types should match what gigi and the personality routine expect.
 280    --  The initial value is an arbitrary value that will not exceed the range
 281    --  of Integer on 16-bit targets (such as AAMP).
 282
 283    Others_Value : constant Integer := 16#7FFF#;
 284    pragma Export (C, Others_Value, "__gnat_others_value");
 285
 286    All_Others_Value : constant Integer := 16#7FFF#;
 287    pragma Export (C, All_Others_Value, "__gnat_all_others_value");
 288
 289    ------------
 290    -- Remove --
 291    ------------
 292
 293    function Remove
 294      (Top   : EOA;
 295       Excep : GNAT_GCC_Exception_Access) return Boolean
 296    is
 297       Prev          : GNAT_GCC_Exception_Access := null;
 298       Iter          : EOA := Top;
 299       GCC_Exception : GNAT_GCC_Exception_Access;
 300
 301    begin
 302       --  Pop stack
 303
 304       loop
 305          pragma Assert (Iter.Private_Data /= System.Null_Address);
 306
 307          GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);
 308
 309          if GCC_Exception = Excep then
 310             if Prev = null then
 311
 312                --  Special case for the top of the stack: shift the contents
 313                --  of the next item to the top, since top is at a fixed
 314                --  location and can't be changed.
 315
 316                Iter := GCC_Exception.Next_Exception;
 317
 318                if Iter = null then
 319
 320                   --  Stack is now empty
 321
 322                   Top.Private_Data := System.Null_Address;
 323
 324                else
 325                   Save_Occurrence_And_Private (Top.all, Iter.all);
 326                   Free (Iter);
 327                end if;
 328
 329             else
 330                Prev.Next_Exception := GCC_Exception.Next_Exception;
 331                Free (Iter);
 332             end if;
 333
 334             Free (GCC_Exception);
 335
 336             return True;
 337          end if;
 338
 339          exit when GCC_Exception.Next_Exception = null;
 340
 341          Prev := GCC_Exception;
 342          Iter := GCC_Exception.Next_Exception;
 343       end loop;
 344
 345       return False;
 346    end Remove;
 347
 348    ---------------------------
 349    -- CleanupUnwind_Handler --
 350    ---------------------------
 351
 352    function CleanupUnwind_Handler
 353      (UW_Version   : Integer;
 354       UW_Phases    : Unwind_Action;
 355       UW_Eclass    : Exception_Class;
 356       UW_Exception : not null access GNAT_GCC_Exception;
 357       UW_Context   : System.Address;
 358       UW_Argument  : System.Address) return Unwind_Reason_Code
 359    is
 360       pragma Unreferenced
 361         (UW_Version, UW_Phases, UW_Eclass, UW_Context, UW_Argument);
 362
 363    begin
 364       --  Terminate as soon as we know there is nothing more to run. The
 365       --  count is maintained by the personality routine.
 366
 367       if UW_Exception.N_Cleanups_To_Trigger = 0 then
 368          Unhandled_Exception_Terminate;
 369       end if;
 370
 371       --  We know there is at least one cleanup further up. Return so that it
 372       --  is searched and entered, after which Unwind_Resume will be called
 373       --  and this hook will gain control (with an updated count) again.
 374
 375       return URC_NO_REASON;
 376    end CleanupUnwind_Handler;
 377
 378    ---------------------------------
 379    -- Is_Setup_And_Not_Propagated --
 380    ---------------------------------
 381
 382    function Is_Setup_And_Not_Propagated (E : EOA) return Boolean is
 383       GCC_E : constant GNAT_GCC_Exception_Access :=
 384                 To_GNAT_GCC_Exception (E.Private_Data);
 385    begin
 386       return GCC_E /= null and then GCC_E.Header.Private1 = Setup_Key;
 387    end Is_Setup_And_Not_Propagated;
 388
 389    ------------------------------------
 390    -- Clear_Setup_And_Not_Propagated --
 391    ------------------------------------
 392
 393    procedure Clear_Setup_And_Not_Propagated (E : EOA) is
 394       GCC_E : constant GNAT_GCC_Exception_Access :=
 395                 To_GNAT_GCC_Exception (E.Private_Data);
 396    begin
 397       pragma Assert (GCC_E /= null);
 398       GCC_E.Header.Private1 := 0;
 399    end Clear_Setup_And_Not_Propagated;
 400
 401    ----------------------------------
 402    -- Set_Setup_And_Not_Propagated --
 403    ----------------------------------
 404
 405    procedure Set_Setup_And_Not_Propagated (E : EOA) is
 406       GCC_E : constant GNAT_GCC_Exception_Access :=
 407                 To_GNAT_GCC_Exception (E.Private_Data);
 408    begin
 409       pragma Assert (GCC_E /= null);
 410       GCC_E.Header.Private1 := Setup_Key;
 411    end Set_Setup_And_Not_Propagated;
 412
 413    --------------------------------
 414    -- Save_Occurrence_And_Private --
 415    --------------------------------
 416
 417    procedure Save_Occurrence_And_Private
 418      (Target : out Exception_Occurrence;
 419       Source : Exception_Occurrence)
 420    is
 421    begin
 422       Save_Occurrence_No_Private (Target, Source);
 423       Target.Private_Data := Source.Private_Data;
 424    end Save_Occurrence_And_Private;
 425
 426    ---------------------
 427    -- Setup_Exception --
 428    ---------------------
 429
 430    --  In the GCC-EH implementation of the propagation scheme, this
 431    --  subprogram should be understood as: Setup the exception occurrence
 432    --  stack headed at Current for a forthcoming raise of Excep.
 433
 434    procedure Setup_Exception
 435      (Excep    : EOA;
 436       Current  : EOA;
 437       Reraised : Boolean := False)
 438    is
 439       Top           : constant EOA := Current;
 440       Next          : EOA;
 441       GCC_Exception : GNAT_GCC_Exception_Access;
 442
 443    begin
 444       --  The exception Excep is soon to be propagated, and the
 445       --  storage used for that will be the occurrence statically allocated
 446       --  for the current thread. This storage might currently be used for a
 447       --  still active occurrence, so we need to push it on the thread's
 448       --  occurrence stack (headed at that static occurrence) before it gets
 449       --  clobbered.
 450
 451       --  What we do here is to trigger this push when need be, and allocate a
 452       --  Private_Data block for the forthcoming Propagation.
 453
 454       --  Some tasking rendez-vous attempts lead to an occurrence transfer
 455       --  from the server to the client (see Exceptional_Complete_Rendezvous).
 456       --  In those cases Setup is called twice for the very same occurrence
 457       --  before it gets propagated: once from the server, because this is
 458       --  where the occurrence contents is elaborated and known, and then
 459       --  once from the client when it detects the case and actually raises
 460       --  the exception in its own context.
 461
 462       --  The Is_Setup_And_Not_Propagated predicate tells us when we are in
 463       --  the second call to Setup for a Transferred occurrence, and there is
 464       --  nothing to be done here in this situation. This predicate cannot be
 465       --  True if we are dealing with a Reraise, and we may even be called
 466       --  with a raw uninitialized Excep occurrence in this case so we should
 467       --  not check anyway. Observe the front-end expansion for a "raise;" to
 468       --  see that happening. We get a local occurrence and a direct call to
 469       --  Save_Occurrence without the intermediate init-proc call.
 470
 471       if not Reraised and then Is_Setup_And_Not_Propagated (Excep) then
 472          return;
 473       end if;
 474
 475       --  Allocate what will be the Private_Data block for the exception
 476       --  to be propagated.
 477
 478       GCC_Exception := new GNAT_GCC_Exception;
 479
 480       --  If the Top of the occurrence stack is not currently used for an
 481       --  active exception (the stack is empty) we just need to setup the
 482       --  Private_Data pointer.
 483
 484       --  Otherwise, we also need to shift the contents of the Top of the
 485       --  stack in a freshly allocated entry and link everything together.
 486
 487       if Top.Private_Data /= System.Null_Address then
 488          Next := new Exception_Occurrence;
 489          Save_Occurrence_And_Private (Next.all, Top.all);
 490
 491          GCC_Exception.Next_Exception := Next;
 492          Top.Private_Data := GCC_Exception.all'Address;
 493       end if;
 494
 495       Top.Private_Data := GCC_Exception.all'Address;
 496
 497       Set_Setup_And_Not_Propagated (Top);
 498    end Setup_Exception;
 499
 500    -------------------
 501    -- Begin_Handler --
 502    -------------------
 503
 504    procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
 505       pragma Unreferenced (GCC_Exception);
 506
 507    begin
 508       --  Every necessary operation related to the occurrence stack has
 509       --  already been performed by Propagate_Exception. This hook remains for
 510       --  potential future necessity in optimizing the overall scheme, as well
 511       --  a useful debugging tool.
 512
 513       null;
 514    end Begin_Handler;
 515
 516    -----------------
 517    -- End_Handler --
 518    -----------------
 519
 520    procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
 521       Removed : Boolean;
 522    begin
 523       Removed := Remove (Get_Current_Excep.all, GCC_Exception);
 524       pragma Assert (Removed);
 525    end End_Handler;
 526
 527    -------------------------
 528    -- Propagate_Exception --
 529    -------------------------
 530
 531    --  Build an object suitable for the libgcc processing and call
 532    --  Unwind_RaiseException to actually throw, taking care of handling
 533    --  the two phase scheme it implements.
 534
 535    procedure Propagate_Exception
 536      (E                   : Exception_Id;
 537       From_Signal_Handler : Boolean)
 538    is
 539       pragma Inspection_Point (E);
 540       pragma Unreferenced (From_Signal_Handler);
 541
 542       Excep         : constant EOA := Get_Current_Excep.all;
 543       GCC_Exception : GNAT_GCC_Exception_Access;
 544
 545    begin
 546       pragma Assert (Excep.Private_Data /= System.Null_Address);
 547
 548       --  Retrieve the Private_Data for this occurrence and set the useful
 549       --  flags for the personality routine, which will be called for each
 550       --  frame via Unwind_RaiseException below.
 551
 552       GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
 553
 554       Clear_Setup_And_Not_Propagated (Excep);
 555
 556       GCC_Exception.Id := Excep.Id;
 557       GCC_Exception.N_Cleanups_To_Trigger := 0;
 558
 559       --  Compute the backtrace for this occurrence if the corresponding
 560       --  binder option has been set. Call_Chain takes care of the reraise
 561       --  case.
 562
 563       --  ??? Using Call_Chain here means we are going to walk up the stack
 564       --  once only for backtracing purposes before doing it again for the
 565       --  propagation per se.
 566
 567       --  The first inspection is much lighter, though, as it only requires
 568       --  partial unwinding of each frame. Additionally, although we could use
 569       --  the personality routine to record the addresses while propagating,
 570       --  this method has two drawbacks:
 571
 572       --  1) the trace is incomplete if the exception is handled since we
 573       --  don't walk past the frame with the handler,
 574
 575       --    and
 576
 577       --  2) we would miss the frames for which our personality routine is not
 578       --  called, e.g. if C or C++ calls are on the way.
 579
 580       Call_Chain (Excep);
 581
 582       --  Perform a standard raise first. If a regular handler is found, it
 583       --  will be entered after all the intermediate cleanups have run. If
 584       --  there is no regular handler, control will get back to after the
 585       --  call, with N_Cleanups_To_Trigger set to the number of frames with
 586       --  cleanups found on the way up, and none of these already run.
 587
 588       Unwind_RaiseException (GCC_Exception);
 589
 590       --  If we get here we know the exception is not handled, as otherwise
 591       --  Unwind_RaiseException arranges for the handler to be entered. Take
 592       --  the necessary steps to enable the debugger to gain control while the
 593       --  stack is still intact.
 594
 595       Notify_Unhandled_Exception;
 596
 597       --  Now, if cleanups have been found, run a forced unwind to trigger
 598       --  them. Control should not resume there, as the unwinding hook calls
 599       --  Unhandled_Exception_Terminate as soon as the last cleanup has been
 600       --  triggered.
 601
 602       if GCC_Exception.N_Cleanups_To_Trigger /= 0 then
 603          Unwind_ForcedUnwind (GCC_Exception,
 604                               CleanupUnwind_Handler'Address,
 605                               System.Null_Address);
 606       end if;
 607
 608       --  We get here when there is no handler or cleanup to be run at all.
 609       --  The debugger has been notified before the second step above.
 610
 611       Unhandled_Exception_Terminate;
 612    end Propagate_Exception;
 613
 614    ---------------------------
 615    -- Adjust_N_Cleanups_For --
 616    ---------------------------
 617
 618    procedure Adjust_N_Cleanups_For
 619      (GNAT_Exception : GNAT_GCC_Exception_Access;
 620       Adjustment     : Integer)
 621    is
 622    begin
 623       GNAT_Exception.N_Cleanups_To_Trigger :=
 624         GNAT_Exception.N_Cleanups_To_Trigger + Adjustment;
 625    end Adjust_N_Cleanups_For;
 626
 627    -------------
 628    -- EID_For --
 629    -------------
 630
 631    function EID_For
 632      (GNAT_Exception : GNAT_GCC_Exception_Access) return Exception_Id
 633    is
 634    begin
 635       return GNAT_Exception.Id;
 636    end EID_For;
 637
 638    ---------------------
 639    -- Import_Code_For --
 640    ---------------------
 641
 642    function Import_Code_For
 643      (E : SSL.Exception_Data_Ptr) return Exception_Code
 644    is
 645    begin
 646       return E.all.Import_Code;
 647    end Import_Code_For;
 648
 649    --------------------------
 650    -- Is_Handled_By_Others --
 651    --------------------------
 652
 653    function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
 654    begin
 655       return not E.all.Not_Handled_By_Others;
 656    end Is_Handled_By_Others;
 657
 658    ------------------
 659    -- Language_For --
 660    ------------------
 661
 662    function Language_For (E : SSL.Exception_Data_Ptr) return Character is
 663    begin
 664       return E.all.Lang;
 665    end Language_For;
 666
 667    -----------
 668    -- Notes --
 669    -----------
 670
 671    --  The current model implemented for the stack of occurrences is a
 672    --  simplification of previous attempts, which all prooved to be flawed or
 673    --  would have needed significant additional circuitry to be made to work
 674    --  correctly.
 675
 676    --  We now represent every propagation by a new entry on the stack, which
 677    --  means that an exception occurrence may appear more than once (e.g. when
 678    --  it is reraised during the course of its own handler).
 679
 680    --  This may seem overcostly compared to the C++ model as implemented in
 681    --  the g++ v3 libstd. This is actually understandable when one considers
 682    --  the extra variations of possible run-time configurations induced by the
 683    --  freedom offered by the Save_Occurrence/Reraise_Occurrence public
 684    --  interface.
 685
 686    --  The basic point is that arranging for an occurrence to always appear at
 687    --  most once on the stack requires a way to determine if a given occurence
 688    --  is already there, which is not as easy as it might seem.
 689
 690    --  An attempt was made to use the Private_Data pointer for this purpose.
 691    --  It did not work because:
 692
 693    --  1) The Private_Data has to be saved by Save_Occurrence to be usable
 694    --     as a key in case of a later reraise,
 695
 696    --  2) There is no easy way to synchronize End_Handler for an occurrence
 697    --     and the data attached to potential copies, so these copies may end
 698    --     up pointing to stale data. Moreover ...
 699
 700    --  3) The same address may be reused for different occurrences, which
 701    --     defeats the idea of using it as a key.
 702
 703    --  The example below illustrates:
 704
 705    --  Saved_CE : Exception_Occurrence;
 706
 707    --  begin
 708    --    raise Constraint_Error;
 709    --  exception
 710    --    when CE: others =>
 711    --      Save_Occurrence (Saved_CE, CE);      <= Saved_CE.PDA = CE.PDA
 712    --  end;
 713
 714    --                                           <= Saved_CE.PDA is stale (!)
 715
 716    --  begin
 717    --    raise Program_Error;                   <= Saved_CE.PDA = PE.PDA (!!)
 718    --  exception
 719    --    when others =>
 720    --      Reraise_Occurrence (Saved_CE);
 721    --  end;
 722
 723    --  Not releasing the Private_Data via End_Handler could be an option,
 724    --  but making this to work while still avoiding memory leaks is far
 725    --  from trivial.
 726
 727    --  The current scheme has the advantage of beeing simple, and induces
 728    --  extra costs only in reraise cases which is acceptable.
 729
 730 end Exception_Propagation;