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-2019, 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 83with Ada.Unchecked_Conversion; 84with Ada.Unchecked_Deallocation; 85 86with System.Storage_Elements; use System.Storage_Elements; 87with System.Exceptions.Machine; use System.Exceptions.Machine; 88 89separate (Ada.Exceptions) 90package 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 531end Exception_Propagation; 532