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-2019, 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, which could rely on
33--  different underlying unwinding engines, for example DWARF or ARM unwind
34--  info based. Here is a sketch of the most prominent data structures
35--  involved:
36
37--      (s-excmac.ads)
38--      GNAT_GCC_Exception:
39--      *-----------------------------------*
40--  o-->|          (s-excmac.ads)           |
41--  |   | Header : <gcc occurrence type>    |
42--  |   |   - Class                         |
43--  |   |   ...                             |    Constraint_Error:
44--  |   |-----------------------------------*    Program_Error:
45--  |   |              (a-except.ads)       |    Foreign_Exception:
46--  |   | Occurrence : Exception_Occurrence |
47--  |   |                                   |    (s-stalib. ads)
48--  |   |   - Id : Exception_Id  --------------> Exception_Data
49--  o------ - Machine_Occurrence            |   *------------------------*
50--      |   - Msg                           |   | Not_Handled_By_Others  |
51--      |   - Traceback                     |   | Lang                   |
52--      |   ...                             |   | Foreign_Data --o       |
53--      *-----------------------------------*   | Full_Name      |       |
54--        ||                                    | ...            |       |
55--        ||          foreign rtti blob         *----------------|-------*
56--        ||          *---------------*                          |
57--        ||          |   ...   ...   |<-------------------------o
58--        ||          *---------------*
59--        ||
60--     Setup_Current_Excep()
61--        ||
62--        ||   Latch into ATCB or
63--        ||   environment Current Exception Buffer:
64--        ||
65--        vv
66--     <> : Exception_Occurrence
67--     *---------------------------*
68--     | ...  ...  ... ... ... ... * --- Get_Current_Excep() ---->
69--     *---------------------------*
70
71--  On "raise" events, the runtime allocates a new GNAT_GCC_Exception
72--  instance and eventually calls into libgcc's Unwind_RaiseException.
73--  This part handles the object through the header part only.
74
75--  During execution, Get_Current_Excep provides a pointer to the
76--  Exception_Occurrence being raised or last raised by the current task.
77
78--  This is actually the address of a statically allocated
79--  Exception_Occurrence attached to the current ATCB or to the environment
80--  thread into which an occurrence being raised is synchronized at critical
81--  points during the raise process, via Setup_Current_Excep.
82
83with Ada.Unchecked_Conversion;
84with Ada.Unchecked_Deallocation;
85
86with System.Storage_Elements;   use System.Storage_Elements;
87with System.Exceptions.Machine; use System.Exceptions.Machine;
88
89separate (Ada.Exceptions)
90package body Exception_Propagation is
91
92   use Exception_Traces;
93
94   Foreign_Exception : aliased System.Standard_Library.Exception_Data;
95   pragma Import (Ada, Foreign_Exception,
96                  "system__exceptions__foreign_exception");
97   --  Id for foreign exceptions
98
99   --------------------------------------------------------------
100   -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
101   --------------------------------------------------------------
102
103   --  Phase identifiers (Unwind Actions)
104
105   type Unwind_Action is new Integer;
106   pragma Convention (C, Unwind_Action);
107
108   UA_SEARCH_PHASE  : constant Unwind_Action := 1;
109   UA_CLEANUP_PHASE : constant Unwind_Action := 2;
110   UA_HANDLER_FRAME : constant Unwind_Action := 4;
111   UA_FORCE_UNWIND  : constant Unwind_Action := 8;
112   UA_END_OF_STACK  : constant Unwind_Action := 16;  --  GCC extension
113
114   pragma Unreferenced
115     (UA_HANDLER_FRAME,
116      UA_FORCE_UNWIND,
117      UA_END_OF_STACK);
118
119   procedure GNAT_GCC_Exception_Cleanup
120     (Reason : Unwind_Reason_Code;
121      Excep  : not null GNAT_GCC_Exception_Access);
122   pragma Convention (C, GNAT_GCC_Exception_Cleanup);
123   --  Procedure called when a GNAT GCC exception is free.
124
125   procedure Propagate_GCC_Exception
126     (GCC_Exception : not null GCC_Exception_Access);
127   pragma No_Return (Propagate_GCC_Exception);
128   --  Propagate a GCC exception
129
130   procedure Reraise_GCC_Exception
131     (GCC_Exception : not null GCC_Exception_Access);
132   pragma No_Return (Reraise_GCC_Exception);
133   pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx");
134   --  Called to implement raise without exception, ie reraise. Called
135   --  directly from gigi.
136
137   function Setup_Current_Excep
138     (GCC_Exception : not null GCC_Exception_Access;
139      Phase : Unwind_Action) return EOA;
140   pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
141   --  Acknowledge GCC_Exception as the current exception object being
142   --  raised, which could be an Ada or a foreign exception object.  Return
143   --  a pointer to the embedded Ada occurrence for an Ada exception object,
144   --  to the current exception buffer otherwise.
145   --
146   --  Synchronize the current exception buffer as needed for possible
147   --  accesses through Get_Current_Except.all afterwards, depending on the
148   --  Phase bits, received either from the personality routine, from a
149   --  forced_unwind cleanup handler, or just before the start of propagation
150   --  for an Ada exception (Phase 0 in this case).
151
152   procedure Unhandled_Except_Handler
153     (GCC_Exception : not null GCC_Exception_Access);
154   pragma No_Return (Unhandled_Except_Handler);
155   pragma Export (C, Unhandled_Except_Handler,
156                  "__gnat_unhandled_except_handler");
157   --  Called for handle unhandled exceptions, ie the last chance handler
158   --  on platforms (such as SEH) that never returns after throwing an
159   --  exception. Called directly by gigi.
160
161   function CleanupUnwind_Handler
162     (UW_Version   : Integer;
163      UW_Phases    : Unwind_Action;
164      UW_Eclass    : Exception_Class;
165      UW_Exception : not null GCC_Exception_Access;
166      UW_Context   : System.Address;
167      UW_Argument  : System.Address) return Unwind_Reason_Code;
168   pragma Import (C, CleanupUnwind_Handler,
169                  "__gnat_cleanupunwind_handler");
170   --  Hook called at each step of the forced unwinding we perform to trigger
171   --  cleanups found during the propagation of an unhandled exception.
172
173   --  GCC runtime functions used. These are C non-void functions, actually,
174   --  but we ignore the return values. See raise.c as to why we are using
175   --  __gnat stubs for these.
176
177   procedure Unwind_RaiseException
178     (UW_Exception : not null GCC_Exception_Access);
179   pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
180
181   procedure Unwind_ForcedUnwind
182     (UW_Exception : not null GCC_Exception_Access;
183      UW_Handler   : System.Address;
184      UW_Argument  : System.Address);
185   pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
186
187   procedure Set_Exception_Parameter
188     (Excep         : EOA;
189      GCC_Exception : not null GCC_Exception_Access);
190   pragma Export
191     (C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
192   --  Called inserted by gigi to set the exception choice parameter from the
193   --  gcc occurrence.
194
195   procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
196   --  Utility routine to initialize occurrence Excep from a foreign exception
197   --  whose machine occurrence is Mo. The message is empty, the backtrace
198   --  is empty too and the exception identity is Foreign_Exception.
199
200   --  Hooks called when entering/leaving an exception handler for a given
201   --  occurrence, aimed at handling the stack of active occurrences. The
202   --  calls are generated by gigi in tree_transform/N_Exception_Handler.
203
204   procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access);
205   pragma Export (C, Begin_Handler, "__gnat_begin_handler");
206
207   procedure End_Handler (GCC_Exception : GCC_Exception_Access);
208   pragma Export (C, End_Handler, "__gnat_end_handler");
209
210   --------------------------------------------------------------------
211   -- Accessors to Basic Components of a GNAT Exception Data Pointer --
212   --------------------------------------------------------------------
213
214   --  As of today, these are only used by the C implementation of the GCC
215   --  propagation personality routine to avoid having to rely on a C
216   --  counterpart of the whole exception_data structure, which is both
217   --  painful and error prone. These subprograms could be moved to a more
218   --  widely visible location if need be.
219
220   function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean;
221   pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others");
222   pragma Warnings (Off, Is_Handled_By_Others);
223
224   function Language_For (E : Exception_Data_Ptr) return Character;
225   pragma Export (C, Language_For, "__gnat_language_for");
226
227   function Foreign_Data_For (E : Exception_Data_Ptr) return Address;
228   pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for");
229
230   function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access)
231     return Exception_Id;
232   pragma Export (C, EID_For, "__gnat_eid_for");
233
234   ---------------------------------------------------------------------------
235   -- Objects to materialize "others" and "all others" in the GCC EH tables --
236   ---------------------------------------------------------------------------
237
238   --  Currently, these only have their address taken and compared so there is
239   --  no real point having whole exception data blocks allocated. Note that
240   --  there are corresponding declarations in gigi (trans.c) which must be
241   --  kept properly synchronized.
242
243   Others_Value : constant Character := 'O';
244   pragma Export (C, Others_Value, "__gnat_others_value");
245
246   All_Others_Value : constant Character := 'A';
247   pragma Export (C, All_Others_Value, "__gnat_all_others_value");
248
249   Unhandled_Others_Value : constant Character := 'U';
250   pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value");
251   --  Special choice (emitted by gigi) to catch and notify unhandled
252   --  exceptions on targets which always handle exceptions (such as SEH).
253   --  The handler will simply call Unhandled_Except_Handler.
254
255   -------------------------
256   -- Allocate_Occurrence --
257   -------------------------
258
259   function Allocate_Occurrence return EOA is
260      Res : GNAT_GCC_Exception_Access;
261
262   begin
263      Res := New_Occurrence;
264      Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address;
265      Res.Occurrence.Machine_Occurrence := Res.all'Address;
266
267      return Res.Occurrence'Access;
268   end Allocate_Occurrence;
269
270   --------------------------------
271   -- GNAT_GCC_Exception_Cleanup --
272   --------------------------------
273
274   procedure GNAT_GCC_Exception_Cleanup
275     (Reason : Unwind_Reason_Code;
276      Excep  : not null GNAT_GCC_Exception_Access)
277   is
278      pragma Unreferenced (Reason);
279
280      procedure Free is new Unchecked_Deallocation
281        (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
282
283      Copy : GNAT_GCC_Exception_Access := Excep;
284
285   begin
286      --  Simply free the memory
287
288      Free (Copy);
289   end GNAT_GCC_Exception_Cleanup;
290
291   ----------------------------
292   -- Set_Foreign_Occurrence --
293   ----------------------------
294
295   procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is
296   begin
297      Excep.all := (
298        Id                 => Foreign_Exception'Access,
299        Machine_Occurrence => Mo,
300        Msg                => <>,
301        Msg_Length         => 0,
302        Exception_Raised   => True,
303        Pid                => Local_Partition_ID,
304        Num_Tracebacks     => 0,
305        Tracebacks         => <>);
306   end Set_Foreign_Occurrence;
307
308   -------------------------
309   -- Setup_Current_Excep --
310   -------------------------
311
312   function Setup_Current_Excep
313     (GCC_Exception : not null GCC_Exception_Access;
314      Phase : Unwind_Action) return EOA
315   is
316      Excep : constant EOA := Get_Current_Excep.all;
317
318   begin
319
320      if GCC_Exception.Class = GNAT_Exception_Class then
321
322         --  Ada exception : latch the occurrence data in the Current
323         --  Exception Buffer if needed and return a pointer to the original
324         --  Ada exception object. This particular object was specifically
325         --  allocated for this raise and is thus more precise than the fixed
326         --  Current Exception Buffer address.
327
328         declare
329            GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
330                                To_GNAT_GCC_Exception (GCC_Exception);
331         begin
332
333            --  When reaching here during SEARCH_PHASE, no need to
334            --  replicate the copy performed at the propagation start.
335
336            if Phase /= UA_SEARCH_PHASE then
337               Excep.all := GNAT_Occurrence.Occurrence;
338            end if;
339            return GNAT_Occurrence.Occurrence'Access;
340         end;
341
342      else
343
344         --  Foreign exception (caught by Ada handler, reaching here from
345         --  personality routine) : The original exception object doesn't hold
346         --  an Ada occurrence info.  Set the foreign data pointer in the
347         --  Current Exception Buffer and return the address of the latter.
348
349         Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
350
351         return Excep;
352      end if;
353   end Setup_Current_Excep;
354
355   -------------------
356   -- Begin_Handler --
357   -------------------
358
359   procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is
360      pragma Unreferenced (GCC_Exception);
361   begin
362      null;
363   end Begin_Handler;
364
365   -----------------
366   -- End_Handler --
367   -----------------
368
369   procedure End_Handler (GCC_Exception : GCC_Exception_Access) is
370   begin
371      if GCC_Exception /= null then
372
373         --  The exception might have been reraised, in this case the cleanup
374         --  mustn't be called.
375
376         Unwind_DeleteException (GCC_Exception);
377      end if;
378   end End_Handler;
379
380   -----------------------------
381   -- Reraise_GCC_Exception --
382   -----------------------------
383
384   procedure Reraise_GCC_Exception
385     (GCC_Exception : not null GCC_Exception_Access)
386   is
387   begin
388      --  Simply propagate it
389
390      Propagate_GCC_Exception (GCC_Exception);
391   end Reraise_GCC_Exception;
392
393   -----------------------------
394   -- Propagate_GCC_Exception --
395   -----------------------------
396
397   --  Call Unwind_RaiseException to actually throw, taking care of handling
398   --  the two phase scheme it implements.
399
400   procedure Propagate_GCC_Exception
401     (GCC_Exception : not null GCC_Exception_Access)
402   is
403      --  Acknowledge the current exception info now, before unwinding
404      --  starts so it is available even from C++ handlers involved before
405      --  our personality routine.
406
407      Excep : constant EOA :=
408        Setup_Current_Excep (GCC_Exception, Phase => 0);
409
410   begin
411      --  Perform a standard raise first. If a regular handler is found, it
412      --  will be entered after all the intermediate cleanups have run. If
413      --  there is no regular handler, it will return.
414
415      Unwind_RaiseException (GCC_Exception);
416
417      --  If we get here we know the exception is not handled, as otherwise
418      --  Unwind_RaiseException arranges for the handler to be entered. Take
419      --  the necessary steps to enable the debugger to gain control while the
420      --  stack is still intact.
421
422      Notify_Unhandled_Exception (Excep);
423
424      --  Now, un a forced unwind to trigger cleanups. Control should not
425      --  resume there, if there are cleanups and in any cases as the
426      --  unwinding hook calls Unhandled_Exception_Terminate when end of
427      --  stack is reached.
428
429      Unwind_ForcedUnwind
430        (GCC_Exception,
431         CleanupUnwind_Handler'Address,
432         System.Null_Address);
433
434      --  We get here in case of error. The debugger has been notified before
435      --  the second step above.
436
437      Unhandled_Except_Handler (GCC_Exception);
438   end Propagate_GCC_Exception;
439
440   -------------------------
441   -- Propagate_Exception --
442   -------------------------
443
444   procedure Propagate_Exception (Excep : Exception_Occurrence) is
445   begin
446      Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence));
447   end Propagate_Exception;
448
449   -----------------------------
450   -- Set_Exception_Parameter --
451   -----------------------------
452
453   procedure Set_Exception_Parameter
454     (Excep         : EOA;
455      GCC_Exception : not null GCC_Exception_Access)
456   is
457   begin
458      --  Setup the exception occurrence
459
460      if GCC_Exception.Class = GNAT_Exception_Class then
461
462         --  From the GCC exception
463
464         declare
465            GNAT_Occurrence : constant GNAT_GCC_Exception_Access :=
466                                To_GNAT_GCC_Exception (GCC_Exception);
467         begin
468            Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence);
469         end;
470
471      else
472         --  A default one
473
474         Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address);
475      end if;
476   end Set_Exception_Parameter;
477
478   ------------------------------
479   -- Unhandled_Except_Handler --
480   ------------------------------
481
482   procedure Unhandled_Except_Handler
483     (GCC_Exception : not null GCC_Exception_Access)
484   is
485      Excep : EOA;
486   begin
487      Excep := Setup_Current_Excep (GCC_Exception, Phase => UA_CLEANUP_PHASE);
488      Unhandled_Exception_Terminate (Excep);
489   end Unhandled_Except_Handler;
490
491   -------------
492   -- EID_For --
493   -------------
494
495   function EID_For
496     (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id
497   is
498   begin
499      return GNAT_Exception.Occurrence.Id;
500   end EID_For;
501
502   ----------------------
503   -- Foreign_Data_For --
504   ----------------------
505
506   function Foreign_Data_For
507     (E : SSL.Exception_Data_Ptr) return Address
508   is
509   begin
510      return E.Foreign_Data;
511   end Foreign_Data_For;
512
513   --------------------------
514   -- Is_Handled_By_Others --
515   --------------------------
516
517   function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is
518   begin
519      return not E.all.Not_Handled_By_Others;
520   end Is_Handled_By_Others;
521
522   ------------------
523   -- Language_For --
524   ------------------
525
526   function Language_For (E : SSL.Exception_Data_Ptr) return Character is
527   begin
528      return E.all.Lang;
529   end Language_For;
530
531end Exception_Propagation;
532