gcc/ada/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-2016, 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 with System.Exceptions.Machine; use System.Exceptions.Machine;
  39
  40 separate (Ada.Exceptions)
  41 package body Exception_Propagation is
  42
  43    use Exception_Traces;
  44
  45    Foreign_Exception : aliased System.Standard_Library.Exception_Data;
  46    pragma Import (Ada, Foreign_Exception,
  47                   "system__exceptions__foreign_exception");
  48    --  Id for foreign exceptions
  49
  50    --------------------------------------------------------------
  51    -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
  52    --------------------------------------------------------------
  53
  54    procedure GNAT_GCC_Exception_Cleanup
  55      (Reason : Unwind_Reason_Code;
  56       Excep  : not null GNAT_GCC_Exception_Access);
  57    pragma Convention (C, GNAT_GCC_Exception_Cleanup);
  58    --  Procedure called when a GNAT GCC exception is free.
  59
  60    procedure Propagate_GCC_Exception
  61      (GCC_Exception : not null GCC_Exception_Access);
  62    pragma No_Return (Propagate_GCC_Exception);
  63    --  Propagate a GCC exception
  64
  65    procedure Reraise_GCC_Exception
  66      (GCC_Exception : not null GCC_Exception_Access);
  67    pragma No_Return (Reraise_GCC_Exception);
  68    pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
  69    --  Called to implement raise without exception, ie reraise. Called
  70    --  directly from gigi.
  71
  72    function Setup_Current_Excep
  73      (GCC_Exception : not null GCC_Exception_Access) return EOA;
  74    pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
  75    --  Write Get_Current_Excep.all from GCC_Exception. Called by the
  76    --  personality routine.
  77
  78    procedure Unhandled_Except_Handler
  79      (GCC_Exception : not null GCC_Exception_Access);
  80    pragma No_Return (Unhandled_Except_Handler);
  81    pragma Export (C, Unhandled_Except_Handler,
  82                   "__gnat_unhandled_except_handler");
  83    --  Called for handle unhandled exceptions, ie the last chance handler
  84    --  on platforms (such as SEH) that never returns after throwing an
  85    --  exception. Called directly by gigi.
  86
  87    function CleanupUnwind_Handler
  88      (UW_Version   : Integer;
  89       UW_Phases    : Unwind_Action;
  90       UW_Eclass    : Exception_Class;
  91       UW_Exception : not null GCC_Exception_Access;
  92       UW_Context   : System.Address;
  93       UW_Argument  : System.Address) return Unwind_Reason_Code;
  94    pragma Import (C, CleanupUnwind_Handler,
  95                   "__gnat_cleanupunwind_handler");
  96    --  Hook called at each step of the forced unwinding we perform to trigger
  97    --  cleanups found during the propagation of an unhandled exception.
  98
  99    --  GCC runtime functions used. These are C non-void functions, actually,
 100    --  but we ignore the return values. See raise.c as to why we are using
 101    --  __gnat stubs for these.
 102
 103    procedure Unwind_RaiseException
 104      (UW_Exception : not null GCC_Exception_Access);
 105    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 106
 107    procedure Unwind_ForcedUnwind
 108      (UW_Exception : not null GCC_Exception_Access;
 109       UW_Handler   : System.Address;
 110       UW_Argument  : System.Address);
 111    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 112
 113    procedure Set_Exception_Parameter
 114      (Excep         : EOA;
 115       GCC_Exception : not null GCC_Exception_Access);
 116    pragma Export
 117      (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
 118    --  Called inserted by gigi to set the exception choice parameter from the
 119    --  gcc occurrence.
 120
 121    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
 122    --  Utility routine to initialize occurrence Excep from a foreign exception
 123    --  whose machine occurrence is Mo. The message is empty, the backtrace
 124    --  is empty too and the exception identity is Foreign_Exception.
 125
 126    --  Hooks called when entering/leaving an exception handler for a given
 127    --  occurrence, aimed at handling the stack of active occurrences. The
 128    --  calls are generated by gigi in tree_transform/N_Exception_Handler.
 129
 130    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
 131    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 132
 133    procedure End_Handler (GCC_Exception : GCC_Exception_Access);
 134    pragma Export (C, End_Handler, "__gnat_end_handler");
 135
 136    --------------------------------------------------------------------
 137    -- Accessors to Basic Components of a GNAT Exception Data Pointer --
 138    --------------------------------------------------------------------
 139
 140    --  As of today, these are only used by the C implementation of the GCC
 141    --  propagation personality routine to avoid having to rely on a C
 142    --  counterpart of the whole exception_data structure, which is both
 143    --  painful and error prone. These subprograms could be moved to a more
 144    --  widely visible location if need be.
 145
 146    function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
 147    pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
 148    pragma Warnings (Off, Is_Handled_By_Others);
 149
 150    function Language_For (E : Exception_Data_Ptr) return Character;
 151    pragma Export (C, Language_For, "__gnat_language_for");
 152
 153    function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
 154    pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
 155
 156    function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
 157      return Exception_Id;
 158    pragma Export (C, EID_For, "__gnat_eid_for");
 159
 160    ---------------------------------------------------------------------------
 161    -- Objects to materialize "others" and "all others" in the GCC EH tables --
 162    ---------------------------------------------------------------------------
 163
 164    --  Currently, these only have their address taken and compared so there is
 165    --  no real point having whole exception data blocks allocated. Note that
 166    --  there are corresponding declarations in gigi (trans.c) which must be
 167    --  kept properly synchronized.
 168
 169    Others_Value : constant Character := 'O';
 170    pragma Export (C, Others_Value, "__gnat_others_value");
 171
 172    All_Others_Value : constant Character := 'A';
 173    pragma Export (C, All_Others_Value, "__gnat_all_others_value");
 174
 175    Unhandled_Others_Value : constant Character := 'U';
 176    pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
 177    --  Special choice (emitted by gigi) to catch and notify unhandled
 178    --  exceptions on targets which always handle exceptions (such as SEH).
 179    --  The handler will simply call Unhandled_Except_Handler.
 180
 181    -------------------------
 182    -- Allocate_Occurrence --
 183    -------------------------
 184
 185    function Allocate_Occurrence return EOA is
 186       Res : GNAT_GCC_Exception_Access;
 187
 188    begin
 189       Res := New_Occurrence;
 190       Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
 191       Res.Occurrence.Machine_Occurrence := Res.all'Address;
 192
 193       return Res.Occurrence'Access;
 194    end Allocate_Occurrence;
 195
 196    --------------------------------
 197    -- GNAT_GCC_Exception_Cleanup --
 198    --------------------------------
 199
 200    procedure GNAT_GCC_Exception_Cleanup
 201      (Reason : Unwind_Reason_Code;
 202       Excep  : not null GNAT_GCC_Exception_Access)
 203    is
 204       pragma Unreferenced (Reason);
 205
 206       procedure Free is new Unchecked_Deallocation
 207         (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 208
 209       Copy : GNAT_GCC_Exception_Access := Excep;
 210
 211    begin
 212       --  Simply free the memory
 213
 214       Free (Copy);
 215    end GNAT_GCC_Exception_Cleanup;
 216
 217    ----------------------------
 218    -- Set_Foreign_Occurrence --
 219    ----------------------------
 220
 221    procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
 222    begin
 223       Excep.all := (
 224         Id                 => Foreign_Exception'Access,
 225         Machine_Occurrence => Mo,
 226         Msg                => <>,
 227         Msg_Length         => 0,
 228         Exception_Raised   => True,
 229         Pid                => Local_Partition_ID,
 230         Num_Tracebacks     => 0,
 231         Tracebacks         => <>);
 232    end Set_Foreign_Occurrence;
 233
 234    -------------------------
 235    -- Setup_Current_Excep --
 236    -------------------------
 237
 238    function Setup_Current_Excep
 239      (GCC_Exception : not null GCC_Exception_Access) return EOA
 240    is
 241       Excep : constant EOA := Get_Current_Excep.all;
 242
 243    begin
 244       --  Setup the exception occurrence
 245
 246       if GCC_Exception.Class = GNAT_Exception_Class then
 247
 248          --  From the GCC exception
 249
 250          declare
 251             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 252                                 To_GNAT_GCC_Exception (GCC_Exception);
 253          begin
 254             Excep.all := GNAT_Occurrence.Occurrence;
 255             return GNAT_Occurrence.Occurrence'Access;
 256          end;
 257
 258       else
 259          --  A default one
 260
 261          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 262
 263          return Excep;
 264       end if;
 265    end Setup_Current_Excep;
 266
 267    -------------------
 268    -- Begin_Handler --
 269    -------------------
 270
 271    procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
 272       pragma Unreferenced (GCC_Exception);
 273    begin
 274       null;
 275    end Begin_Handler;
 276
 277    -----------------
 278    -- End_Handler --
 279    -----------------
 280
 281    procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
 282    begin
 283       if GCC_Exception /= null then
 284
 285          --  The exception might have been reraised, in this case the cleanup
 286          --  mustn't be called.
 287
 288          Unwind_DeleteException (GCC_Exception);
 289       end if;
 290    end End_Handler;
 291
 292    -----------------------------
 293    -- Reraise_GCC_Exception --
 294    -----------------------------
 295
 296    procedure Reraise_GCC_Exception
 297      (GCC_Exception : not null GCC_Exception_Access)
 298    is
 299    begin
 300       --  Simply propagate it
 301
 302       Propagate_GCC_Exception (GCC_Exception);
 303    end Reraise_GCC_Exception;
 304
 305    -----------------------------
 306    -- Propagate_GCC_Exception --
 307    -----------------------------
 308
 309    --  Call Unwind_RaiseException to actually throw, taking care of handling
 310    --  the two phase scheme it implements.
 311
 312    procedure Propagate_GCC_Exception
 313      (GCC_Exception : not null GCC_Exception_Access)
 314    is
 315       Excep : EOA;
 316
 317    begin
 318       --  Perform a standard raise first. If a regular handler is found, it
 319       --  will be entered after all the intermediate cleanups have run. If
 320       --  there is no regular handler, it will return.
 321
 322       Unwind_RaiseException (GCC_Exception);
 323
 324       --  If we get here we know the exception is not handled, as otherwise
 325       --  Unwind_RaiseException arranges for the handler to be entered. Take
 326       --  the necessary steps to enable the debugger to gain control while the
 327       --  stack is still intact.
 328
 329       Excep := Setup_Current_Excep (GCC_Exception);
 330       Notify_Unhandled_Exception (Excep);
 331
 332       --  Now, un a forced unwind to trigger cleanups. Control should not
 333       --  resume there, if there are cleanups and in any cases as the
 334       --  unwinding hook calls Unhandled_Exception_Terminate when end of
 335       --  stack is reached.
 336
 337       Unwind_ForcedUnwind
 338         (GCC_Exception,
 339          CleanupUnwind_Handler'Address,
 340          System.Null_Address);
 341
 342       --  We get here in case of error. The debugger has been notified before
 343       --  the second step above.
 344
 345       Unhandled_Except_Handler (GCC_Exception);
 346    end Propagate_GCC_Exception;
 347
 348    -------------------------
 349    -- Propagate_Exception --
 350    -------------------------
 351
 352    procedure Propagate_Exception (Excep : EOA) is
 353    begin
 354       Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
 355    end Propagate_Exception;
 356
 357    -----------------------------
 358    -- Set_Exception_Parameter --
 359    -----------------------------
 360
 361    procedure Set_Exception_Parameter
 362      (Excep         : EOA;
 363       GCC_Exception : not null GCC_Exception_Access)
 364    is
 365    begin
 366       --  Setup the exception occurrence
 367
 368       if GCC_Exception.Class = GNAT_Exception_Class then
 369
 370          --  From the GCC exception
 371
 372          declare
 373             GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
 374                                 To_GNAT_GCC_Exception (GCC_Exception);
 375          begin
 376             Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
 377          end;
 378
 379       else
 380          --  A default one
 381
 382          Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
 383       end if;
 384    end Set_Exception_Parameter;
 385
 386    ------------------------------
 387    -- Unhandled_Except_Handler --
 388    ------------------------------
 389
 390    procedure Unhandled_Except_Handler
 391      (GCC_Exception : not null GCC_Exception_Access)
 392    is
 393       Excep : EOA;
 394    begin
 395       Excep := Setup_Current_Excep (GCC_Exception);
 396       Unhandled_Exception_Terminate (Excep);
 397    end Unhandled_Except_Handler;
 398
 399    -------------
 400    -- EID_For --
 401    -------------
 402
 403    function EID_For
 404      (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
 405    is
 406    begin
 407       return GNAT_Exception.Occurrence.Id;
 408    end EID_For;
 409
 410    ----------------------
 411    -- Foreign_Data_For --
 412    ----------------------
 413
 414    function Foreign_Data_For
 415      (E : SSL.Exception_Data_Ptr) return Address
 416    is
 417    begin
 418       return E.Foreign_Data;
 419    end Foreign_Data_For;
 420
 421    --------------------------
 422    -- Is_Handled_By_Others --
 423    --------------------------
 424
 425    function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
 426    begin
 427       return not E.all.Not_Handled_By_Others;
 428    end Is_Handled_By_Others;
 429
 430    ------------------
 431    -- Language_For --
 432    ------------------
 433
 434    function Language_For (E : SSL.Exception_Data_Ptr) return Character is
 435    begin
 436       return E.all.Lang;
 437    end Language_For;
 438
 439 end Exception_Propagation;