Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / a-exexpr-gcc.adb
blob178b7e375f653e4a12931bbd55688bb8b458b2ec
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-2012, 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 ------------------------------------------------------------------------------
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
42 use Exception_Traces;
44 ------------------------------------------------
45 -- Entities to interface with the GCC runtime --
46 ------------------------------------------------
48 -- These come from "C++ ABI for Itanium: Exception handling", which is
49 -- the reference for GCC.
51 -- Return codes from the GCC runtime functions used to propagate
52 -- an exception.
54 type Unwind_Reason_Code is
55 (URC_NO_REASON,
56 URC_FOREIGN_EXCEPTION_CAUGHT,
57 URC_PHASE2_ERROR,
58 URC_PHASE1_ERROR,
59 URC_NORMAL_STOP,
60 URC_END_OF_STACK,
61 URC_HANDLER_FOUND,
62 URC_INSTALL_CONTEXT,
63 URC_CONTINUE_UNWIND);
65 pragma Unreferenced
66 (URC_NO_REASON,
67 URC_FOREIGN_EXCEPTION_CAUGHT,
68 URC_PHASE2_ERROR,
69 URC_PHASE1_ERROR,
70 URC_NORMAL_STOP,
71 URC_END_OF_STACK,
72 URC_HANDLER_FOUND,
73 URC_INSTALL_CONTEXT,
74 URC_CONTINUE_UNWIND);
76 pragma Convention (C, Unwind_Reason_Code);
78 -- Phase identifiers
80 type Unwind_Action is new Integer;
81 pragma Convention (C, Unwind_Action);
83 UA_SEARCH_PHASE : constant Unwind_Action := 1;
84 UA_CLEANUP_PHASE : constant Unwind_Action := 2;
85 UA_HANDLER_FRAME : constant Unwind_Action := 4;
86 UA_FORCE_UNWIND : constant Unwind_Action := 8;
87 UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension
89 pragma Unreferenced
90 (UA_SEARCH_PHASE,
91 UA_CLEANUP_PHASE,
92 UA_HANDLER_FRAME,
93 UA_FORCE_UNWIND,
94 UA_END_OF_STACK);
96 -- Mandatory common header for any exception object handled by the
97 -- GCC unwinding runtime.
99 type Exception_Class is mod 2 ** 64;
101 GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
102 -- "GNU-Ada\0"
104 type Unwind_Word is mod 2 ** System.Word_Size;
105 for Unwind_Word'Size use System.Word_Size;
106 -- Map the corresponding C type used in Unwind_Exception below
108 type Unwind_Exception is record
109 Class : Exception_Class;
110 Cleanup : System.Address;
111 Private1 : Unwind_Word;
112 Private2 : Unwind_Word;
114 -- Usual exception structure has only two private fields, but the SEH
115 -- one has six. To avoid making this file more complex, we use six
116 -- fields on all platforms, wasting a few bytes on some.
118 Private3 : Unwind_Word;
119 Private4 : Unwind_Word;
120 Private5 : Unwind_Word;
121 Private6 : Unwind_Word;
122 end record;
123 pragma Convention (C, Unwind_Exception);
124 -- Map the GCC struct used for exception handling
126 for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
127 -- The C++ ABI mandates the common exception header to be at least
128 -- doubleword aligned, and the libGCC implementation actually makes it
129 -- maximally aligned (see unwind.h). See additional comments on the
130 -- alignment below.
132 type GCC_Exception_Access is access all Unwind_Exception;
133 -- Pointer to a GCC exception. Do not use convention C as on VMS this
134 -- would imply the use of 32-bits pointers.
136 procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
137 pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
138 -- Procedure to free any GCC exception
140 Foreign_Exception : aliased System.Standard_Library.Exception_Data;
141 pragma Import (Ada, Foreign_Exception,
142 "system__exceptions__foreign_exception");
143 -- Id for foreign exceptions
145 --------------------------------------------------------------
146 -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
147 --------------------------------------------------------------
149 -- A GNAT exception object to be dealt with by the personality routine
150 -- called by the GCC unwinding runtime.
152 type GNAT_GCC_Exception is record
153 Header : Unwind_Exception;
154 -- ABI Exception header first
156 Occurrence : aliased Exception_Occurrence;
157 -- The Ada occurrence
158 end record;
160 pragma Convention (C, GNAT_GCC_Exception);
162 -- There is a subtle issue with the common header alignment, since the C
163 -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
164 -- Standard'Maximum_Alignment, and those two values don't quite represent
165 -- the same concepts and so may be decoupled someday. One typical reason
166 -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
167 -- allocator guarantees, and there are extra costs involved in allocating
168 -- objects aligned to such factors.
170 -- To deal with the potential alignment differences between the C and Ada
171 -- representations, the Ada part of the whole structure is only accessed
172 -- by the personality routine through the accessors declared below. Ada
173 -- specific fields are thus always accessed through consistent layout, and
174 -- we expect the actual alignment to always be large enough to avoid traps
175 -- from the C accesses to the common header. Besides, accessors alleviate
176 -- the need for a C struct whole counterpart, both painful and error-prone
177 -- to maintain anyway.
179 type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
181 function To_GCC_Exception is new
182 Unchecked_Conversion (System.Address, GCC_Exception_Access);
184 function To_GNAT_GCC_Exception is new
185 Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
187 procedure GNAT_GCC_Exception_Cleanup
188 (Reason : Unwind_Reason_Code;
189 Excep : not null GNAT_GCC_Exception_Access);
190 pragma Convention (C, GNAT_GCC_Exception_Cleanup);
191 -- Procedure called when a GNAT GCC exception is free.
193 procedure Propagate_GCC_Exception
194 (GCC_Exception : not null GCC_Exception_Access);
195 pragma No_Return (Propagate_GCC_Exception);
196 -- Propagate a GCC exception
198 procedure Reraise_GCC_Exception
199 (GCC_Exception : not null GCC_Exception_Access);
200 pragma No_Return (Reraise_GCC_Exception);
201 pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
202 -- Called to implement raise without exception, ie reraise. Called
203 -- directly from gigi.
205 function Setup_Current_Excep
206 (GCC_Exception : not null GCC_Exception_Access) return EOA;
207 pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
208 -- Write Get_Current_Excep.all from GCC_Exception
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
229 -- trigger cleanups found during the propagation of an unhandled
230 -- exception.
232 -- GCC runtime functions used. These are C non-void functions, actually,
233 -- but we ignore the return values. See raise.c as to why we are using
234 -- __gnat stubs for these.
236 procedure Unwind_RaiseException
237 (UW_Exception : not null GCC_Exception_Access);
238 pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
240 procedure Unwind_ForcedUnwind
241 (UW_Exception : not null GCC_Exception_Access;
242 UW_Handler : System.Address;
243 UW_Argument : System.Address);
244 pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
246 -- Hooks called when entering/leaving an exception handler for a given
247 -- occurrence, aimed at handling the stack of active occurrences. The
248 -- calls are generated by gigi in tree_transform/N_Exception_Handler.
250 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
251 pragma Export (C, Begin_Handler, "__gnat_begin_handler");
253 procedure End_Handler (GCC_Exception : GCC_Exception_Access);
254 pragma Export (C, End_Handler, "__gnat_end_handler");
256 --------------------------------------------------------------------
257 -- Accessors to Basic Components of a GNAT Exception Data Pointer --
258 --------------------------------------------------------------------
260 -- As of today, these are only used by the C implementation of the GCC
261 -- propagation personality routine to avoid having to rely on a C
262 -- counterpart of the whole exception_data structure, which is both
263 -- painful and error prone. These subprograms could be moved to a more
264 -- widely visible location if need be.
266 function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
267 pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
268 pragma Warnings (Off, Is_Handled_By_Others);
270 function Language_For (E : Exception_Data_Ptr) return Character;
271 pragma Export (C, Language_For, "__gnat_language_for");
273 function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
274 pragma Export (C, Import_Code_For, "__gnat_import_code_for");
276 function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
277 return Exception_Id;
278 pragma Export (C, EID_For, "__gnat_eid_for");
280 ---------------------------------------------------------------------------
281 -- Objects to materialize "others" and "all others" in the GCC EH tables --
282 ---------------------------------------------------------------------------
284 -- Currently, these only have their address taken and compared so there is
285 -- no real point having whole exception data blocks allocated. In any case
286 -- the types should match what gigi and the personality routine expect.
287 -- The initial value is an arbitrary value that will not exceed the range
288 -- of Integer on 16-bit targets (such as AAMP).
290 Others_Value : constant Integer := 16#7FFF#;
291 pragma Export (C, Others_Value, "__gnat_others_value");
293 All_Others_Value : constant Integer := 16#7FFF#;
294 pragma Export (C, All_Others_Value, "__gnat_all_others_value");
296 Unhandled_Others_Value : constant Integer := 16#7FFF#;
297 pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
298 -- Special choice (emitted by gigi) to catch and notify unhandled
299 -- exceptions on targets which always handle exceptions (such as SEH).
300 -- The handler will simply call Unhandled_Except_Handler.
302 -------------------------
303 -- Allocate_Occurrence --
304 -------------------------
306 function Allocate_Occurrence return EOA is
307 Res : GNAT_GCC_Exception_Access;
308 begin
309 Res :=
310 new GNAT_GCC_Exception'
311 (Header => (Class => GNAT_Exception_Class,
312 Cleanup => GNAT_GCC_Exception_Cleanup'Address,
313 others => 0),
314 Occurrence => (others => <>));
315 Res.Occurrence.Machine_Occurrence := Res.all'Address;
317 return Res.Occurrence'Access;
318 end Allocate_Occurrence;
320 --------------------------------
321 -- GNAT_GCC_Exception_Cleanup --
322 --------------------------------
324 procedure GNAT_GCC_Exception_Cleanup
325 (Reason : Unwind_Reason_Code;
326 Excep : not null GNAT_GCC_Exception_Access)
328 pragma Unreferenced (Reason);
330 procedure Free is new Unchecked_Deallocation
331 (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
333 Copy : GNAT_GCC_Exception_Access := Excep;
335 begin
336 -- Simply free the memory
338 Free (Copy);
339 end GNAT_GCC_Exception_Cleanup;
341 -------------------------
342 -- Setup_Current_Excep --
343 -------------------------
345 function Setup_Current_Excep
346 (GCC_Exception : not null GCC_Exception_Access) return EOA
348 Excep : constant EOA := Get_Current_Excep.all;
350 begin
351 -- Setup the exception occurrence
353 if GCC_Exception.Class = GNAT_Exception_Class then
355 -- From the GCC exception
357 declare
358 GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
359 To_GNAT_GCC_Exception (GCC_Exception);
360 begin
361 Excep.all := GNAT_Occurrence.Occurrence;
363 return GNAT_Occurrence.Occurrence'Access;
364 end;
365 else
367 -- A default one
369 Excep.Id := Foreign_Exception'Access;
370 Excep.Machine_Occurrence := GCC_Exception.all'Address;
371 Excep.Msg_Length := 0;
372 Excep.Exception_Raised := True;
373 Excep.Pid := Local_Partition_ID;
374 Excep.Num_Tracebacks := 0;
376 return Excep;
377 end if;
378 end Setup_Current_Excep;
380 -------------------
381 -- Begin_Handler --
382 -------------------
384 procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
385 pragma Unreferenced (GCC_Exception);
386 begin
387 null;
388 end Begin_Handler;
390 -----------------
391 -- End_Handler --
392 -----------------
394 procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
395 begin
396 if GCC_Exception /= null then
398 -- The exception might have been reraised, in this case the cleanup
399 -- mustn't be called.
401 Unwind_DeleteException (GCC_Exception);
402 end if;
403 end End_Handler;
405 -----------------------------
406 -- Reraise_GCC_Exception --
407 -----------------------------
409 procedure Reraise_GCC_Exception
410 (GCC_Exception : not null GCC_Exception_Access)
412 begin
413 -- Simply propagate it
414 Propagate_GCC_Exception (GCC_Exception);
415 end Reraise_GCC_Exception;
417 -----------------------------
418 -- Propagate_GCC_Exception --
419 -----------------------------
421 -- Call Unwind_RaiseException to actually throw, taking care of handling
422 -- the two phase scheme it implements.
424 procedure Propagate_GCC_Exception
425 (GCC_Exception : not null GCC_Exception_Access)
427 Excep : EOA;
429 begin
430 -- Perform a standard raise first. If a regular handler is found, it
431 -- will be entered after all the intermediate cleanups have run. If
432 -- there is no regular handler, it will return.
434 Unwind_RaiseException (GCC_Exception);
436 -- If we get here we know the exception is not handled, as otherwise
437 -- Unwind_RaiseException arranges for the handler to be entered. Take
438 -- the necessary steps to enable the debugger to gain control while the
439 -- stack is still intact.
441 Excep := Setup_Current_Excep (GCC_Exception);
442 Notify_Unhandled_Exception (Excep);
444 -- Now, un a forced unwind to trigger cleanups. Control should not
445 -- resume there, if there are cleanups and in any cases as the
446 -- unwinding hook calls Unhandled_Exception_Terminate when end of
447 -- stack is reached.
449 Unwind_ForcedUnwind (GCC_Exception,
450 CleanupUnwind_Handler'Address,
451 System.Null_Address);
453 -- We get here in case of error. The debugger has been notified before
454 -- the second step above.
456 Unhandled_Except_Handler (GCC_Exception);
457 end Propagate_GCC_Exception;
459 -------------------------
460 -- Propagate_Exception --
461 -------------------------
463 procedure Propagate_Exception (Excep : EOA) is
464 begin
465 Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
466 end Propagate_Exception;
468 ------------------------------
469 -- Unhandled_Except_Handler --
470 ------------------------------
472 procedure Unhandled_Except_Handler
473 (GCC_Exception : not null GCC_Exception_Access)
475 Excep : EOA;
476 begin
477 Excep := Setup_Current_Excep (GCC_Exception);
478 Unhandled_Exception_Terminate (Excep);
479 end Unhandled_Except_Handler;
481 -------------
482 -- EID_For --
483 -------------
485 function EID_For
486 (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
488 begin
489 return GNAT_Exception.Occurrence.Id;
490 end EID_For;
492 ---------------------
493 -- Import_Code_For --
494 ---------------------
496 function Import_Code_For
497 (E : SSL.Exception_Data_Ptr) return Exception_Code
499 begin
500 return E.all.Import_Code;
501 end Import_Code_For;
503 --------------------------
504 -- Is_Handled_By_Others --
505 --------------------------
507 function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
508 begin
509 return not E.all.Not_Handled_By_Others;
510 end Is_Handled_By_Others;
512 ------------------
513 -- Language_For --
514 ------------------
516 function Language_For (E : SSL.Exception_Data_Ptr) return Character is
517 begin
518 return E.all.Lang;
519 end Language_For;
521 end Exception_Propagation;