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