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-2012, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This is the version using the GCC EH mechanism
  33
  34 with Ada.Unchecked_Conversion;
  35 with Ada.Unchecked_Deallocation;
  36
  37 with System.Storage_Elements;  use System.Storage_Elements;
  38
  39 separate (Ada.Exceptions)
  40 package body Exception_Propagation is
  41
  42    use Exception_Traces;
  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.
  50
  51    --  Return codes from the GCC runtime functions used to propagate
  52    --  an exception.
  53
  54    type Unwind_Reason_Code is
  55      (URC_NO_REASON,
  56       URC_FOREIGN_EXCEPTION_CAUGHT,
  57       URC_PHASE2_ERROR,
  58       URC_PHASE1_ERROR,
  59       URC_NORMAL_STOP,
  60       URC_END_OF_STACK,
  61       URC_HANDLER_FOUND,
  62       URC_INSTALL_CONTEXT,
  63       URC_CONTINUE_UNWIND);
  64
  65    pragma Unreferenced
  66      (URC_NO_REASON,
  67       URC_FOREIGN_EXCEPTION_CAUGHT,
  68       URC_PHASE2_ERROR,
  69       URC_PHASE1_ERROR,
  70       URC_NORMAL_STOP,
  71       URC_END_OF_STACK,
  72       URC_HANDLER_FOUND,
  73       URC_INSTALL_CONTEXT,
  74       URC_CONTINUE_UNWIND);
  75
  76    pragma Convention (C, Unwind_Reason_Code);
  77
  78    --  Phase identifiers
  79
  80    type Unwind_Action is new Integer;
  81    pragma Convention (C, Unwind_Action);
  82
  83    UA_SEARCH_PHASE  : constant Unwind_Action := 1;
  84    UA_CLEANUP_PHASE : constant Unwind_Action := 2;
  85    UA_HANDLER_FRAME : constant Unwind_Action := 4;
  86    UA_FORCE_UNWIND  : constant Unwind_Action := 8;
  87    UA_END_OF_STACK  : constant Unwind_Action := 16;  --  GCC extension
  88
  89    pragma Unreferenced
  90      (UA_SEARCH_PHASE,
  91       UA_CLEANUP_PHASE,
  92       UA_HANDLER_FRAME,
  93       UA_FORCE_UNWIND,
  94       UA_END_OF_STACK);
  95
  96    --  Mandatory common header for any exception object handled by the
  97    --  GCC unwinding runtime.
  98
  99    type Exception_Class is mod 2 ** 64;
 100
 101    GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
 102    --  "GNU-Ada\0"
 103
 104    type Unwind_Word is mod 2 ** System.Word_Size;
 105    for Unwind_Word'Size use System.Word_Size;
 106    --  Map the corresponding C type used in Unwind_Exception below
 107
 108    type Unwind_Exception is record
 109       Class    : Exception_Class;
 110       Cleanup  : System.Address;
 111       Private1 : Unwind_Word;
 112       Private2 : Unwind_Word;
 113
 114       --  Usual exception structure has only two private fields, but the SEH
 115       --  one has six. To avoid making this file more complex, we use six
 116       --  fields on all platforms, wasting a few bytes on some.
 117
 118       Private3 : Unwind_Word;
 119       Private4 : Unwind_Word;
 120       Private5 : Unwind_Word;
 121       Private6 : Unwind_Word;
 122    end record;
 123    pragma Convention (C, Unwind_Exception);
 124    --  Map the GCC struct used for exception handling
 125
 126    for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
 127    --  The C++ ABI mandates the common exception header to be at least
 128    --  doubleword aligned, and the libGCC implementation actually makes it
 129    --  maximally aligned (see unwind.h). See additional comments on the
 130    --  alignment below.
 131
 132    type GCC_Exception_Access is access all Unwind_Exception;
 133    --  Pointer to a GCC exception. Do not use convention C as on VMS this
 134    --  would imply the use of 32-bits pointers.
 135
 136    procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
 137    pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
 138    --  Procedure to free any GCC exception
 139
 140    Foreign_Exception : aliased System.Standard_Library.Exception_Data;
 141    pragma Import (Ada, Foreign_Exception,
 142                   "system__exceptions__foreign_exception");
 143    --  Id for foreign exceptions
 144
 145    --------------------------------------------------------------
 146    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
 147    --------------------------------------------------------------
 148
 149    --  A GNAT exception object to be dealt with by the personality routine
 150    --  called by the GCC unwinding runtime.
 151
 152    type GNAT_GCC_Exception is record
 153       Header : Unwind_Exception;
 154       --  ABI Exception header first
 155
 156       Occurrence : aliased Exception_Occurrence;
 157       --  The Ada occurrence
 158    end record;
 159
 160    pragma Convention (C, GNAT_GCC_Exception);
 161
 162    --  There is a subtle issue with the common header alignment, since the C
 163    --  version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
 164    --  Standard'Maximum_Alignment, and those two values don't quite represent
 165    --  the same concepts and so may be decoupled someday. One typical reason
 166    --  is that BIGGEST_ALIGNMENT may be larger than what the underlying system
 167    --  allocator guarantees, and there are extra costs involved in allocating
 168    --  objects aligned to such factors.
 169
 170    --  To deal with the potential alignment differences between the C and Ada
 171    --  representations, the Ada part of the whole structure is only accessed
 172    --  by the personality routine through the accessors declared below.  Ada
 173    --  specific fields are thus always accessed through consistent layout, and
 174    --  we expect the actual alignment to always be large enough to avoid traps
 175    --  from the C accesses to the common header. Besides, accessors alleviate
 176    --  the need for a C struct whole counterpart, both painful and error-prone
 177    --  to maintain anyway.
 178
 179    type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
 180
 181    function To_GCC_Exception is new
 182      Unchecked_Conversion (System.Address, GCC_Exception_Access);
 183
 184    function To_GNAT_GCC_Exception is new
 185      Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
 186
 187    procedure GNAT_GCC_Exception_Cleanup
 188      (Reason : Unwind_Reason_Code;
 189       Excep  : not null GNAT_GCC_Exception_Access);
 190    pragma Convention (C, GNAT_GCC_Exception_Cleanup);
 191    --  Procedure called when a GNAT GCC exception is free.
 192
 193    procedure Propagate_GCC_Exception
 194      (GCC_Exception : not null GCC_Exception_Access);
 195    pragma No_Return (Propagate_GCC_Exception);
 196    --  Propagate a GCC exception
 197
 198    procedure Reraise_GCC_Exception
 199      (GCC_Exception : not null GCC_Exception_Access);
 200    pragma No_Return (Reraise_GCC_Exception);
 201    pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
 202    --  Called to implement raise without exception, ie reraise.  Called
 203    --  directly from gigi.
 204
 205    function Setup_Current_Excep
 206      (GCC_Exception : not null GCC_Exception_Access) return EOA;
 207    pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
 208    --  Write Get_Current_Excep.all from GCC_Exception
 209
 210    procedure Unhandled_Except_Handler
 211      (GCC_Exception : not null GCC_Exception_Access);
 212    pragma No_Return (Unhandled_Except_Handler);
 213    pragma Export (C, Unhandled_Except_Handler,
 214                   "__gnat_unhandled_except_handler");
 215    --  Called for handle unhandled exceptions, ie the last chance handler
 216    --  on platforms (such as SEH) that never returns after throwing an
 217    --  exception. Called directly by gigi.
 218
 219    function CleanupUnwind_Handler
 220      (UW_Version   : Integer;
 221       UW_Phases    : Unwind_Action;
 222       UW_Eclass    : Exception_Class;
 223       UW_Exception : not null GCC_Exception_Access;
 224       UW_Context   : System.Address;
 225       UW_Argument  : System.Address) return Unwind_Reason_Code;
 226    pragma Import (C, CleanupUnwind_Handler,
 227                   "__gnat_cleanupunwind_handler");
 228    --  Hook called at each step of the forced unwinding we perform to
 229    --  trigger cleanups found during the propagation of an unhandled
 230    --  exception.
 231
 232    --  GCC runtime functions used. These are C non-void functions, actually,
 233    --  but we ignore the return values. See raise.c as to why we are using
 234    --  __gnat stubs for these.
 235
 236    procedure Unwind_RaiseException
 237      (UW_Exception : not null GCC_Exception_Access);
 238    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 239
 240    procedure Unwind_ForcedUnwind
 241      (UW_Exception : not null GCC_Exception_Access;
 242       UW_Handler   : System.Address;
 243       UW_Argument  : System.Address);
 244    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 245
 246    --  Hooks called when entering/leaving an exception handler for a given
 247    --  occurrence, aimed at handling the stack of active occurrences. The
 248    --  calls are generated by gigi in tree_transform/N_Exception_Handler.
 249
 250    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
 251    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 252
 253    procedure End_Handler (GCC_Exception : GCC_Exception_Access);
 254    pragma Export (C, End_Handler, "__gnat_end_handler");
 255
 256    --------------------------------------------------------------------
 257    -- Accessors to Basic Components of a GNAT Exception Data Pointer --
 258    --------------------------------------------------------------------
 259
 260    --  As of today, these are only used by the C implementation of the GCC
 261    --  propagation personality routine to avoid having to rely on a C
 262    --  counterpart of the whole exception_data structure, which is both
 263    --  painful and error prone. These subprograms could be moved to a more
 264    --  widely visible location if need be.
 265
 266    function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
 267    pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
 268    pragma Warnings (Off, Is_Handled_By_Others);
 269
 270    function Language_For (E : Exception_Data_Ptr) return Character;
 271    pragma Export (C, Language_For, "__gnat_language_for");
 272
 273    function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
 274    pragma Export (C, Import_Code_For, "__gnat_import_code_for");
 275
 276    function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
 277      return Exception_Id;
 278    pragma Export (C, EID_For, "__gnat_eid_for");
 279
 280    ---------------------------------------------------------------------------
 281    -- Objects to materialize "others" and "all others" in the GCC EH tables --
 282    ---------------------------------------------------------------------------
 283
 284    --  Currently, these only have their address taken and compared so there is
 285    --  no real point having whole exception data blocks allocated. In any case
 286    --  the types should match what gigi and the personality routine expect.
 287    --  The initial value is an arbitrary value that will not exceed the range
 288    --  of Integer on 16-bit targets (such as AAMP).
 289
 290    Others_Value : constant Integer := 16#7FFF#;
 291    pragma Export (C, Others_Value, "__gnat_others_value");
 292
 293    All_Others_Value : constant Integer := 16#7FFF#;
 294    pragma Export (C, All_Others_Value, "__gnat_all_others_value");
 295
 296    Unhandled_Others_Value : constant Integer := 16#7FFF#;
 297    pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
 298    --  Special choice (emitted by gigi) to catch and notify unhandled
 299    --  exceptions on targets which always handle exceptions (such as SEH).
 300    --  The handler will simply call Unhandled_Except_Handler.
 301
 302    -------------------------
 303    -- Allocate_Occurrence --
 304    -------------------------
 305
 306    function Allocate_Occurrence return EOA is
 307       Res : GNAT_GCC_Exception_Access;
 308    begin
 309       Res :=
 310         new GNAT_GCC_Exception'
 311         (Header     => (Class   => GNAT_Exception_Class,
 312                         Cleanup => GNAT_GCC_Exception_Cleanup'Address,
 313                         others  => 0),
 314          Occurrence => (others => <>));
 315       Res.Occurrence.Machine_Occurrence := Res.all'Address;
 316
 317       return Res.Occurrence'Access;
 318    end Allocate_Occurrence;
 319
 320    --------------------------------
 321    -- GNAT_GCC_Exception_Cleanup --
 322    --------------------------------
 323
 324    procedure GNAT_GCC_Exception_Cleanup
 325      (Reason : Unwind_Reason_Code;
 326       Excep  : not null GNAT_GCC_Exception_Access)
 327    is
 328       pragma Unreferenced (Reason);
 329
 330       procedure Free is new Unchecked_Deallocation
 331         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 332
 333       Copy : GNAT_GCC_Exception_Access := Excep;
 334
 335    begin
 336       --  Simply free the memory
 337
 338       Free (Copy);
 339    end GNAT_GCC_Exception_Cleanup;
 340
 341    -------------------------
 342    -- Setup_Current_Excep --
 343    -------------------------
 344
 345    function Setup_Current_Excep
 346      (GCC_Exception : not null GCC_Exception_Access) return EOA
 347    is
 348       Excep : constant EOA := Get_Current_Excep.all;
 349
 350    begin
 351       --  Setup the exception occurrence
 352
 353       if GCC_Exception.Class = GNAT_Exception_Class then
 354
 355          --  From the GCC exception
 356
 357          declare
 358             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 359               To_GNAT_GCC_Exception (GCC_Exception);
 360          begin
 361             Excep.all := GNAT_Occurrence.Occurrence;
 362
 363             return GNAT_Occurrence.Occurrence'Access;
 364          end;
 365       else
 366
 367          --  A default one
 368
 369          Excep.Id := Foreign_Exception'Access;
 370          Excep.Machine_Occurrence := GCC_Exception.all'Address;
 371          Excep.Msg_Length := 0;
 372          Excep.Exception_Raised := True;
 373          Excep.Pid := Local_Partition_ID;
 374          Excep.Num_Tracebacks := 0;
 375
 376          return Excep;
 377       end if;
 378    end Setup_Current_Excep;
 379
 380    -------------------
 381    -- Begin_Handler --
 382    -------------------
 383
 384    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
 385       pragma Unreferenced (GCC_Exception);
 386    begin
 387       null;
 388    end Begin_Handler;
 389
 390    -----------------
 391    -- End_Handler --
 392    -----------------
 393
 394    procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
 395    begin
 396       if GCC_Exception /= null then
 397
 398          --  The exception might have been reraised, in this case the cleanup
 399          --  mustn't be called.
 400
 401          Unwind_DeleteException (GCC_Exception);
 402       end if;
 403    end End_Handler;
 404
 405    -----------------------------
 406    -- Reraise_GCC_Exception --
 407    -----------------------------
 408
 409    procedure Reraise_GCC_Exception
 410      (GCC_Exception : not null GCC_Exception_Access)
 411    is
 412    begin
 413       --  Simply propagate it
 414       Propagate_GCC_Exception (GCC_Exception);
 415    end Reraise_GCC_Exception;
 416
 417    -----------------------------
 418    -- Propagate_GCC_Exception --
 419    -----------------------------
 420
 421    --  Call Unwind_RaiseException to actually throw, taking care of handling
 422    --  the two phase scheme it implements.
 423
 424    procedure Propagate_GCC_Exception
 425      (GCC_Exception : not null GCC_Exception_Access)
 426    is
 427       Excep : EOA;
 428
 429    begin
 430       --  Perform a standard raise first. If a regular handler is found, it
 431       --  will be entered after all the intermediate cleanups have run. If
 432       --  there is no regular handler, it will return.
 433
 434       Unwind_RaiseException (GCC_Exception);
 435
 436       --  If we get here we know the exception is not handled, as otherwise
 437       --  Unwind_RaiseException arranges for the handler to be entered. Take
 438       --  the necessary steps to enable the debugger to gain control while the
 439       --  stack is still intact.
 440
 441       Excep := Setup_Current_Excep (GCC_Exception);
 442       Notify_Unhandled_Exception (Excep);
 443
 444       --  Now, un a forced unwind to trigger cleanups. Control should not
 445       --  resume there, if there are cleanups and in any cases as the
 446       --  unwinding hook calls Unhandled_Exception_Terminate when end of
 447       --  stack is reached.
 448
 449       Unwind_ForcedUnwind (GCC_Exception,
 450                            CleanupUnwind_Handler'Address,
 451                            System.Null_Address);
 452
 453       --  We get here in case of error. The debugger has been notified before
 454       --  the second step above.
 455
 456       Unhandled_Except_Handler (GCC_Exception);
 457    end Propagate_GCC_Exception;
 458
 459    -------------------------
 460    -- Propagate_Exception --
 461    -------------------------
 462
 463    procedure Propagate_Exception (Excep : EOA) is
 464    begin
 465       Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
 466    end Propagate_Exception;
 467
 468    ------------------------------
 469    -- Unhandled_Except_Handler --
 470    ------------------------------
 471
 472    procedure Unhandled_Except_Handler
 473      (GCC_Exception : not null GCC_Exception_Access)
 474    is
 475       Excep : EOA;
 476    begin
 477       Excep := Setup_Current_Excep (GCC_Exception);
 478       Unhandled_Exception_Terminate (Excep);
 479    end Unhandled_Except_Handler;
 480
 481    -------------
 482    -- EID_For --
 483    -------------
 484
 485    function EID_For
 486      (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
 487    is
 488    begin
 489       return GNAT_Exception.Occurrence.Id;
 490    end EID_For;
 491
 492    ---------------------
 493    -- Import_Code_For --
 494    ---------------------
 495
 496    function Import_Code_For
 497      (E : SSL.Exception_Data_Ptr) return Exception_Code
 498    is
 499    begin
 500       return E.all.Import_Code;
 501    end Import_Code_For;
 502
 503    --------------------------
 504    -- Is_Handled_By_Others --
 505    --------------------------
 506
 507    function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
 508    begin
 509       return not E.all.Not_Handled_By_Others;
 510    end Is_Handled_By_Others;
 511
 512    ------------------
 513    -- Language_For --
 514    ------------------
 515
 516    function Language_For (E : SSL.Exception_Data_Ptr) return Character is
 517    begin
 518       return E.all.Lang;
 519    end Language_For;
 520
 521 end Exception_Propagation;