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