OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-exexpr-gcc.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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-2011, 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
 
34
with Ada.Unchecked_Conversion;
35
with Ada.Unchecked_Deallocation;
36
 
37
with System.Storage_Elements;  use System.Storage_Elements;
38
 
39
separate (Ada.Exceptions)
40
package body Exception_Propagation is
41
 
42
   ------------------------------------------------
43
   -- Entities to interface with the GCC runtime --
44
   ------------------------------------------------
45
 
46
   --  These come from "C++ ABI for Itanium: Exception handling", which is
47
   --  the reference for GCC. They are used only when we are relying on
48
   --  back-end tables for exception propagation, which in turn is currently
49
   --  only the case for Zero_Cost_Exceptions in GNAT5.
50
 
51
   --  Return codes from the GCC runtime functions used to propagate
52
   --  an exception.
53
 
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);
64
 
65
   pragma Unreferenced
66
     (URC_FOREIGN_EXCEPTION_CAUGHT,
67
      URC_PHASE2_ERROR,
68
      URC_PHASE1_ERROR,
69
      URC_NORMAL_STOP,
70
      URC_END_OF_STACK,
71
      URC_HANDLER_FOUND,
72
      URC_INSTALL_CONTEXT,
73
      URC_CONTINUE_UNWIND);
74
 
75
   pragma Convention (C, Unwind_Reason_Code);
76
 
77
   --  Phase identifiers
78
 
79
   type Unwind_Action is new Integer;
80
   pragma Convention (C, Unwind_Action);
81
 
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 ?
87
 
88
   pragma Unreferenced
89
     (UA_SEARCH_PHASE,
90
      UA_CLEANUP_PHASE,
91
      UA_HANDLER_FRAME,
92
      UA_FORCE_UNWIND);
93
 
94
   --  Mandatory common header for any exception object handled by the
95
   --  GCC unwinding runtime.
96
 
97
   type Exception_Class is mod 2 ** 64;
98
 
99
   GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
100
   --  "GNU-Ada\0"
101
 
102
   type Unwind_Word is mod 2 ** System.Word_Size;
103
   for Unwind_Word'Size use System.Word_Size;
104
   --  Map the corresponding C type used in Unwind_Exception below
105
 
106
   type Unwind_Exception is record
107
      Class    : Exception_Class;
108
      Cleanup  : System.Address;
109
      Private1 : Unwind_Word;
110
      Private2 : Unwind_Word;
111
   end record;
112
   pragma Convention (C, Unwind_Exception);
113
   --  Map the GCC struct used for exception handling
114
 
115
   for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
116
   --  The C++ ABI mandates the common exception header to be at least
117
   --  doubleword aligned, and the libGCC implementation actually makes it
118
   --  maximally aligned (see unwind.h). See additional comments on the
119
   --  alignment below.
120
 
121
   type GCC_Exception_Access is access all Unwind_Exception;
122
   --  Pointer to a GCC exception. Do not use convention C as on VMS this
123
   --  would imply the use of 32-bits pointers.
124
 
125
   procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
126
   pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
127
   --  Procedure to free any GCC exception
128
 
129
   Foreign_Exception : aliased System.Standard_Library.Exception_Data;
130
   pragma Import (Ada, Foreign_Exception,
131
                  "system__exceptions__foreign_exception");
132
   --  Id for foreign exceptions
133
 
134
   --------------------------------------------------------------
135
   -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
136
   --------------------------------------------------------------
137
 
138
   --  A GNAT exception object to be dealt with by the personality routine
139
   --  called by the GCC unwinding runtime.
140
 
141
   type GNAT_GCC_Exception is record
142
      Header : Unwind_Exception;
143
      --  ABI Exception header first
144
 
145
      Occurrence : Exception_Occurrence;
146
      --  The Ada occurrence
147
   end record;
148
 
149
   pragma Convention (C, GNAT_GCC_Exception);
150
 
151
   --  There is a subtle issue with the common header alignment, since the C
152
   --  version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
153
   --  Standard'Maximum_Alignment, and those two values don't quite represent
154
   --  the same concepts and so may be decoupled someday. One typical reason
155
   --  is that BIGGEST_ALIGNMENT may be larger than what the underlying system
156
   --  allocator guarantees, and there are extra costs involved in allocating
157
   --  objects aligned to such factors.
158
 
159
   --  To deal with the potential alignment differences between the C and Ada
160
   --  representations, the Ada part of the whole structure is only accessed
161
   --  by the personality routine through the accessors declared below.  Ada
162
   --  specific fields are thus always accessed through consistent layout, and
