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