File : a-exexpr-gcc.adb
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 -- --
19 -- --
20 -- --
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
34 with Ada.Unchecked_Conversion;
35 with Ada.Unchecked_Deallocation;
36
37 with System.Storage_Elements; use System.Storage_Elements;
38 with System.Exceptions.Machine; use System.Exceptions.Machine;
39
40 separate (Ada.Exceptions)
41 package 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
438 end Exception_Propagation;