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 33 34with Ada.Unchecked_Conversion; 35with Ada.Unchecked_Deallocation; 36 37with System.Storage_Elements; use System.Storage_Elements; 38with System.Exceptions.Machine; use System.Exceptions.Machine; 39 40separate (Ada.Exceptions) 41package 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 439end Exception_Propagation; 440