gcc/ada/a-exexpr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                     ADA.EXCEPTIONS.EXCEPTION_PROPAGATION                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2003 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Interfaces;
  35
  36 with Ada.Unchecked_Conversion;
  37 with Ada.Unchecked_Deallocation;
  38
  39 pragma Warnings (Off);
  40 --  Since several constructs give warnings in 3.14a1, including unreferenced
  41 --  variables and pragma Unreferenced itself.
  42
  43 separate (Ada.Exceptions)
  44 package body Exception_Propagation is
  45
  46    ------------------------------------------------
  47    -- Entities to interface with the GCC runtime --
  48    ------------------------------------------------
  49
  50    --  These come from "C++ ABI for Itanium: Exception handling", which is
  51    --  the reference for GCC. They are used only when we are relying on
  52    --  back-end tables for exception propagation, which in turn is currenly
  53    --  only the case for Zero_Cost_Exceptions in GNAT5.
  54
  55    --  Return codes from the GCC runtime functions used to propagate
  56    --  an exception.
  57
  58    type Unwind_Reason_Code is
  59      (URC_NO_REASON,
  60       URC_FOREIGN_EXCEPTION_CAUGHT,
  61       URC_PHASE2_ERROR,
  62       URC_PHASE1_ERROR,
  63       URC_NORMAL_STOP,
  64       URC_END_OF_STACK,
  65       URC_HANDLER_FOUND,
  66       URC_INSTALL_CONTEXT,
  67       URC_CONTINUE_UNWIND);
  68
  69    pragma Unreferenced
  70      (URC_FOREIGN_EXCEPTION_CAUGHT,
  71       URC_PHASE2_ERROR,
  72       URC_PHASE1_ERROR,
  73       URC_NORMAL_STOP,
  74       URC_END_OF_STACK,
  75       URC_HANDLER_FOUND,
  76       URC_INSTALL_CONTEXT,
  77       URC_CONTINUE_UNWIND);
  78
  79    pragma Convention (C, Unwind_Reason_Code);
  80
  81    --  Phase identifiers
  82
  83    type Unwind_Action is
  84      (UA_SEARCH_PHASE,
  85       UA_CLEANUP_PHASE,
  86       UA_HANDLER_FRAME,
  87       UA_FORCE_UNWIND);
  88
  89    for Unwind_Action use
  90       (UA_SEARCH_PHASE  => 1,
  91        UA_CLEANUP_PHASE => 2,
  92        UA_HANDLER_FRAME => 4,
  93        UA_FORCE_UNWIND  => 8);
  94
  95    pragma Convention (C, Unwind_Action);
  96
  97    --  Mandatory common header for any exception object handled by the
  98    --  GCC unwinding runtime.
  99
 100    subtype Exception_Class is Interfaces.Unsigned_64;
 101
 102    GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
 103    --  "GNU-Ada\0"
 104
 105    type Unwind_Exception is record
 106       Class    : Exception_Class := GNAT_Exception_Class;
 107       Cleanup  : System.Address  := System.Null_Address;
 108       Private1 : Integer;
 109       Private2 : Integer;
 110    end record;
 111
 112    pragma Convention (C, Unwind_Exception);
 113
 114    for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
 115    --  The C++ ABI mandates the common exception header to be at least
 116    --  doubleword aligned, and the libGCC implementation actually makes it
 117    --  maximally aligned (see unwind.h). We need to match this because:
 118
 119    --  1/ We pass pointers to such headers down to the underlying
 120    --     libGCC unwinder,
 121
 122    --  and
 123
 124    --  2/ The GNAT_GCC_Exception record below starts with this common
 125    --     common header and has a C counterpart which needs to be laid
 126    --     out identically in raise.c. If the alignment of the C and Ada
 127    --     common headers mismatch, their size may also differ, and the
 128    --     layouts may not match anymore.
 129
 130    ---------------------------------------------------------------
 131    --  GNAT specific entities to deal with the GCC eh circuitry --
 132    ---------------------------------------------------------------
 133
 134    --  A GNAT exception object to be dealt with by the personality routine
 135    --  called by the GCC unwinding runtime. This structure shall match the
 136    --  one in raise.c and is currently experimental as it might be merged
 137    --  with the GNAT runtime definition some day.
 138
 139    type GNAT_GCC_Exception is record
 140       Header : Unwind_Exception;
 141       --  ABI Exception header first.
 142
 143       Id : Exception_Id;
 144       --  GNAT Exception identifier. This is used by the personality
 145       --  routine to determine if the context it examines contains a
 146       --  handler for the exception beeing propagated.
 147
 148       Handled_By_Others : Boolean;
 149       --  Is this exception handled by "when others" ? This is used by the
 150       --  personality routine to determine if an "others" handler in the
 151       --  context it examines may catch the exception beeing propagated.
 152
 153       N_Cleanups_To_Trigger : Integer;
 154       --  Number of cleanup only frames encountered in SEARCH phase.
 155       --  This is used to control the forced unwinding triggered when
 156       --  no handler has been found.
 157
 158       Next_Exception : EOA;
 159       --  Used to create a linked list of exception occurrences.
 160    end record;
 161
 162    pragma Convention (C, GNAT_GCC_Exception);
 163
 164    type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
 165
 166    function To_GNAT_GCC_Exception is new
 167      Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);
 168
 169    procedure Free is new Unchecked_Deallocation
 170      (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
 171
 172    procedure Free is new Unchecked_Deallocation
 173      (Exception_Occurrence, EOA);
 174
 175    function Remove
 176      (Top   : EOA;
 177       Excep : GNAT_GCC_Exception_Access)
 178       return  Boolean;
 179    --  Remove Excep from the stack starting at Top.
 180    --  Return True if Excep was found and removed, false otherwise.
 181
 182    --  Hooks called when entering/leaving an exception handler for a given
 183    --  occurrence, aimed at handling the stack of active occurrences. The
 184    --  calls are generated by gigi in tree_transform/N_Exception_Handler.
 185
 186    procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
 187    pragma Export (C, Begin_Handler, "__gnat_begin_handler");
 188
 189    procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
 190    pragma Export (C, End_Handler, "__gnat_end_handler");
 191
 192    function CleanupUnwind_Handler
 193      (UW_Version   : Integer;
 194       UW_Phases    : Unwind_Action;
 195       UW_Eclass    : Exception_Class;
 196       UW_Exception : access GNAT_GCC_Exception;
 197       UW_Context   : System.Address;
 198       UW_Argument  : System.Address)
 199       return         Unwind_Reason_Code;
 200    --  Hook called at each step of the forced unwinding we perform to
 201    --  trigger cleanups found during the propagation of an unhandled
 202    --  exception.
 203
 204    --  GCC runtime functions used. These are C non-void functions, actually,
 205    --  but we ignore the return values. See raise.c as to why we are using
 206    --  __gnat stubs for these.
 207
 208    procedure Unwind_RaiseException
 209      (UW_Exception : access GNAT_GCC_Exception);
 210    pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
 211
 212    procedure Unwind_ForcedUnwind
 213      (UW_Exception : access GNAT_GCC_Exception;
 214       UW_Handler   : System.Address;
 215       UW_Argument  : System.Address);
 216    pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
 217
 218    ------------
 219    -- Remove --
 220    ------------
 221
 222    function Remove
 223      (Top   : EOA;
 224       Excep : GNAT_GCC_Exception_Access)
 225       return  Boolean
 226    is
 227       Prev          : GNAT_GCC_Exception_Access := null;
 228       Iter          : EOA := Top;
 229       GCC_Exception : GNAT_GCC_Exception_Access;
 230
 231    begin
 232       --  Pop stack
 233
 234       loop
 235          pragma Assert (Iter.Private_Data /= System.Null_Address);
 236
 237          GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);
 238
 239          if GCC_Exception = Excep then
 240             if Prev = null then
 241
 242                --  Special case for the top of the stack: shift the contents
 243                --  of the next item to the top, since top is at a fixed
 244                --  location and can't be changed.
 245
 246                Iter := GCC_Exception.Next_Exception;
 247
 248                if Iter = null then
 249
 250                   --  Stack is now empty
 251
 252                   Top.Private_Data := System.Null_Address;
 253
 254                else
 255                   Save_Occurrence_And_Private (Top.all, Iter.all);
 256                   Free (Iter);
 257                end if;
 258
 259             else
 260                Prev.Next_Exception := GCC_Exception.Next_Exception;
 261                Free (Iter);
 262             end if;
 263
 264             Free (GCC_Exception);
 265
 266             return True;
 267          end if;
 268
 269          exit when GCC_Exception.Next_Exception = null;
 270
 271          Prev := GCC_Exception;
 272          Iter := GCC_Exception.Next_Exception;
 273       end loop;
 274
 275       return False;
 276    end Remove;
 277
 278    ---------------------------
 279    -- CleanupUnwind_Handler --
 280    ---------------------------
 281
 282    function CleanupUnwind_Handler
 283      (UW_Version   : Integer;
 284       UW_Phases    : Unwind_Action;
 285       UW_Eclass    : Exception_Class;
 286       UW_Exception : access GNAT_GCC_Exception;
 287       UW_Context   : System.Address;
 288       UW_Argument  : System.Address)
 289       return         Unwind_Reason_Code
 290    is
 291    begin
 292       --  Terminate as soon as we know there is nothing more to run. The
 293       --  count is maintained by the personality routine.
 294
 295       if UW_Exception.N_Cleanups_To_Trigger = 0 then
 296          Unhandled_Exception_Terminate;
 297       end if;
 298
 299       --  We know there is at least one cleanup further up. Return so that it
 300       --  is searched and entered, after which Unwind_Resume will be called
 301       --  and this hook will gain control (with an updated count) again.
 302
 303       return URC_NO_REASON;
 304    end CleanupUnwind_Handler;
 305
 306    ---------------------
 307    -- Setup_Exception --
 308    ---------------------
 309
 310    --  Push the current exception occurrence on the stack before overriding it.
 311
 312    procedure Setup_Exception
 313      (Excep    : EOA;
 314       Current  : EOA;
 315       Reraised : Boolean := False)
 316    is
 317       Top           : constant EOA := Current;
 318       Next          : EOA;
 319       GCC_Exception : GNAT_GCC_Exception_Access;
 320
 321       --  Note that we make no use of the Reraised indication at this point.
 322
 323       --  The information is still passed around just in case of future needs,
 324       --  since we've already switched between using/not-using it a number of
 325       --  times.
 326
 327    begin
 328       --  If the current exception is not live, the stack is empty and there
 329       --  is nothing to do. Note that the stack always appears empty for
 330       --  mechanisms that do not require one. For the mechanism we implement
 331       --  in this unit, the initial Private_Data allocation for an occurrence
 332       --  is issued by Propagate_Exception.
 333
 334       if Top.Private_Data = System.Null_Address then
 335          return;
 336       end if;
 337
 338       --  Shift the contents of the Top of the stack in a freshly allocated
 339       --  entry, which leaves the room in the fixed Top entry available for the
 340       --  occurrence about to be propagated.
 341
 342       Next := new Exception_Occurrence;
 343       Save_Occurrence_And_Private (Next.all, Top.all);
 344
 345       --  Allocate Private_Data for the occurrence about to be propagated
 346       --  and link everything together.
 347
 348       GCC_Exception := new GNAT_GCC_Exception;
 349       GCC_Exception.Next_Exception := Next;
 350
 351       Top.Private_Data := GCC_Exception.all'Address;
 352
 353    end Setup_Exception;
 354
 355    -------------------
 356    -- Begin_Handler --
 357    -------------------
 358
 359    procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
 360    begin
 361       --  Every necessary operation related to the occurrence stack has
 362       --  already been performed by Propagate_Exception. This hook remains for
 363       --  potential future necessity in optimizing the overall scheme, as well
 364       --  a useful debugging tool.
 365       null;
 366    end Begin_Handler;
 367
 368    -----------------
 369    -- End_Handler --
 370    -----------------
 371
 372    procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
 373       Removed : Boolean;
 374
 375    begin
 376       Removed := Remove (Get_Current_Excep.all, GCC_Exception);
 377       pragma Assert (Removed);
 378    end End_Handler;
 379
 380    -------------------------
 381    -- Propagate_Exception --
 382    -------------------------
 383
 384    --  Build an object suitable for the libgcc processing and call
 385    --  Unwind_RaiseException to actually throw, taking care of handling
 386    --  the two phase scheme it implements.
 387
 388    procedure Propagate_Exception (From_Signal_Handler : Boolean) is
 389       Excep         : EOA := Get_Current_Excep.all;
 390       GCC_Exception : GNAT_GCC_Exception_Access;
 391
 392    begin
 393       if Excep.Private_Data = System.Null_Address then
 394          GCC_Exception := new GNAT_GCC_Exception;
 395          Excep.Private_Data := GCC_Exception.all'Address;
 396       else
 397          GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
 398       end if;
 399
 400       --  Fill in the useful flags for the personality routine called for each
 401       --  frame via Unwind_RaiseException below.
 402
 403       GCC_Exception.Id := Excep.Id;
 404       GCC_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others;
 405       GCC_Exception.N_Cleanups_To_Trigger := 0;
 406
 407       --  Compute the backtrace for this occurrence if the corresponding
 408       --  binder option has been set. Call_Chain takes care of the reraise
 409       --  case.
 410
 411       --  ??? Using Call_Chain here means we are going to walk up the stack
 412       --  once only for backtracing purposes before doing it again for the
 413       --  propagation per se.
 414
 415       --  The first inspection is much lighter, though, as it only requires
 416       --  partial unwinding of each frame. Additionally, although we could use
 417       --  the personality routine to record the addresses while propagating,
 418       --  this method has two drawbacks:
 419
 420       --  1) the trace is incomplete if the exception is handled since we
 421       --  don't walk past the frame with the handler,
 422
 423       --    and
 424
 425       --  2) we would miss the frames for which our personality routine is not
 426       --  called, e.g. if C or C++ calls are on the way.
 427
 428       Call_Chain (Excep);
 429
 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, control will get back to after the
 433       --  call, with N_Cleanups_To_Trigger set to the number of frames with
 434       --  cleanups found on the way up, and none of these already run.
 435
 436       Unwind_RaiseException (GCC_Exception);
 437
 438       --  If we get here we know the exception is not handled, as otherwise
 439       --  Unwind_RaiseException arranges for the handler to be entered. Take
 440       --  the necessary steps to enable the debugger to gain control while the
 441       --  stack is still intact.
 442
 443       Notify_Unhandled_Exception;
 444
 445       --  Now, if cleanups have been found, run a forced unwind to trigger
 446       --  them. Control should not resume there, as the unwinding hook calls
 447       --  Unhandled_Exception_Terminate as soon as the last cleanup has been
 448       --  triggered.
 449
 450       if GCC_Exception.N_Cleanups_To_Trigger /= 0 then
 451          Unwind_ForcedUnwind (GCC_Exception,
 452                               CleanupUnwind_Handler'Address,
 453                               System.Null_Address);
 454       end if;
 455
 456       --  We get here when there is no handler or cleanup to be run at
 457       --  all. The debugger has been notified before the second step above.
 458
 459       Unhandled_Exception_Terminate;
 460    end Propagate_Exception;
 461
 462    -----------
 463    -- Notes --
 464    -----------
 465
 466    --  The current model implemented for the stack of occurrences is a
 467    --  simplification of previous attempts, which all prooved to be flawed or
 468    --  would have needed significant additional circuitry to be made to work
 469    --  correctly.
 470
 471    --  We now represent every propagation by a new entry on the stack, which
 472    --  means that an exception occurrence may appear more than once (e.g. when
 473    --  it is reraised during the course of its own handler).
 474
 475    --  This may seem overcostly compared to the C++ model as implemented in
 476    --  the g++ v3 libstd. This is actually understandable when one considers
 477    --  the extra variations of possible run-time configurations induced by the
 478    --  freedom offered by the Save_Occurrence/Reraise_Occurrence public
 479    --  interface.
 480
 481    --  The basic point is that arranging for an occurrence to always appear at
 482    --  most once on the stack requires a way to determine if a given occurence
 483    --  is already there, which is not as easy as it might seem.
 484
 485    --  An attempt was made to use the Private_Data pointer for this purpose.
 486    --  It did not work because:
 487
 488    --  1/ The Private_Data has to be saved by Save_Occurrence to be usable
 489    --     as a key in case of a later reraise,
 490
 491    --  2/ There is no easy way to synchronize End_Handler for an occurrence
 492    --     and the data attached to potential copies, so these copies may end
 493    --     up pointing to stale data. Moreover ...
 494
 495    --  3/ The same address may be reused for different occurrences, which
 496    --     defeats the idea of using it as a key.
 497
 498    --  The example below illustrates:
 499
 500    --  Saved_CE : Exception_Occurrence;
 501    --
 502    --  begin
 503    --    raise Constraint_Error;
 504    --  exception
 505    --    when CE: others =>
 506    --      Save_Occurrence (Saved_CE, CE);      <= Saved_CE.PDA = CE.PDA
 507    --  end;
 508    --
 509    --                                           <= Saved_CE.PDA is stale (!)
 510    --
 511    --  begin
 512    --    raise Program_Error;                   <= Saved_CE.PDA = PE.PDA (!!)
 513    --  exception
 514    --    when others =>
 515    --      Reraise_Occurrence (Saved_CE);
 516    --  end;
 517
 518    --  Not releasing the Private_Data via End_Handler could be an option,
 519    --  but making this to work while still avoiding memory leaks is far
 520    --  from trivial.
 521
 522    --  The current scheme has the advantage of beeing simple, and induces
 523    --  extra costs only in reraise cases which is acceptable.
 524
 525 end Exception_Propagation;