163
   --  we expect the actual alignment to always be large enough to avoid traps
164
   --  from the C accesses to the common header. Besides, accessors alleviate
165
   --  the need for a C struct whole counterpart, both painful and error-prone
166
   --  to maintain anyway.
167
 
168
   type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
169
 
170
   function To_GCC_Exception is new
171
     Unchecked_Conversion (GNAT_GCC_Exception_Access, GCC_Exception_Access);
172
 
173
   function To_GNAT_GCC_Exception is new
174
     Unchecked_Conversion (GCC_Exception_Access, GNAT_GCC_Exception_Access);
175
 
176
   procedure GNAT_GCC_Exception_Cleanup
177
     (Reason : Unwind_Reason_Code;
178
      Excep  : not null GNAT_GCC_Exception_Access);
179
   pragma Convention (C, GNAT_GCC_Exception_Cleanup);
180
   --  Procedure called when a GNAT GCC exception is free.
181
 
182
   procedure Propagate_GCC_Exception
183
     (GCC_Exception : not null GCC_Exception_Access);
184
   pragma No_Return (Propagate_GCC_Exception);
185
   --  Propagate a GCC exception
186
 
187
   procedure Reraise_GCC_Exception
188
     (GCC_Exception : not null GCC_Exception_Access);
189
   pragma No_Return (Reraise_GCC_Exception);
190
   pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
191
   --  Called to implement raise without exception, ie reraise.  Called
192
   --  directly from gigi.
193
 
194
   procedure Setup_Current_Excep
195
     (GCC_Exception : not null GCC_Exception_Access);
196
   pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
197
   --  Write Get_Current_Excep.all from GCC_Exception
198
 
199
   function CleanupUnwind_Handler
200
     (UW_Version   : Integer;
201
      UW_Phases    : Unwind_Action;
202
      UW_Eclass    : Exception_Class;
203
      UW_Exception : not null GCC_Exception_Access;
204
      UW_Context   : System.Address;
205
      UW_Argument  : System.Address) return Unwind_Reason_Code;
206
   --  Hook called at each step of the forced unwinding we perform to
207
   --  trigger cleanups found during the propagation of an unhandled
208
   --  exception.
209
 
210
   --  GCC runtime functions used. These are C non-void functions, actually,
211
   --  but we ignore the return values. See raise.c as to why we are using
212
   --  __gnat stubs for these.
213
 
214
   procedure Unwind_RaiseException
215
     (UW_Exception : not null GCC_Exception_Access);
216
   pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
217
 
218
   procedure Unwind_ForcedUnwind
219
     (UW_Exception : not null GCC_Exception_Access;
220
      UW_Handler   : System.Address;
221
      UW_Argument  : System.Address);
222
   pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
223
 
224
   --  Hooks called when entering/leaving an exception handler for a given
225
   --  occurrence, aimed at handling the stack of active occurrences. The
226
   --  calls are generated by gigi in tree_transform/N_Exception_Handler.
227
 
228
   procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
229
   pragma Export (C, Begin_Handler, "__gnat_begin_handler");
230
 
231
   procedure End_Handler (GCC_Exception : GCC_Exception_Access);
232
   pragma Export (C, End_Handler, "__gnat_end_handler");
233
 
234
   --------------------------------------------------------------------
235
   -- Accessors to Basic Components of a GNAT Exception Data Pointer --
236
   --------------------------------------------------------------------
237
 
238
   --  As of today, these are only used by the C implementation of the GCC
239
   --  propagation personality routine to avoid having to rely on a C
240
   --  counterpart of the whole exception_data structure, which is both
241
   --  painful and error prone. These subprograms could be moved to a more
242
   --  widely visible location if need be.
243
 
244
   function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
245
   pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
246
   pragma Warnings (Off, Is_Handled_By_Others);
247
 
248
   function Language_For (E : Exception_Data_Ptr) return Character;
249
   pragma Export (C, Language_For, "__gnat_language_for");
250
 
251
   function Import_Code_For (E : Exception_Data_Ptr) return Exception_Code;
252
   pragma Export (C, Import_Code_For, "__gnat_import_code_for");
253
 
254
   function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
255
     return Exception_Id;
256
   pragma Export (C, EID_For, "__gnat_eid_for");
257
 
258
   ---------------------------------------------------------------------------
259
   -- Objects to materialize "others" and "all others" in the GCC EH tables --
260
   ---------------------------------------------------------------------------
261
 
262
   --  Currently, these only have their address taken and compared so there is
