1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
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 --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This is the version using the GCC EH mechanism
34 with Ada.Unchecked_Conversion;
35 with Ada.Unchecked_Deallocation;
37 with System.Storage_Elements; use System.Storage_Elements;
39 separate (Ada.Exceptions)
40 package body Exception_Propagation is
44 ------------------------------------------------
45 -- Entities to interface with the GCC runtime --
46 ------------------------------------------------
48 -- These come from "C++ ABI for Itanium: Exception handling", which is the
51 -- Return codes from GCC runtime functions used to propagate an exception
53 type Unwind_Reason_Code is
55 URC_FOREIGN_EXCEPTION_CAUGHT,
66 URC_FOREIGN_EXCEPTION_CAUGHT,
75 pragma Convention (C, Unwind_Reason_Code);
79 type Unwind_Action is new Integer;
80 pragma Convention (C, Unwind_Action);
82 UA_SEARCH_PHASE : constant Unwind_Action := 1;
83 UA_CLEANUP_PHASE : constant Unwind_Action := 2;
84 UA_HANDLER_FRAME : constant Unwind_Action := 4;
85 UA_FORCE_UNWIND : constant Unwind_Action := 8;
86 UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension
95 -- Mandatory common header for any exception object handled by the
96 -- GCC unwinding runtime.
98 type Exception_Class is mod 2 ** 64;
100 GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
103 type Unwind_Word is mod 2 ** System.Word_Size;
104 for Unwind_Word'Size use System.Word_Size;
105 -- Map the corresponding C type used in Unwind_Exception below
107 type Unwind_Exception is record
108 Class : Exception_Class;
109 Cleanup : System.Address;
110 Private1 : Unwind_Word;
111 Private2 : Unwind_Word;
113 -- Usual exception structure has only two private fields, but the SEH
114 -- one has six. To avoid making this file more complex, we use six
115 -- fields on all platforms, wasting a few bytes on some.
117 Private3 : Unwind_Word;
118 Private4 : Unwind_Word;
119 Private5 : Unwind_Word;
120 Private6 : Unwind_Word;
122 pragma Convention (C, Unwind_Exception);
123 -- Map the GCC struct used for exception handling
125 for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
126 -- The C++ ABI mandates the common exception header to be at least
127 -- doubleword aligned, and the libGCC implementation actually makes it
128 -- maximally aligned (see unwind.h). See additional comments on the
131 type GCC_Exception_Access is access all Unwind_Exception;
132 -- Pointer to a GCC exception. Do not use convention C as on VMS this
133 -- would imply the use of 32-bits pointers.
135 procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
136 pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
137 -- Procedure to free any GCC exception
139 Foreign_Exception : aliased System.Standard_Library.Exception_Data;
140 pragma Import (Ada, Foreign_Exception,
141 "system__exceptions__foreign_exception");
142 -- Id for foreign exceptions
144 --------------------------------------------------------------
145 -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
146 --------------------------------------------------------------
148 -- A GNAT exception object to be dealt with by the personality routine
149 -- called by the GCC unwinding runtime.
151 type GNAT_GCC_Exception is record
152 Header : Unwind_Exception;
153 -- ABI Exception header first
155 Occurrence : aliased Exception_Occurrence;
156 -- The Ada occurrence
159 pragma Convention (C, GNAT_GCC_Exception);
161 -- There is a subtle issue with the common header alignment, since the C
162 -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
163 -- Standard'Maximum_Alignment, and those two values don't quite represent
164 -- the same concepts and so may be decoupled someday. One typical reason
165 -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
166 -- allocator guarantees, and there are extra costs involved in allocating
167 -- objects aligned to such factors.
169 -- To deal with the potential alignment differences between the C and Ada
170 -- representations, the Ada part of the whole structure is only accessed
171 -- by the personality routine through the accessors declared below. Ada
172 -- specific fields are thus always accessed through consistent layout, and
173 -- we expect the actual alignment to always be large enough to avoid traps
174 -- from the C accesses to the common header. Besides, accessors alleviate
175 -- the need for a C struct whole counterpart, both painful and error-prone
176 -- to maintain anyway.
178 type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
180 function To_GCC_Exception is new
181 Unchecked_Conversion (System.Address, GCC_Exception_Access);
183 function To_GNAT_GCC_Exception is new
184 Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
186 procedure GNAT_GCC_Exception_Cleanup
187 (Reason : Unwind_Reason_Code;
188 Excep : not null GNAT_GCC_Exception_Access);
189 pragma Convention (C, GNAT_GCC_Exception_Cleanup);
190 -- Procedure called when a GNAT GCC exception is free.
192 procedure Propagate_GCC_Exception
193 (GCC_Exception : not null GCC_Exception_Access);
194 pragma No_Return (Propagate_GCC_Exception);
195 -- Propagate a GCC exception
197 procedure Reraise_GCC_Exception
198 (GCC_Exception : not null GCC_Exception_Access);
199 pragma No_Return (Reraise_GCC_Exception);
200 pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
201 -- Called to implement raise without exception, ie reraise. Called
202 -- directly from gigi.
204 function Setup_Current_Excep
205 (GCC_Exception : not null GCC_Exception_Access) return EOA;
206 pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
207 -- Write Get_Current_Excep.all from GCC_Exception. Called by the
208 -- personality routine.
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.
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 trigger
229 -- cleanups found during the propagation of an unhandled exception.
231 -- GCC runtime functions used. These are C non-void functions, actually,
232 -- but we ignore the return values. See raise.c as to why we are using
233 -- __gnat stubs for these.
235 procedure Unwind_RaiseException
236 (UW_Exception : not null GCC_Exception_Access);
237 pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
239 procedure Unwind_ForcedUnwind
240 (UW_Exception : not null GCC_Exception_Access;
241 UW_Handler : System.Address;
242 UW_Argument : System.Address);
243 pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
245 procedure Set_Exception_Parameter
247 GCC_Exception : not null GCC_Exception_Access);
249 (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
250 -- Called inserted by gigi to initialize the exception parameter
252 procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
253 -- Utility routine to initialize occurrence Excep from a foreign exception
254 -- whose machine occurrence is Mo. The message is empty, the backtrace
255 -- is empty too and the exception identity is Foreign_Exception.
257 -- Hooks called when entering/leaving an exception handler for a given
258 -- occurrence, aimed at handling the stack of active occurrences. The
259 -- calls are generated by gigi in tree_transform/N_Exception_Handler.
261 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
262 pragma Export (C, Begin_Handler, "__gnat_begin_handler");
264 procedure End_Handler (GCC_Exception : GCC_Exception_Access);
265 pragma Export (C, End_Handler, "__gnat_end_handler");
267 --------------------------------------------------------------------
268 -- Accessors to Basic Components of a GNAT Exception Data Pointer --
269 --------------------------------------------------------------------
271 -- As of today, these are only used by the C implementation of the GCC
272 -- propagation personality routine to avoid having to rely on a C
273 -- counterpart of the whole exception_data structure, which is both
274 -- painful and error prone. These subprograms could be moved to a more
275 -- widely visible location if need be.
277 function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
278 pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
279 pragma Warnings (Off, Is_Handled_By_Others);
281 function Language_For (E : Exception_Data_Ptr) return Character;
282 pragma Export (C, Language_For, "__gnat_language_for");
284 function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
285 pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
287 function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
289 pragma Export (C, EID_For, "__gnat_eid_for");
291 ---------------------------------------------------------------------------
292 -- Objects to materialize "others" and "all others" in the GCC EH tables --
293 ---------------------------------------------------------------------------
295 -- Currently, these only have their address taken and compared so there is
296 -- no real point having whole exception data blocks allocated. Note that
297 -- there are corresponding declarations in gigi (trans.c) which must be
298 -- kept properly synchronized.
300 Others_Value : constant Character := 'O';
301 pragma Export (C, Others_Value, "__gnat_others_value");
303 All_Others_Value : constant Character := 'A';
304 pragma Export (C, All_Others_Value, "__gnat_all_others_value");
306 Unhandled_Others_Value : constant Character := 'U';
307 pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
308 -- Special choice (emitted by gigi) to catch and notify unhandled
309 -- exceptions on targets which always handle exceptions (such as SEH).
310 -- The handler will simply call Unhandled_Except_Handler.
312 -------------------------
313 -- Allocate_Occurrence --
314 -------------------------
316 function Allocate_Occurrence return EOA is
317 Res : GNAT_GCC_Exception_Access;
321 new GNAT_GCC_Exception'
322 (Header => (Class => GNAT_Exception_Class,
323 Cleanup => GNAT_GCC_Exception_Cleanup'Address,
325 Occurrence => (others => <>));
326 Res.Occurrence.Machine_Occurrence := Res.all'Address;
328 return Res.Occurrence'Access;
329 end Allocate_Occurrence;
331 --------------------------------
332 -- GNAT_GCC_Exception_Cleanup --
333 --------------------------------
335 procedure GNAT_GCC_Exception_Cleanup
336 (Reason : Unwind_Reason_Code;
337 Excep : not null GNAT_GCC_Exception_Access)
339 pragma Unreferenced (Reason);
341 procedure Free is new Unchecked_Deallocation
342 (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
344 Copy : GNAT_GCC_Exception_Access := Excep;
347 -- Simply free the memory
350 end GNAT_GCC_Exception_Cleanup;
352 ----------------------------
353 -- Set_Foreign_Occurrence --
354 ----------------------------
356 procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
359 Id => Foreign_Exception'Access,
360 Machine_Occurrence => Mo,
363 Exception_Raised => True,
364 Pid => Local_Partition_ID,
367 end Set_Foreign_Occurrence;
369 -------------------------
370 -- Setup_Current_Excep --
371 -------------------------
373 function Setup_Current_Excep
374 (GCC_Exception : not null GCC_Exception_Access) return EOA
376 Excep : constant EOA := Get_Current_Excep.all;
379 -- Setup the exception occurrence
381 if GCC_Exception.Class = GNAT_Exception_Class then
383 -- From the GCC exception
386 GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
387 To_GNAT_GCC_Exception (GCC_Exception);
389 Excep.all := GNAT_Occurrence.Occurrence;
390 return GNAT_Occurrence.Occurrence'Access;
396 Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
400 end Setup_Current_Excep;
406 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
407 pragma Unreferenced (GCC_Exception);
416 procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
418 if GCC_Exception /= null then
420 -- The exception might have been reraised, in this case the cleanup
421 -- mustn't be called.
423 Unwind_DeleteException (GCC_Exception);
427 -----------------------------
428 -- Reraise_GCC_Exception --
429 -----------------------------
431 procedure Reraise_GCC_Exception
432 (GCC_Exception : not null GCC_Exception_Access)
435 -- Simply propagate it
437 Propagate_GCC_Exception (GCC_Exception);
438 end Reraise_GCC_Exception;
440 -----------------------------
441 -- Propagate_GCC_Exception --
442 -----------------------------
444 -- Call Unwind_RaiseException to actually throw, taking care of handling
445 -- the two phase scheme it implements.
447 procedure Propagate_GCC_Exception
448 (GCC_Exception : not null GCC_Exception_Access)
453 -- Perform a standard raise first. If a regular handler is found, it
454 -- will be entered after all the intermediate cleanups have run. If
455 -- there is no regular handler, it will return.
457 Unwind_RaiseException (GCC_Exception);
459 -- If we get here we know the exception is not handled, as otherwise
460 -- Unwind_RaiseException arranges for the handler to be entered. Take
461 -- the necessary steps to enable the debugger to gain control while the
462 -- stack is still intact.
464 Excep := Setup_Current_Excep (GCC_Exception);
465 Notify_Unhandled_Exception (Excep);
467 -- Now, un a forced unwind to trigger cleanups. Control should not
468 -- resume there, if there are cleanups and in any cases as the
469 -- unwinding hook calls Unhandled_Exception_Terminate when end of
474 CleanupUnwind_Handler'Address,
475 System.Null_Address);
477 -- We get here in case of error. The debugger has been notified before
478 -- the second step above.
480 Unhandled_Except_Handler (GCC_Exception);
481 end Propagate_GCC_Exception;
483 -------------------------
484 -- Propagate_Exception --
485 -------------------------
487 procedure Propagate_Exception (Excep : EOA) is
489 Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
490 end Propagate_Exception;
492 -----------------------------
493 -- Set_Exception_Parameter --
494 -----------------------------
496 procedure Set_Exception_Parameter
498 GCC_Exception : not null GCC_Exception_Access)
501 -- Setup the exception occurrence
503 if GCC_Exception.Class = GNAT_Exception_Class then
505 -- From the GCC exception
508 GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
509 To_GNAT_GCC_Exception (GCC_Exception);
511 Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
517 Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
519 end Set_Exception_Parameter;
521 ------------------------------
522 -- Unhandled_Except_Handler --
523 ------------------------------
525 procedure Unhandled_Except_Handler
526 (GCC_Exception : not null GCC_Exception_Access)
530 Excep := Setup_Current_Excep (GCC_Exception);
531 Unhandled_Exception_Terminate (Excep);
532 end Unhandled_Except_Handler;
539 (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
542 return GNAT_Exception.Occurrence.Id;
545 ----------------------
546 -- Foreign_Data_For --
547 ----------------------
549 function Foreign_Data_For
550 (E : SSL.Exception_Data_Ptr) return Address
553 return E.Foreign_Data;
554 end Foreign_Data_For;
556 --------------------------
557 -- Is_Handled_By_Others --
558 --------------------------
560 function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
562 return not E.all.Not_Handled_By_Others;
563 end Is_Handled_By_Others;
569 function Language_For (E : SSL.Exception_Data_Ptr) return Character is
574 end Exception_Propagation;