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-2013, 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 the
  49    --  reference for GCC.
  50
  51    --  Return codes from GCC runtime functions used to propagate an exception
  52
  53    type Unwind_Reason_Code is
  54      (URC_NO_REASON,
  55       URC_FOREIGN_EXCEPTION_CAUGHT,
  56       URC_PHASE2_ERROR,
  57       URC_PHASE1_ERROR,
  58       URC_NORMAL_STOP,
  59       URC_END_OF_STACK,
  60       URC_HANDLER_FOUND,
  61       URC_INSTALL_CONTEXT,
  62       URC_CONTINUE_UNWIND);
  63
  64    pragma Unreferenced
  65      (URC_NO_REASON,
  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       UA_END_OF_STACK);
  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;
 109       Cleanup  : System.Address;
 110       Private1 : Unwind_Word;
 111       Private2 : Unwind_Word;
 112
 113       --  Usual exception structure has only two private fields, but the SEH
 114       --  one has six. To avoid making this file more complex, we use six
 115       --  fields on all platforms, wasting a few bytes on some.
 116
 117       Private3 : Unwind_Word;
 118       Private4 : Unwind_Word;
 119       Private5 : Unwind_Word;
 120       Private6 : Unwind_Word;
 121    end record;
 122    pragma Convention (C, Unwind_Exception);
 123    --  Map the GCC struct used for exception handling
 124
 125    for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
 126    --  The C++ ABI mandates the common exception header to be at least
 127    --  doubleword aligned, and the libGCC implementation actually makes it
 128    --  maximally aligned (see unwind.h). See additional comments on the
 129    --  alignment below.
 130
 131    type GCC_Exception_Access is access all Unwind_Exception;
 132    --  Pointer to a GCC exception. Do not use convention C as on VMS this
 133    --  would imply the use of 32-bits pointers.
 134
 135    procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
 136    pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
 137    --  Procedure to free any GCC exception
 138
 139    Foreign_Exception : aliased System.Standard_Library.Exception_Data;
 140    pragma Import (Ada, Foreign_Exception,
 141                   "system__exceptions__foreign_exception");
 142    --  Id for foreign exceptions
 143
 144    --------------------------------------------------------------
 145    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
 146    --------------------------------------------------------------
 147
 148    --  A GNAT exception object to be dealt with by the personality routine
 149    --  called by the GCC unwinding runtime.
 150
 151    type GNAT_GCC_Exception is record
 152       Header : Unwind_Exception;
 153       --  ABI Exception header first
 154
 155       Occurrence : aliased Exception_Occurrence;
 156       --  The Ada occurrence
 157    end record;
 158
 159    pragma Convention (C, GNAT_GCC_Exception);
 160
 161    --  There is a subtle issue with the common header alignment, since the C
 162    --  version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
 163    --  Standard'Maximum_Alignment, and those two values don't quite represent
 164    --  the same concepts and so may be decoupled someday. One typical reason
 165    --  is that BIGGEST_ALIGNMENT may be larger than what the underlying system
 166    --  allocator guarantees, and there are extra costs involved in allocating
 167    --  objects aligned to such factors.
 168
 169    --  To deal with the potential alignment differences between the C and Ada
 170    --  representations, the Ada part of the whole structure is only accessed
 171    --  by the personality routine through the accessors declared below.  Ada
 172    --  specific fields are thus always accessed through consistent layout, and
 173    --  we expect the actual alignment to always be large enough to avoid traps
 174    --  from the C accesses to the common header. Besides, accessors alleviate
 175    --  the need for a C struct whole counterpart, both painful and error-prone
 176    --  to maintain anyway.
 177
 178    type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
 179
 180    function To_GCC_Exception is new
 181      Unchecked_Conversion (System.Address, GCC_Exception_Access);
 182
 183    function To_GNAT_GCC_Exception is new
 184      Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
 185
 186    procedure GNAT_GCC_Exception_Cleanup
 187      (Reason : Unwind_Reason_Code;
 188       Excep  : not null GNAT_GCC_Exception_Access);
 189    pragma Convention (C, GNAT_GCC_Exception_Cleanup);
 190    --  Procedure called when a GNAT GCC exception is free.
 191
 192    procedure Propagate_GCC_Exception
 193      (GCC_Exception : not null GCC_Exception_Access);
 194    pragma No_Return (Propagate_GCC_Exception);
 195    --  Propagate a GCC exception
 196
 197    procedure Reraise_GCC_Exception
 198      (GCC_Exception : not null GCC_Exception_Access);
 199    pragma No_Return (Reraise_GCC_Exception);
 200    pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
 201    --  Called to implement raise without exception, ie reraise. Called
 202    --  directly from gigi.
 203
 204    function Setup_Current_Excep
 205      (GCC_Exception : not null GCC_Exception_Access) return EOA;
 206    pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
 207    --  Write Get_Current_Excep.all from GCC_Exception. Called by the
 208    --  personality routine.
 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 trigger
 229    --  cleanups found during the propagation of an unhandled exception.
 230
 231    --  GCC runtime functions used. These are C non-void functions, actually,
 232    --  but we ignore the return values. See raise.c as to why we are using
 233    --  __gnat stubs for these.
 234
 235    procedure Unwind_RaiseException
 236      (UW_Exception : not null GCC_Exception_Access);
 237    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 238
 239    procedure Unwind_ForcedUnwind
 240      (UW_Exception : not null GCC_Exception_Access;
 241       UW_Handler   : System.Address;
 242       UW_Argument  : System.Address);
 243    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 244
 245    procedure Set_Exception_Parameter
 246      (Excep         : EOA;
 247       GCC_Exception : not null GCC_Exception_Access);
 248    pragma Export
 249      (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
 250    --  Called inserted by gigi to initialize the exception parameter
 251
 252    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
 253    --  Utility routine to initialize occurrence Excep from a foreign exception
 254    --  whose machine occurrence is Mo. The message is empty, the backtrace
 255    --  is empty too and the exception identity is Foreign_Exception.
 256
 257    --  Hooks called when entering/leaving an exception handler for a given
 258    --  occurrence, aimed at handling the stack of active occurrences. The
 259    --  calls are generated by gigi in tree_transform/N_Exception_Handler.
 260
 261    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
 262    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 263
 264    procedure End_Handler (GCC_Exception : GCC_Exception_Access);
 265    pragma Export (C, End_Handler, "__gnat_end_handler");
 266
 267    --------------------------------------------------------------------
 268    -- Accessors to Basic Components of a GNAT Exception Data Pointer --
 269    --------------------------------------------------------------------
 270
 271    --  As of today, these are only used by the C implementation of the GCC
 272    --  propagation personality routine to avoid having to rely on a C
 273    --  counterpart of the whole exception_data structure, which is both
 274    --  painful and error prone. These subprograms could be moved to a more
 275    --  widely visible location if need be.
 276
 277    function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
 278    pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
 279    pragma Warnings (Off, Is_Handled_By_Others);
 280
 281    function Language_For (E : Exception_Data_Ptr) return Character;
 282    pragma Export (C, Language_For, "__gnat_language_for");
 283
 284    function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
 285    pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
 286
 287    function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
 288      return Exception_Id;
 289    pragma Export (C, EID_For, "__gnat_eid_for");
 290
 291    ---------------------------------------------------------------------------
 292    -- Objects to materialize "others" and "all others" in the GCC EH tables --
 293    ---------------------------------------------------------------------------
 294
 295    --  Currently, these only have their address taken and compared so there is
 296    --  no real point having whole exception data blocks allocated. Note that
 297    --  there are corresponding declarations in gigi (trans.c) which must be
 298    --  kept properly synchronized.
 299
 300    Others_Value : constant Character := 'O';
 301    pragma Export (C, Others_Value, "__gnat_others_value");
 302
 303    All_Others_Value : constant Character := 'A';
 304    pragma Export (C, All_Others_Value, "__gnat_all_others_value");
 305
 306    Unhandled_Others_Value : constant Character := 'U';
 307    pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
 308    --  Special choice (emitted by gigi) to catch and notify unhandled
 309    --  exceptions on targets which always handle exceptions (such as SEH).
 310    --  The handler will simply call Unhandled_Except_Handler.
 311
 312    -------------------------
 313    -- Allocate_Occurrence --
 314    -------------------------
 315
 316    function Allocate_Occurrence return EOA is
 317       Res : GNAT_GCC_Exception_Access;
 318
 319    begin
 320       Res :=
 321         new GNAT_GCC_Exception'
 322         (Header     => (Class   => GNAT_Exception_Class,
 323                         Cleanup => GNAT_GCC_Exception_Cleanup'Address,
 324                         others  => 0),
 325          Occurrence => (others => <>));
 326       Res.Occurrence.Machine_Occurrence := Res.all'Address;
 327
 328       return Res.Occurrence'Access;
 329    end Allocate_Occurrence;
 330
 331    --------------------------------
 332    -- GNAT_GCC_Exception_Cleanup --
 333    --------------------------------
 334
 335    procedure GNAT_GCC_Exception_Cleanup
 336      (Reason : Unwind_Reason_Code;
 337       Excep  : not null GNAT_GCC_Exception_Access)
 338    is
 339       pragma Unreferenced (Reason);
 340
 341       procedure Free is new Unchecked_Deallocation
 342         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 343
 344       Copy : GNAT_GCC_Exception_Access := Excep;
 345
 346    begin
 347       --  Simply free the memory
 348
 349       Free (Copy);
 350    end GNAT_GCC_Exception_Cleanup;
 351
 352    ----------------------------
 353    -- Set_Foreign_Occurrence --
 354    ----------------------------
 355
 356    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
 357    begin
 358       Excep.all := (
 359         Id                 => Foreign_Exception'Access,
 360         Machine_Occurrence => Mo,
 361         Msg                => <>,
 362         Msg_Length         => 0,
 363         Exception_Raised   => True,
 364         Pid                => Local_Partition_ID,
 365         Num_Tracebacks     => 0,
 366         Tracebacks         => <>);
 367    end Set_Foreign_Occurrence;
 368
 369    -------------------------
 370    -- Setup_Current_Excep --
 371    -------------------------
 372
 373    function Setup_Current_Excep
 374      (GCC_Exception : not null GCC_Exception_Access) return EOA
 375    is
 376       Excep : constant EOA := Get_Current_Excep.all;
 377
 378    begin
 379       --  Setup the exception occurrence
 380
 381       if GCC_Exception.Class = GNAT_Exception_Class then
 382
 383          --  From the GCC exception
 384
 385          declare
 386             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 387                                 To_GNAT_GCC_Exception (GCC_Exception);
 388          begin
 389             Excep.all := GNAT_Occurrence.Occurrence;
 390             return GNAT_Occurrence.Occurrence'Access;
 391          end;
 392
 393       else
 394          --  A default one
 395
 396          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 397
 398          return Excep;
 399       end if;
 400    end Setup_Current_Excep;
 401
 402    -------------------
 403    -- Begin_Handler --
 404    -------------------
 405
 406    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
 407       pragma Unreferenced (GCC_Exception);
 408    begin
 409       null;
 410    end Begin_Handler;
 411
 412    -----------------
 413    -- End_Handler --
 414    -----------------
 415
 416    procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
 417    begin
 418       if GCC_Exception /= null then
 419
 420          --  The exception might have been reraised, in this case the cleanup
 421          --  mustn't be called.
 422
 423          Unwind_DeleteException (GCC_Exception);
 424       end if;
 425    end End_Handler;
 426
 427    -----------------------------
 428    -- Reraise_GCC_Exception --
 429    -----------------------------
 430
 431    procedure Reraise_GCC_Exception
 432      (GCC_Exception : not null GCC_Exception_Access)
 433    is
 434    begin
 435       --  Simply propagate it
 436
 437       Propagate_GCC_Exception (GCC_Exception);
 438    end Reraise_GCC_Exception;
 439
 440    -----------------------------
 441    -- Propagate_GCC_Exception --
 442    -----------------------------
 443
 444    --  Call Unwind_RaiseException to actually throw, taking care of handling
 445    --  the two phase scheme it implements.
 446
 447    procedure Propagate_GCC_Exception
 448      (GCC_Exception : not null GCC_Exception_Access)
 449    is
 450       Excep : EOA;
 451
 452    begin
 453       --  Perform a standard raise first. If a regular handler is found, it
 454       --  will be entered after all the intermediate cleanups have run. If
 455       --  there is no regular handler, it will return.
 456
 457       Unwind_RaiseException (GCC_Exception);
 458
 459       --  If we get here we know the exception is not handled, as otherwise
 460       --  Unwind_RaiseException arranges for the handler to be entered. Take
 461       --  the necessary steps to enable the debugger to gain control while the
 462       --  stack is still intact.
 463
 464       Excep := Setup_Current_Excep (GCC_Exception);
 465       Notify_Unhandled_Exception (Excep);
 466
 467       --  Now, un a forced unwind to trigger cleanups. Control should not
 468       --  resume there, if there are cleanups and in any cases as the
 469       --  unwinding hook calls Unhandled_Exception_Terminate when end of
 470       --  stack is reached.
 471
 472       Unwind_ForcedUnwind
 473         (GCC_Exception,
 474          CleanupUnwind_Handler'Address,
 475          System.Null_Address);
 476
 477       --  We get here in case of error. The debugger has been notified before
 478       --  the second step above.
 479
 480       Unhandled_Except_Handler (GCC_Exception);
 481    end Propagate_GCC_Exception;
 482
 483    -------------------------
 484    -- Propagate_Exception --
 485    -------------------------
 486
 487    procedure Propagate_Exception (Excep : EOA) is
 488    begin
 489       Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
 490    end Propagate_Exception;
 491
 492    -----------------------------
 493    -- Set_Exception_Parameter --
 494    -----------------------------
 495
 496    procedure Set_Exception_Parameter
 497      (Excep         : EOA;
 498       GCC_Exception : not null GCC_Exception_Access)
 499    is
 500    begin
 501       --  Setup the exception occurrence
 502
 503       if GCC_Exception.Class = GNAT_Exception_Class then
 504
 505          --  From the GCC exception
 506
 507          declare
 508             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 509                                 To_GNAT_GCC_Exception (GCC_Exception);
 510          begin
 511             Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
 512          end;
 513
 514       else
 515          --  A default one
 516
 517          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 518       end if;
 519    end Set_Exception_Parameter;
 520
 521    ------------------------------
 522    -- Unhandled_Except_Handler --
 523    ------------------------------
 524
 525    procedure Unhandled_Except_Handler
 526      (GCC_Exception : not null GCC_Exception_Access)
 527    is
 528       Excep : EOA;
 529    begin
 530       Excep := Setup_Current_Excep (GCC_Exception);
 531       Unhandled_Exception_Terminate (Excep);
 532    end Unhandled_Except_Handler;
 533
 534    -------------
 535    -- EID_For --
 536    -------------
 537
 538    function EID_For
 539      (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
 540    is
 541    begin
 542       return GNAT_Exception.Occurrence.Id;
 543    end EID_For;
 544
 545    ----------------------
 546    -- Foreign_Data_For --
 547    ----------------------
 548
 549    function Foreign_Data_For
 550      (E : SSL.Exception_Data_Ptr) return Address
 551    is
 552    begin
 553       return E.Foreign_Data;
 554    end Foreign_Data_For;
 555
 556    --------------------------
 557    -- Is_Handled_By_Others --
 558    --------------------------
 559
 560    function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
 561    begin
 562       return not E.all.Not_Handled_By_Others;
 563    end Is_Handled_By_Others;
 564
 565    ------------------
 566    -- Language_For --
 567    ------------------
 568
 569    function Language_For (E : SSL.Exception_Data_Ptr) return Character is
 570    begin
 571       return E.all.Lang;
 572    end Language_For;
 573
 574 end Exception_Propagation;