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-2011, 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    ------------------------------------------------
  43    -- Entities to interface with the GCC runtime --
  44    ------------------------------------------------
  45
  46    --  These come from "C++ ABI for Itanium: Exception handling", which is
  47    --  the reference for GCC. They are used only when we are relying on
  48    --  back-end tables for exception propagation, which in turn is currently
  49    --  only the case for Zero_Cost_Exceptions in GNAT5.
  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_FOREIGN_EXCEPTION_CAUGHT,
  67       URC_PHASE2_ERROR,
  68       URC_PHASE1_ERROR,
  69       URC_NORMAL_STOP,
  70       URC_END_OF_STACK,
  71       URC_HANDLER_FOUND,
  72       URC_INSTALL_CONTEXT,
  73       URC_CONTINUE_UNWIND);
  74
  75    pragma Convention (C, Unwind_Reason_Code);
  76
  77    --  Phase identifiers
  78
  79    type Unwind_Action is new Integer;
  80    pragma Convention (C, Unwind_Action);
  81
  82    UA_SEARCH_PHASE  : constant Unwind_Action := 1;
  83    UA_CLEANUP_PHASE : constant Unwind_Action := 2;
  84    UA_HANDLER_FRAME : constant Unwind_Action := 4;
  85    UA_FORCE_UNWIND  : constant Unwind_Action := 8;
  86    UA_END_OF_STACK  : constant Unwind_Action := 16;  --  GCC extension ?
  87
  88    pragma Unreferenced
  89      (UA_SEARCH_PHASE,
  90       UA_CLEANUP_PHASE,
  91       UA_HANDLER_FRAME,
  92       UA_FORCE_UNWIND);
  93
  94    --  Mandatory common header for any exception object handled by the
  95    --  GCC unwinding runtime.
  96
  97    type Exception_Class is mod 2 ** 64;
  98
  99    GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
 100    --  "GNU-Ada\0"
 101
 102    type Unwind_Word is mod 2 ** System.Word_Size;
 103    for Unwind_Word'Size use System.Word_Size;
 104    --  Map the corresponding C type used in Unwind_Exception below
 105
 106    type Unwind_Exception is record
 107       Class    : Exception_Class;
 108       Cleanup  : System.Address;
 109       Private1 : Unwind_Word;
 110       Private2 : Unwind_Word;
 111    end record;
 112    pragma Convention (C, Unwind_Exception);
 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    type GCC_Exception_Access is access all Unwind_Exception;
 122    pragma Convention (C, GCC_Exception_Access);
 123    --  Pointer to a GCC exception
 124
 125    procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
 126    pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
 127    --  Procedure to free any GCC exception
 128
 129    Foreign_Exception : aliased System.Standard_Library.Exception_Data;
 130    pragma Import (Ada, Foreign_Exception,
 131                   "system__exceptions__foreign_exception");
 132    --  Id for foreign exceptions
 133
 134    --------------------------------------------------------------
 135    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
 136    --------------------------------------------------------------
 137
 138    --  A GNAT exception object to be dealt with by the personality routine
 139    --  called by the GCC unwinding runtime.
 140
 141    type GNAT_GCC_Exception is record
 142       Header : Unwind_Exception;
 143       --  ABI Exception header first
 144
 145       Occurrence : Exception_Occurrence;
 146       --  The Ada occurrence
 147    end record;
 148
 149    pragma Convention (C, GNAT_GCC_Exception);
 150
 151    --  There is a subtle issue with the common header alignment, since the C
 152    --  version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
 153    --  Standard'Maximum_Alignment, and those two values don't quite represent
 154    --  the same concepts and so may be decoupled someday. One typical reason
 155    --  is that BIGGEST_ALIGNMENT may be larger than what the underlying system
 156    --  allocator guarantees, and there are extra costs involved in allocating
 157    --  objects aligned to such factors.
 158
 159    --  To deal with the potential alignment differences between the C and Ada
 160    --  representations, the Ada part of the whole structure is only accessed
 161    --  by the personality routine through the accessors declared below.  Ada
 162    --  specific fields are thus always accessed through consistent layout, and
 163    --  we expect the actual alignment to always be large enough to avoid traps
 164    --  from the C accesses to the common header. Besides, accessors alleviate
 165    --  the need for a C struct whole counterpart, both painful and error-prone
 166    --  to maintain anyway.
 167
 168    type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
 169    pragma Convention (C, GNAT_GCC_Exception_Access);
 170
 171    function To_GCC_Exception is new
 172      Unchecked_Conversion (GNAT_GCC_Exception_Access, GCC_Exception_Access);
 173
 174    function To_GNAT_GCC_Exception is new
 175      Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
 176
 177    procedure GNAT_GCC_Exception_Cleanup
 178      (Reason : Unwind_Reason_Code;
 179       Excep  : not null GNAT_GCC_Exception_Access);
 180    pragma Convention (C, GNAT_GCC_Exception_Cleanup);
 181    --  Procedure called when a GNAT GCC exception is free.
 182
 183    procedure Propagate_GCC_Exception
 184      (GCC_Exception : not null GCC_Exception_Access);
 185    pragma No_Return (Propagate_GCC_Exception);
 186    --  Propagate a GCC exception
 187
 188    procedure Reraise_GCC_Exception
 189      (GCC_Exception : not null GCC_Exception_Access);
 190    pragma No_Return (Reraise_GCC_Exception);
 191    pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
 192    --  Called to implement raise without exception, ie reraise.  Called
 193    --  directly from gigi.
 194
 195    procedure Setup_Current_Excep
 196      (GCC_Exception : not null GCC_Exception_Access);
 197    pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
 198    --  Write Get_Current_Excep.all from GCC_Exception
 199
 200    function CleanupUnwind_Handler
 201      (UW_Version   : Integer;
 202       UW_Phases    : Unwind_Action;
 203       UW_Eclass    : Exception_Class;
 204       UW_Exception : not null GCC_Exception_Access;
 205       UW_Context   : System.Address;
 206       UW_Argument  : System.Address) return Unwind_Reason_Code;
 207    --  Hook called at each step of the forced unwinding we perform to
 208    --  trigger cleanups found during the propagation of an unhandled
 209    --  exception.
 210
 211    --  GCC runtime functions used. These are C non-void functions, actually,
 212    --  but we ignore the return values. See raise.c as to why we are using
 213    --  __gnat stubs for these.
 214
 215    procedure Unwind_RaiseException
 216      (UW_Exception : not null GCC_Exception_Access);
 217    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 218
 219    procedure Unwind_ForcedUnwind
 220      (UW_Exception : not null GCC_Exception_Access;
 221       UW_Handler   : System.Address;
 222       UW_Argument  : System.Address);
 223    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 224
 225    --  Hooks called when entering/leaving an exception handler for a given
 226    --  occurrence, aimed at handling the stack of active occurrences. The
 227    --  calls are generated by gigi in tree_transform/N_Exception_Handler.
 228
 229    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
 230    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 231
 232    procedure End_Handler (GCC_Exception : GCC_Exception_Access);
 233    pragma Export (C, End_Handler, "__gnat_end_handler");
 234
 235    --------------------------------------------------------------------
 236    -- Accessors to Basic Components of a GNAT Exception Data Pointer --
 237    --------------------------------------------------------------------
 238
 239    --  As of today, these are only used by the C implementation of the GCC
 240    --  propagation personality routine to avoid having to rely on a C
 241    --  counterpart of the whole exception_data structure, which is both
 242    --  painful and error prone. These subprograms could be moved to a more
 243    --  widely visible location if need be.
 244
 245    function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
 246    pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
 247    pragma Warnings (Off, Is_Handled_By_Others);
 248
 249    function Language_For (E : Exception_Data_Ptr) return Character;
 250    pragma Export (C, Language_For, "__gnat_language_for");
 251
 252    function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
 253    pragma Export (C, Import_Code_For, "__gnat_import_code_for");
 254
 255    function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
 256      return Exception_Id;
 257    pragma Export (C, EID_For, "__gnat_eid_for");
 258
 259    ---------------------------------------------------------------------------
 260    -- Objects to materialize "others" and "all others" in the GCC EH tables --
 261    ---------------------------------------------------------------------------
 262
 263    --  Currently, these only have their address taken and compared so there is
 264    --  no real point having whole exception data blocks allocated. In any case
 265    --  the types should match what gigi and the personality routine expect.
 266    --  The initial value is an arbitrary value that will not exceed the range
 267    --  of Integer on 16-bit targets (such as AAMP).
 268
 269    Others_Value : constant Integer := 16#7FFF#;
 270    pragma Export (C, Others_Value, "__gnat_others_value");
 271
 272    All_Others_Value : constant Integer := 16#7FFF#;
 273    pragma Export (C, All_Others_Value, "__gnat_all_others_value");
 274
 275    --------------------------------
 276    -- GNAT_GCC_Exception_Cleanup --
 277    --------------------------------
 278
 279    procedure GNAT_GCC_Exception_Cleanup
 280      (Reason : Unwind_Reason_Code;
 281       Excep  : not null GNAT_GCC_Exception_Access)
 282    is
 283       pragma Unreferenced (Reason);
 284
 285       procedure Free is new Unchecked_Deallocation
 286         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 287
 288       Copy : GNAT_GCC_Exception_Access := Excep;
 289
 290    begin
 291       --  Simply free the memory
 292
 293       Free (Copy);
 294    end GNAT_GCC_Exception_Cleanup;
 295
 296    ---------------------------
 297    -- CleanupUnwind_Handler --
 298    ---------------------------
 299
 300    function CleanupUnwind_Handler
 301      (UW_Version   : Integer;
 302       UW_Phases    : Unwind_Action;
 303       UW_Eclass    : Exception_Class;
 304       UW_Exception : not null GCC_Exception_Access;
 305       UW_Context   : System.Address;
 306       UW_Argument  : System.Address) return Unwind_Reason_Code
 307    is
 308       pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
 309
 310    begin
 311       --  Terminate when the end of the stack is reached
 312
 313       if UW_Phases >= UA_END_OF_STACK then
 314          Setup_Current_Excep (UW_Exception);
 315          Unhandled_Exception_Terminate;
 316       end if;
 317
 318       --  We know there is at least one cleanup further up. Return so that it
 319       --  is searched and entered, after which Unwind_Resume will be called
 320       --  and this hook will gain control again.
 321
 322       return URC_NO_REASON;
 323    end CleanupUnwind_Handler;
 324
 325    -------------------------
 326    -- Setup_Current_Excep --
 327    -------------------------
 328
 329    procedure Setup_Current_Excep
 330      (GCC_Exception : not null GCC_Exception_Access)
 331    is
 332       Excep : constant EOA := Get_Current_Excep.all;
 333
 334    begin
 335       --  Setup the exception occurrence
 336
 337       if GCC_Exception.Class = GNAT_Exception_Class then
 338
 339          --  From the GCC exception
 340
 341          declare
 342             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 343                                 To_GNAT_GCC_Exception (GCC_Exception);
 344          begin
 345             Excep.all := GNAT_Occurrence.Occurrence;
 346          end;
 347       else
 348
 349          --  A default one
 350
 351          Excep.Id := Foreign_Exception'Access;
 352          Excep.Msg_Length := 0;
 353          Excep.Exception_Raised := True;
 354          Excep.Pid := Local_Partition_ID;
 355          Excep.Num_Tracebacks := 0;
 356       end if;
 357    end Setup_Current_Excep;
 358
 359    -------------------
 360    -- Begin_Handler --
 361    -------------------
 362
 363    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
 364       pragma Unreferenced (GCC_Exception);
 365    begin
 366       null;
 367    end Begin_Handler;
 368
 369    -----------------
 370    -- End_Handler --
 371    -----------------
 372
 373    procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
 374    begin
 375       if GCC_Exception /= null then
 376
 377          --  The exception might have been reraised, in this case the cleanup
 378          --  mustn't be called.
 379
 380          Unwind_DeleteException (GCC_Exception);
 381       end if;
 382    end End_Handler;
 383
 384    -----------------------------
 385    -- Reraise_GCC_Exception --
 386    -----------------------------
 387
 388    procedure Reraise_GCC_Exception
 389      (GCC_Exception : not null GCC_Exception_Access)
 390    is
 391    begin
 392       --  Simply propagate it
 393       Propagate_GCC_Exception (GCC_Exception);
 394    end Reraise_GCC_Exception;
 395
 396    -----------------------------
 397    -- Propagate_GCC_Exception --
 398    -----------------------------
 399
 400    --  Call Unwind_RaiseException to actually throw, taking care of handling
 401    --  the two phase scheme it implements.
 402
 403    procedure Propagate_GCC_Exception
 404      (GCC_Exception : not null GCC_Exception_Access)
 405    is
 406    begin
 407       --  Perform a standard raise first. If a regular handler is found, it
 408       --  will be entered after all the intermediate cleanups have run. If
 409       --  there is no regular handler, it will return.
 410
 411       Unwind_RaiseException (GCC_Exception);
 412
 413       --  If we get here we know the exception is not handled, as otherwise
 414       --  Unwind_RaiseException arranges for the handler to be entered. Take
 415       --  the necessary steps to enable the debugger to gain control while the
 416       --  stack is still intact.
 417
 418       Setup_Current_Excep (GCC_Exception);
 419       Notify_Unhandled_Exception;
 420
 421       --  Now, un a forced unwind to trigger cleanups. Control should not
 422       --  resume there, if there are cleanups and in any cases as the
 423       --  unwinding hook calls Unhandled_Exception_Terminate when end of
 424       --  stack is reached.
 425
 426       Unwind_ForcedUnwind (GCC_Exception,
 427                            CleanupUnwind_Handler'Address,
 428                            System.Null_Address);
 429
 430       --  We get here in case of error. The debugger has been notified before
 431       --  the second step above.
 432
 433       Setup_Current_Excep (GCC_Exception);
 434       Unhandled_Exception_Terminate;
 435    end Propagate_GCC_Exception;
 436
 437    -------------------------
 438    -- Propagate_Exception --
 439    -------------------------
 440
 441    --  Build an object suitable for the libgcc processing and call
 442    --  Unwind_RaiseException to actually do the raise, taking care of
 443    --  handling the two phase scheme it implements.
 444
 445    procedure Propagate_Exception
 446    is
 447       Excep         : constant EOA := Get_Current_Excep.all;
 448       GCC_Exception : GNAT_GCC_Exception_Access;
 449
 450    begin
 451       --  Compute the backtrace for this occurrence if the corresponding
 452       --  binder option has been set. Call_Chain takes care of the reraise
 453       --  case.
 454
 455       --  ??? Using Call_Chain here means we are going to walk up the stack
 456       --  once only for backtracing purposes before doing it again for the
 457       --  propagation per se.
 458
 459       --  The first inspection is much lighter, though, as it only requires
 460       --  partial unwinding of each frame. Additionally, although we could use
 461       --  the personality routine to record the addresses while propagating,
 462       --  this method has two drawbacks:
 463
 464       --  1) the trace is incomplete if the exception is handled since we
 465       --  don't walk past the frame with the handler,
 466
 467       --    and
 468
 469       --  2) we would miss the frames for which our personality routine is not
 470       --  called, e.g. if C or C++ calls are on the way.
 471
 472       Call_Chain (Excep);
 473
 474       --  Allocate the GCC exception
 475
 476       GCC_Exception :=
 477         new GNAT_GCC_Exception'
 478           (Header     => (Class => GNAT_Exception_Class,
 479                           Cleanup => GNAT_GCC_Exception_Cleanup'Address,
 480                           Private1 => 0,
 481                           Private2 => 0),
 482            Occurrence => Excep.all);
 483
 484       --  Propagate it
 485
 486       Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
 487    end Propagate_Exception;
 488
 489    -------------
 490    -- EID_For --
 491    -------------
 492
 493    function EID_For
 494      (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
 495    is
 496    begin
 497       return GNAT_Exception.Occurrence.Id;
 498    end EID_For;
 499
 500    ---------------------
 501    -- Import_Code_For --
 502    ---------------------
 503
 504    function Import_Code_For
 505      (E : SSL.Exception_Data_Ptr) return Exception_Code
 506    is
 507    begin
 508       return E.all.Import_Code;
 509    end Import_Code_For;
 510
 511    --------------------------
 512    -- Is_Handled_By_Others --
 513    --------------------------
 514
 515    function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
 516    begin
 517       return not E.all.Not_Handled_By_Others;
 518    end Is_Handled_By_Others;
 519
 520    ------------------
 521    -- Language_For --
 522    ------------------
 523
 524    function Language_For (E : SSL.Exception_Data_Ptr) return Character is
 525    begin
 526       return E.all.Lang;
 527    end Language_For;
 528
 529 end Exception_Propagation;