gcc/ada/libgnat/a-exexpr.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-2018, 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, which could rely on
  33 --  different underlying unwinding engines, for example DWARF or ARM unwind
  34 --  info based. Here is a sketch of the most prominent data structures
  35 --  involved:
  36
  37 --      (s-excmac.ads)
  38 --      GNAT_GCC_Exception:
  39 --      *-----------------------------------*
  40 --  o-->|          (s-excmac.ads)           |
  41 --  |   | Header : <gcc occurrence type>    |
  42 --  |   |   - Class                         |
  43 --  |   |   ...                             |    Constraint_Error:
  44 --  |   |-----------------------------------*    Program_Error:
  45 --  |   |              (a-except.ads)       |    Foreign_Exception:
  46 --  |   | Occurrence : Exception_Occurrence |
  47 --  |   |                                   |    (s-stalib. ads)
  48 --  |   |   - Id : Exception_Id  --------------> Exception_Data
  49 --  o------ - Machine_Occurrence            |   *------------------------*
  50 --      |   - Msg                           |   | Not_Handled_By_Others  |
  51 --      |   - Traceback                     |   | Lang                   |
  52 --      |   ...                             |   | Foreign_Data --o       |
  53 --      *-----------------------------------*   | Full_Name      |       |
  54 --        ||                                    | ...            |       |
  55 --        ||          foreign rtti blob         *----------------|-------*
  56 --        ||          *---------------*                          |
  57 --        ||          |   ...   ...   |<-------------------------o
  58 --        ||          *---------------*
  59 --        ||
  60 --     Setup_Current_Excep()
  61 --        ||
  62 --        ||   Latch into ATCB or
  63 --        ||   environment Current Exception Buffer:
  64 --        ||
  65 --        vv
  66 --     <> : Exception_Occurrence
  67 --     *---------------------------*
  68 --     | ...  ...  ... ... ... ... * --- Get_Current_Excep() ---->
  69 --     *---------------------------*
  70
  71 --  On "raise" events, the runtime allocates a new GNAT_GCC_Exception
  72 --  instance and eventually calls into libgcc's Unwind_RaiseException.
  73 --  This part handles the object through the header part only.
  74
  75 --  During execution, Get_Current_Excep provides a pointer to the
  76 --  Exception_Occurrence being raised or last raised by the current task.
  77
  78 --  This is actually the address of a statically allocated
  79 --  Exception_Occurrence attached to the current ATCB or to the environment
  80 --  thread into which an occurrence being raised is synchronized at critical
  81 --  points during the raise process, via Setup_Current_Excep.
  82
  83 with Ada.Unchecked_Conversion;
  84 with Ada.Unchecked_Deallocation;
  85
  86 with System.Storage_Elements;   use System.Storage_Elements;
  87 with System.Exceptions.Machine; use System.Exceptions.Machine;
  88
  89 separate (Ada.Exceptions)
  90 package body Exception_Propagation is
  91
  92    use Exception_Traces;
  93
  94    Foreign_Exception : aliased System.Standard_Library.Exception_Data;
  95    pragma Import (Ada, Foreign_Exception,
  96                   "system__exceptions__foreign_exception");
  97    --  Id for foreign exceptions
  98
  99    --------------------------------------------------------------
 100    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
 101    --------------------------------------------------------------
 102
 103    --  Phase identifiers (Unwind Actions)
 104
 105    type Unwind_Action is new Integer;
 106    pragma Convention (C, Unwind_Action);
 107
 108    UA_SEARCH_PHASE  : constant Unwind_Action := 1;
 109    UA_CLEANUP_PHASE : constant Unwind_Action := 2;
 110    UA_HANDLER_FRAME : constant Unwind_Action := 4;
 111    UA_FORCE_UNWIND  : constant Unwind_Action := 8;
 112    UA_END_OF_STACK  : constant Unwind_Action := 16;  --  GCC extension
 113
 114    pragma Unreferenced
 115      (UA_HANDLER_FRAME,
 116       UA_FORCE_UNWIND,
 117       UA_END_OF_STACK);
 118
 119    procedure GNAT_GCC_Exception_Cleanup
 120      (Reason : Unwind_Reason_Code;
 121       Excep  : not null GNAT_GCC_Exception_Access);
 122    pragma Convention (C, GNAT_GCC_Exception_Cleanup);
 123    --  Procedure called when a GNAT GCC exception is free.
 124
 125    procedure Propagate_GCC_Exception
 126      (GCC_Exception : not null GCC_Exception_Access);
 127    pragma No_Return (Propagate_GCC_Exception);
 128    --  Propagate a GCC exception
 129
 130    procedure Reraise_GCC_Exception
 131      (GCC_Exception : not null GCC_Exception_Access);
 132    pragma No_Return (Reraise_GCC_Exception);
 133    pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
 134    --  Called to implement raise without exception, ie reraise. Called
 135    --  directly from gigi.
 136
 137    function Setup_Current_Excep
 138      (GCC_Exception : not null GCC_Exception_Access;
 139       Phase : Unwind_Action) return EOA;
 140    pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
 141    --  Acknowledge GCC_Exception as the current exception object being
 142    --  raised, which could be an Ada or a foreign exception object.  Return
 143    --  a pointer to the embedded Ada occurrence for an Ada exception object,
 144    --  to the current exception buffer otherwise.
 145    --
 146    --  Synchronize the current exception buffer as needed for possible
 147    --  accesses through Get_Current_Except.all afterwards, depending on the
 148    --  Phase bits, received either from the personality routine, from a
 149    --  forced_unwind cleanup handler, or just before the start of propagation
 150    --  for an Ada exception (Phase 0 in this case).
 151
 152    procedure Unhandled_Except_Handler
 153      (GCC_Exception : not null GCC_Exception_Access);
 154    pragma No_Return (Unhandled_Except_Handler);
 155    pragma Export (C, Unhandled_Except_Handler,
 156                   "__gnat_unhandled_except_handler");
 157    --  Called for handle unhandled exceptions, ie the last chance handler
 158    --  on platforms (such as SEH) that never returns after throwing an
 159    --  exception. Called directly by gigi.
 160
 161    function CleanupUnwind_Handler
 162      (UW_Version   : Integer;
 163       UW_Phases    : Unwind_Action;
 164       UW_Eclass    : Exception_Class;
 165       UW_Exception : not null GCC_Exception_Access;
 166       UW_Context   : System.Address;
 167       UW_Argument  : System.Address) return Unwind_Reason_Code;
 168    pragma Import (C, CleanupUnwind_Handler,
 169                   "__gnat_cleanupunwind_handler");
 170    --  Hook called at each step of the forced unwinding we perform to trigger
 171    --  cleanups found during the propagation of an unhandled exception.
 172
 173    --  GCC runtime functions used. These are C non-void functions, actually,
 174    --  but we ignore the return values. See raise.c as to why we are using
 175    --  __gnat stubs for these.
 176
 177    procedure Unwind_RaiseException
 178      (UW_Exception : not null GCC_Exception_Access);
 179    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 180
 181    procedure Unwind_ForcedUnwind
 182      (UW_Exception : not null GCC_Exception_Access;
 183       UW_Handler   : System.Address;
 184       UW_Argument  : System.Address);
 185    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 186
 187    procedure Set_Exception_Parameter
 188      (Excep         : EOA;
 189       GCC_Exception : not null GCC_Exception_Access);
 190    pragma Export
 191      (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
 192    --  Called inserted by gigi to set the exception choice parameter from the
 193    --  gcc occurrence.
 194
 195    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
 196    --  Utility routine to initialize occurrence Excep from a foreign exception
 197    --  whose machine occurrence is Mo. The message is empty, the backtrace
 198    --  is empty too and the exception identity is Foreign_Exception.
 199
 200    --  Hooks called when entering/leaving an exception handler for a given
 201    --  occurrence, aimed at handling the stack of active occurrences. The
 202    --  calls are generated by gigi in tree_transform/N_Exception_Handler.
 203
 204    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
 205    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 206
 207    procedure End_Handler (GCC_Exception : GCC_Exception_Access);
 208    pragma Export (C, End_Handler, "__gnat_end_handler");
 209
 210    --------------------------------------------------------------------
 211    -- Accessors to Basic Components of a GNAT Exception Data Pointer --
 212    --------------------------------------------------------------------
 213
 214    --  As of today, these are only used by the C implementation of the GCC
 215    --  propagation personality routine to avoid having to rely on a C
 216    --  counterpart of the whole exception_data structure, which is both
 217    --  painful and error prone. These subprograms could be moved to a more
 218    --  widely visible location if need be.
 219
 220    function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
 221    pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
 222    pragma Warnings (Off, Is_Handled_By_Others);
 223
 224    function Language_For (E : Exception_Data_Ptr) return Character;
 225    pragma Export (C, Language_For, "__gnat_language_for");
 226
 227    function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
 228    pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
 229
 230    function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
 231      return Exception_Id;
 232    pragma Export (C, EID_For, "__gnat_eid_for");
 233
 234    ---------------------------------------------------------------------------
 235    -- Objects to materialize "others" and "all others" in the GCC EH tables --
 236    ---------------------------------------------------------------------------
 237
 238    --  Currently, these only have their address taken and compared so there is
 239    --  no real point having whole exception data blocks allocated. Note that
 240    --  there are corresponding declarations in gigi (trans.c) which must be
 241    --  kept properly synchronized.
 242
 243    Others_Value : constant Character := 'O';
 244    pragma Export (C, Others_Value, "__gnat_others_value");
 245
 246    All_Others_Value : constant Character := 'A';
 247    pragma Export (C, All_Others_Value, "__gnat_all_others_value");
 248
 249    Unhandled_Others_Value : constant Character := 'U';
 250    pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
 251    --  Special choice (emitted by gigi) to catch and notify unhandled
 252    --  exceptions on targets which always handle exceptions (such as SEH).
 253    --  The handler will simply call Unhandled_Except_Handler.
 254
 255    -------------------------
 256    -- Allocate_Occurrence --
 257    -------------------------
 258
 259    function Allocate_Occurrence return EOA is
 260       Res : GNAT_GCC_Exception_Access;
 261
 262    begin
 263       Res := New_Occurrence;
 264       Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
 265       Res.Occurrence.Machine_Occurrence := Res.all'Address;
 266
 267       return Res.Occurrence'Access;
 268    end Allocate_Occurrence;
 269
 270    --------------------------------
 271    -- GNAT_GCC_Exception_Cleanup --
 272    --------------------------------
 273
 274    procedure GNAT_GCC_Exception_Cleanup
 275      (Reason : Unwind_Reason_Code;
 276       Excep  : not null GNAT_GCC_Exception_Access)
 277    is
 278       pragma Unreferenced (Reason);
 279
 280       procedure Free is new Unchecked_Deallocation
 281         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 282
 283       Copy : GNAT_GCC_Exception_Access := Excep;
 284
 285    begin
 286       --  Simply free the memory
 287
 288       Free (Copy);
 289    end GNAT_GCC_Exception_Cleanup;
 290
 291    ----------------------------
 292    -- Set_Foreign_Occurrence --
 293    ----------------------------
 294
 295    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
 296    begin
 297       Excep.all := (
 298         Id                 => Foreign_Exception'Access,
 299         Machine_Occurrence => Mo,
 300         Msg                => <>,
 301         Msg_Length         => 0,
 302         Exception_Raised   => True,
 303         Pid                => Local_Partition_ID,
 304         Num_Tracebacks     => 0,
 305         Tracebacks         => <>);
 306    end Set_Foreign_Occurrence;
 307
 308    -------------------------
 309    -- Setup_Current_Excep --
 310    -------------------------
 311
 312    function Setup_Current_Excep
 313      (GCC_Exception : not null GCC_Exception_Access;
 314       Phase : Unwind_Action) return EOA
 315    is
 316       Excep : constant EOA := Get_Current_Excep.all;
 317
 318    begin
 319
 320       if GCC_Exception.Class = GNAT_Exception_Class then
 321
 322          --  Ada exception : latch the occurrence data in the Current
 323          --  Exception Buffer if needed and return a pointer to the original
 324          --  Ada exception object. This particular object was specifically
 325          --  allocated for this raise and is thus more precise than the fixed
 326          --  Current Exception Buffer address.
 327
 328          declare
 329             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 330                                 To_GNAT_GCC_Exception (GCC_Exception);
 331          begin
 332
 333             --  When reaching here during SEARCH_PHASE, no need to
 334             --  replicate the copy performed at the propagation start.
 335
 336             if Phase /= UA_SEARCH_PHASE then
 337                Excep.all := GNAT_Occurrence.Occurrence;
 338             end if;
 339             return GNAT_Occurrence.Occurrence'Access;
 340          end;
 341
 342       else
 343
 344          --  Foreign exception (caught by Ada handler, reaching here from
 345          --  personality routine) : The original exception object doesn't hold
 346          --  an Ada occurrence info.  Set the foreign data pointer in the
 347          --  Current Exception Buffer and return the address of the latter.
 348
 349          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 350
 351          return Excep;
 352       end if;
 353    end Setup_Current_Excep;
 354
 355    -------------------
 356    -- Begin_Handler --
 357    -------------------
 358
 359    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
 360       pragma Unreferenced (GCC_Exception);
 361    begin
 362       null;
 363    end Begin_Handler;
 364
 365    -----------------
 366    -- End_Handler --
 367    -----------------
 368
 369    procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
 370    begin
 371       if GCC_Exception /= null then
 372
 373          --  The exception might have been reraised, in this case the cleanup
 374          --  mustn't be called.
 375
 376          Unwind_DeleteException (GCC_Exception);
 377       end if;
 378    end End_Handler;
 379
 380    -----------------------------
 381    -- Reraise_GCC_Exception --
 382    -----------------------------
 383
 384    procedure Reraise_GCC_Exception
 385      (GCC_Exception : not null GCC_Exception_Access)
 386    is
 387    begin
 388       --  Simply propagate it
 389
 390       Propagate_GCC_Exception (GCC_Exception);
 391    end Reraise_GCC_Exception;
 392
 393    -----------------------------
 394    -- Propagate_GCC_Exception --
 395    -----------------------------
 396
 397    --  Call Unwind_RaiseException to actually throw, taking care of handling
 398    --  the two phase scheme it implements.
 399
 400    procedure Propagate_GCC_Exception
 401      (GCC_Exception : not null GCC_Exception_Access)
 402    is
 403       --  Acknowledge the current exception info now, before unwinding
 404       --  starts so it is available even from C++ handlers involved before
 405       --  our personality routine.
 406
 407       Excep : constant EOA :=
 408         Setup_Current_Excep (GCC_Exception, Phase => 0);
 409
 410    begin
 411       --  Perform a standard raise first. If a regular handler is found, it
 412       --  will be entered after all the intermediate cleanups have run. If
 413       --  there is no regular handler, it will return.
 414
 415       Unwind_RaiseException (GCC_Exception);
 416
 417       --  If we get here we know the exception is not handled, as otherwise
 418       --  Unwind_RaiseException arranges for the handler to be entered. Take
 419       --  the necessary steps to enable the debugger to gain control while the
 420       --  stack is still intact.
 421
 422       Notify_Unhandled_Exception (Excep);
 423
 424       --  Now, un a forced unwind to trigger cleanups. Control should not
 425       --  resume there, if there are cleanups and in any cases as the
 426       --  unwinding hook calls Unhandled_Exception_Terminate when end of
 427       --  stack is reached.
 428
 429       Unwind_ForcedUnwind
 430         (GCC_Exception,
 431          CleanupUnwind_Handler'Address,
 432          System.Null_Address);
 433
 434       --  We get here in case of error. The debugger has been notified before
 435       --  the second step above.
 436
 437       Unhandled_Except_Handler (GCC_Exception);
 438    end Propagate_GCC_Exception;
 439
 440    -------------------------
 441    -- Propagate_Exception --
 442    -------------------------
 443
 444    procedure Propagate_Exception (Excep : Exception_Occurrence) is
 445    begin
 446       Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
 447    end Propagate_Exception;
 448
 449    -----------------------------
 450    -- Set_Exception_Parameter --
 451    -----------------------------
 452
 453    procedure Set_Exception_Parameter
 454      (Excep         : EOA;
 455       GCC_Exception : not null GCC_Exception_Access)
 456    is
 457    begin
 458       --  Setup the exception occurrence
 459
 460       if GCC_Exception.Class = GNAT_Exception_Class then
 461
 462          --  From the GCC exception
 463
 464          declare
 465             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 466                                 To_GNAT_GCC_Exception (GCC_Exception);
 467          begin
 468             Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
 469          end;
 470
 471       else
 472          --  A default one
 473
 474          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 475       end if;
 476    end Set_Exception_Parameter;
 477
 478    ------------------------------
 479    -- Unhandled_Except_Handler --
 480    ------------------------------
 481
 482    procedure Unhandled_Except_Handler
 483      (GCC_Exception : not null GCC_Exception_Access)
 484    is
 485       Excep : EOA;
 486    begin
 487       Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE);
 488       Unhandled_Exception_Terminate (Excep);
 489    end Unhandled_Except_Handler;
 490
 491    -------------
 492    -- EID_For --
 493    -------------
 494
 495    function EID_For
 496      (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
 497    is
 498    begin
 499       return GNAT_Exception.Occurrence.Id;
 500    end EID_For;
 501
 502    ----------------------
 503    -- Foreign_Data_For --
 504    ----------------------
 505
 506    function Foreign_Data_For
 507      (E : SSL.Exception_Data_Ptr) return Address
 508    is
 509    begin
 510       return E.Foreign_Data;
 511    end Foreign_Data_For;
 512
 513    --------------------------
 514    -- Is_Handled_By_Others --
 515    --------------------------
 516
 517    function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
 518    begin
 519       return not E.all.Not_Handled_By_Others;
 520    end Is_Handled_By_Others;
 521
 522    ------------------
 523    -- Language_For --
 524    ------------------
 525
 526    function Language_For (E : SSL.Exception_Data_Ptr) return Character is
 527    begin
 528       return E.all.Lang;
 529    end Language_For;
 530
 531 end Exception_Propagation;