263
   --  no real point having whole exception data blocks allocated. In any case
264
   --  the types should match what gigi and the personality routine expect.
265
   --  The initial value is an arbitrary value that will not exceed the range
266
   --  of Integer on 16-bit targets (such as AAMP).
267
 
268
   Others_Value : constant Integer := 16#7FFF#;
269
   pragma Export (C, Others_Value, "__gnat_others_value");
270
 
271
   All_Others_Value : constant Integer := 16#7FFF#;
272
   pragma Export (C, All_Others_Value, "__gnat_all_others_value");
273
 
274
   --------------------------------
275
   -- GNAT_GCC_Exception_Cleanup --
276
   --------------------------------
277
 
278
   procedure GNAT_GCC_Exception_Cleanup
279
     (Reason : Unwind_Reason_Code;
280
      Excep  : not null GNAT_GCC_Exception_Access)
281
   is
282
      pragma Unreferenced (Reason);
283
 
284
      procedure Free is new Unchecked_Deallocation
285
        (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
286
 
287
      Copy : GNAT_GCC_Exception_Access := Excep;
288
 
289
   begin
290
      --  Simply free the memory
291
 
292
      Free (Copy);
293
   end GNAT_GCC_Exception_Cleanup;
294
 
295
   ---------------------------
296
   -- CleanupUnwind_Handler --
297
   ---------------------------
298
 
299
   function CleanupUnwind_Handler
300
     (UW_Version   : Integer;
301
      UW_Phases    : Unwind_Action;
302
      UW_Eclass    : Exception_Class;
303
      UW_Exception : not null GCC_Exception_Access;
304
      UW_Context   : System.Address;
305
      UW_Argument  : System.Address) return Unwind_Reason_Code
306
   is
307
      pragma Unreferenced (UW_Version, UW_Eclass, UW_Context, UW_Argument);
308
 
309
   begin
310
      --  Terminate when the end of the stack is reached
311
 
312
      if UW_Phases >= UA_END_OF_STACK then
313
         Setup_Current_Excep (UW_Exception);
314
         Unhandled_Exception_Terminate;
315
      end if;
316
 
317
      --  We know there is at least one cleanup further up. Return so that it
318
      --  is searched and entered, after which Unwind_Resume will be called
319
      --  and this hook will gain control again.
320
 
321
      return URC_NO_REASON;
322
   end CleanupUnwind_Handler;
323
 
324
   -------------------------
325
   -- Setup_Current_Excep --
326
   -------------------------
327
 
328
   procedure Setup_Current_Excep
329
     (GCC_Exception : not null GCC_Exception_Access)
330
   is
331
      Excep : constant EOA := Get_Current_Excep.all;
332
 
333
   begin
334
      --  Setup the exception occurrence
335
 
336
      if GCC_Exception.Class = GNAT_Exception_Class then
337
 
338
         --  From the GCC exception
339
 
340
         declare
341
            GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
342
                                To_GNAT_GCC_Exception (GCC_Exception);
343
         begin
344
            Excep.all := GNAT_Occurrence.Occurrence;
345
         end;
346
      else
347
 
348
         --  A default one
349
 
350
         Excep.Id := Foreign_Exception'Access;
351
         Excep.Msg_Length := 0;
352
         Excep.Exception_Raised := True;
353
         Excep.Pid := Local_Partition_ID;
354
         Excep.Num_Tracebacks := 0;
355
      end if;
356
   end Setup_Current_Excep;
357
 
358
   -------------------
359
   -- Begin_Handler --
360
   -------------------
361
 
362
   procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
363
      pragma Unreferenced (GCC_Exception);
364
   begin
365
      null;
366
   end Begin_Handler;
367
 
368
   -----------------
369
   -- End_Handler --
370
   -----------------
371
 
372
   procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
373
   begin
374
      if GCC_Exception /= null then
375
 
376
         --  The exception might have been reraised, in this case the cleanup
377
         --  mustn't be called.
378
 
379
         Unwind_DeleteException (GCC_Exception);
380
      end if;
381
   end End_Handler;
382
 
383
   -----------------------------
384
   -- Reraise_GCC_Exception --
385
   -----------------------------
386
 
387
   procedure Reraise_GCC_Exception
388
     (GCC_Exception : not null GCC_Exception_Access)
389
   is
390
   begin
391
      --  Simply propagate it
392
      Propagate_GCC_Exception (GCC_Exception);
393
   end Reraise_GCC_Exception;
394
 
395
   -----------------------------
396
   -- Propagate_GCC_Exception --
397
   -----------------------------
398
 
399
   --  Call Unwind_RaiseException to actually throw, taking care of handling
400
   --  the two phase scheme it implements.
401
 
402
   procedure Propagate_GCC_Exception
403
     (GCC_Exception : not null GCC_Exception_Access)
404
   is
405
   begin
406
      --  Perform a standard raise first. If a regular handler is found, it
407
      --  will be entered after all the intermediate cleanups have run. If
408
      --  there is no regular handler, it will return.
409
 
410
      Unwind_RaiseException (GCC_Exception);
411
 
412
      --  If we get here we know the exception is not handled, as otherwise
413
      --  Unwind_RaiseException arranges for the handler to be entered. Take
414
      --  the necessary steps to enable the debugger to gain control while the
415
      --  stack is still intact.
416
 
417
      Setup_Current_Excep (GCC_Exception);
418
      Notify_Unhandled_Exception;
419
 
420
      --  Now, un a forced unwind to trigger cleanups. Control should not
421
      --  resume there, if there are cleanups and in any cases as the
422
      --  unwinding hook calls Unhandled_Exception_Terminate when end of
423
      --  stack is reached.
424
 
425
      Unwind_ForcedUnwind (GCC_Exception,
426
                           CleanupUnwind_Handler'Address,
427
                           System.Null_Address);
428
 
429
      --  We get here in case of error. The debugger has been notified before
430
      --  the second step above.
431
 
432
      Setup_Current_Excep (GCC_Exception);
433
      Unhandled_Exception_Terminate;
434
   end Propagate_GCC_Exception;
435
 
436
   -------------------------
437
   -- Propagate_Exception --
438
   -------------------------
439
 
440
   --  Build an object suitable for the libgcc processing and call
441
   --  Unwind_RaiseException to actually do the raise, taking care of
442
   --  handling the two phase scheme it implements.
443
 
444
   procedure Propagate_Exception is
445
      Excep         : constant EOA := Get_Current_Excep.all;
446
      GCC_Exception : GNAT_GCC_Exception_Access;
447
 
448
   begin
449
      --  Compute the backtrace for this occurrence if the corresponding
450
      --  binder option has been set. Call_Chain takes care of the reraise
451
      --  case.
452
 
453
      --  ??? Using Call_Chain here means we are going to walk up the stack
454
      --  once only for backtracing purposes before doing it again for the
455
      --  propagation per se.
456
 
457
      --  The first inspection is much lighter, though, as it only requires
458
      --  partial unwinding of each frame. Additionally, although we could use
459
      --  the personality routine to record the addresses while propagating,
460
      --  this method has two drawbacks:
461
 
462
      --  1) the trace is incomplete if the exception is handled since we
