1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                      ADA.EXCEPTIONS.EXCEPTION_TRACES                     --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2020, 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
32with Ada.Unchecked_Conversion;
33
34pragma Warnings (Off);
35with Ada.Exceptions.Last_Chance_Handler;
36pragma Warnings (On);
37--  Bring last chance handler into closure
38
39separate (Ada.Exceptions)
40package body Exception_Traces is
41
42   Nline : constant String := String'(1 => ASCII.LF);
43   --  Convenient shortcut
44
45   type Exception_Action is access procedure (E : Exception_Occurrence);
46   pragma Favor_Top_Level (Exception_Action);
47
48   Global_Action : Exception_Action := null;
49   pragma Atomic (Global_Action);
50   pragma Export
51     (Ada, Global_Action, "__gnat_exception_actions_global_action");
52   --  Global action, executed whenever an exception is raised.  Changing the
53   --  export name must be coordinated with code in g-excact.adb.
54
55   Global_Unhandled_Action : Exception_Action := null;
56   pragma Atomic (Global_Unhandled_Action);
57   pragma Export
58     (Ada, Global_Unhandled_Action,
59      "__gnat_exception_actions_global_unhandled_action");
60   --  Global action, executed whenever an unhandled exception is raised.
61   --  Changing the export name must be coordinated with code in g-excact.adb.
62
63   Raise_Hook_Initialized : Boolean := False;
64   pragma Export
65     (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
66
67   procedure Last_Chance_Handler (Except : Exception_Occurrence);
68   pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler");
69   pragma No_Return (Last_Chance_Handler);
70   --  Users can replace the default version of this routine,
71   --  Ada.Exceptions.Last_Chance_Handler.
72
73   function To_Action is new Ada.Unchecked_Conversion
74     (Raise_Action, Exception_Action);
75
76   -----------------------
77   -- Local Subprograms --
78   -----------------------
79
80   procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean);
81   --  Factorizes the common processing for Notify_Handled_Exception and
82   --  Notify_Unhandled_Exception. Is_Unhandled is set to True only in the
83   --  latter case because Notify_Handled_Exception may be called for an
84   --  actually unhandled occurrence in the Front-End-SJLJ case.
85
86   ----------------------
87   -- Notify_Exception --
88   ----------------------
89
90   procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is
91      --  Save actions locally to avoid any race condition that would
92      --  reset them to null.
93      Action           : constant Exception_Action := Global_Action;
94      Unhandled_Action : constant Exception_Action := Global_Unhandled_Action;
95
96   begin
97      --  Output the exception information required by the Exception_Trace
98      --  configuration. Take care not to output information about internal
99      --  exceptions.
100
101      if not Excep.Id.Not_Handled_By_Others
102        and then
103          (Exception_Trace = Every_Raise
104            or else
105              (Is_Unhandled
106                and then
107                  (Exception_Trace = Unhandled_Raise
108                    or else Exception_Trace = Unhandled_Raise_In_Main)))
109      then
110         --  Exception trace messages need to be protected when several tasks
111         --  can issue them at the same time.
112
113         Lock_Task.all;
114         To_Stderr (Nline);
115
116         if Exception_Trace /= Unhandled_Raise_In_Main then
117            if Is_Unhandled then
118               To_Stderr ("Unhandled ");
119            end if;
120
121            To_Stderr ("Exception raised");
122            To_Stderr (Nline);
123         end if;
124
125         To_Stderr (Exception_Information (Excep.all));
126         Unlock_Task.all;
127      end if;
128
129      --  Call the user-specific actions
130      --  ??? We should presumably look at the reraise status here.
131
132      if Raise_Hook_Initialized
133        and then Exception_Data_Ptr (Excep.Id).Raise_Hook /= null
134      then
135         To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all);
136      end if;
137
138      if Is_Unhandled and Unhandled_Action /= null then
139         Unhandled_Action (Excep.all);
140      end if;
141
142      if Action /= null then
143         Action (Excep.all);
144      end if;
145   end Notify_Exception;
146
147   ------------------------------
148   -- Notify_Handled_Exception --
149   ------------------------------
150
151   procedure Notify_Handled_Exception (Excep : EOA) is
152   begin
153      Notify_Exception (Excep, Is_Unhandled => False);
154   end Notify_Handled_Exception;
155
156   --------------------------------
157   -- Notify_Unhandled_Exception --
158   --------------------------------
159
160   procedure Notify_Unhandled_Exception (Excep : EOA) is
161   begin
162      --  Check whether there is any termination handler to be executed for
163      --  the environment task, and execute it if needed. Here we handle both
164      --  the Abnormal and Unhandled_Exception task termination. Normal
165      --  task termination routine is executed elsewhere (either in the
166      --  Task_Wrapper or in the Adafinal routine for the environment task).
167
168      Task_Termination_Handler.all (Excep.all);
169
170      Notify_Exception (Excep, Is_Unhandled => True);
171      Debug_Unhandled_Exception (SSL.Exception_Data_Ptr (Excep.Id));
172   end Notify_Unhandled_Exception;
173
174   -----------------------------------
175   -- Unhandled_Exception_Terminate --
176   -----------------------------------
177
178   procedure Unhandled_Exception_Terminate (Excep : EOA) is
179      Occ : Exception_Occurrence;
180      --  This occurrence will be used to display a message after finalization.
181      --  It is necessary to save a copy here, or else the designated value
182      --  could be overwritten if an exception is raised during finalization
183      --  (even if that exception is caught). The occurrence is saved on the
184      --  stack to avoid dynamic allocation (if this exception is due to lack
185      --  of space in the heap, we therefore avoid a second failure). We assume
186      --  that there is enough room on the stack however.
187
188   begin
189      Save_Occurrence (Occ, Excep.all);
190      Last_Chance_Handler (Occ);
191   end Unhandled_Exception_Terminate;
192
193   ------------------------------------
194   -- Handling GNAT.Exception_Traces --
195   ------------------------------------
196
197   --  The bulk of exception traces output is centralized in Notify_Exception,
198   --  for both the Handled and Unhandled cases. Extra task specific output is
199   --  triggered in the task wrapper for unhandled occurrences in tasks. It is
200   --  not performed in this unit to avoid dependencies on the tasking units
201   --  here.
202
203   --  We used to rely on the output performed by Unhanded_Exception_Terminate
204   --  for the case of an unhandled occurrence in the environment thread, and
205   --  the task wrapper was responsible for the whole output in the tasking
206   --  case.
207
208   --  This initial scheme had a drawback: the output from Terminate only
209   --  occurs after finalization is done, which means possibly never if some
210   --  tasks keep hanging around.
211
212   --  The first "presumably obvious" fix consists in moving the Terminate
213   --  output before the finalization. It has not been retained because it
214   --  introduces annoying changes in output orders when the finalization
215   --  itself issues outputs, this also in "regular" cases not resorting to
216   --  Exception_Traces.
217
218   --  Today's solution has the advantage of simplicity and better isolates
219   --  the Exception_Traces machinery.
220
221end Exception_Traces;
222