463
      --  don't walk past the frame with the handler,
464
 
465
      --    and
466
 
467
      --  2) we would miss the frames for which our personality routine is not
468
      --  called, e.g. if C or C++ calls are on the way.
469
 
470
      Call_Chain (Excep);
471
 
472
      --  Allocate the GCC exception
473
 
474
      GCC_Exception :=
475
        new GNAT_GCC_Exception'
476
          (Header     => (Class => GNAT_Exception_Class,
477
                          Cleanup => GNAT_GCC_Exception_Cleanup'Address,
478
                          Private1 => 0,
479
                          Private2 => 0),
480
           Occurrence => Excep.all);
481
 
482
      --  Propagate it
483
 
484
      Propagate_GCC_Exception (To_GCC_Exception (GCC_Exception));
485
   end Propagate_Exception;
486
 
487
   -------------
488
   -- EID_For --
489
   -------------
490
 
491
   function EID_For
492
     (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
493
   is
494
   begin
495
      return GNAT_Exception.Occurrence.Id;
496
   end EID_For;
497
 
498
   ---------------------
499
   -- Import_Code_For --
500
   ---------------------
501
 
502
   function Import_Code_For
503
     (E : SSL.Exception_Data_Ptr) return Exception_Code
504
   is
505
   begin
506
      return E.all.Import_Code;
507
   end Import_Code_For;
508
 
509
   --------------------------
510
   -- Is_Handled_By_Others --
511
   --------------------------
512
 
513
   function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
514
   begin
515
      return not E.all.Not_Handled_By_Others;
516
   end Is_Handled_By_Others;
517
 
518
   ------------------
519
   -- Language_For --
520
   ------------------
521
 
522
   function Language_For (E : SSL.Exception_Data_Ptr) return Character is
523
   begin
524
      return E.all.Lang;
525
   end Language_For;
526
 
527
end Exception_Propagation;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.