1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S O F T _ L I N K S --
11 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 -- This package contains a set of subprogram access variables that access
37 -- some low-level primitives that are called different depending wether
38 -- tasking is involved or not (e.g. the Get/Set_Jmpbuf_Address that needs
39 -- to provide a different value for each task). To avoid dragging in the
40 -- tasking all the time, we use a system of soft links where the links are
41 -- initialized to non-tasking versions, and then if the tasking is
42 -- initialized, they are reset to the real tasking versions.
45 with System.Stack_Checking;
47 package System.Soft_Links is
48 pragma Elaborate_Body;
50 subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
51 subtype EO is Ada.Exceptions.Exception_Occurrence;
53 function Current_Target_Exception return EO;
55 (Ada, Current_Target_Exception,
56 "__gnat_current_target_exception");
57 -- Import this subprogram from the private part of Ada.Exceptions.
59 -- First we have the access subprogram types used to establish the links.
60 -- The approach is to establish variables containing access subprogram
61 -- values which by default point to dummy no tasking versions of routines.
63 type No_Param_Proc is access procedure;
64 type Addr_Param_Proc is access procedure (Addr : Address);
66 type Get_Address_Call is access function return Address;
67 type Set_Address_Call is access procedure (Addr : Address);
68 type Set_Address_Call2 is access procedure
69 (Self_ID : Address; Addr : Address);
71 type Get_Integer_Call is access function return Integer;
72 type Set_Integer_Call is access procedure (Len : Integer);
74 type Get_EOA_Call is access function return EOA;
75 type Set_EOA_Call is access procedure (Excep : EOA);
76 type Set_EO_Call is access procedure (Excep : EO);
78 type Special_EO_Call is access
79 procedure (Excep : EO := Current_Target_Exception);
81 type Timed_Delay_Call is access
82 procedure (Time : Duration; Mode : Integer);
84 type Get_Stack_Access_Call is access
85 function return Stack_Checking.Stack_Access;
87 -- Suppress checks on all these types, since we know corrresponding
88 -- values can never be null (the soft links are always initialized).
90 pragma Suppress (Access_Check, No_Param_Proc);
91 pragma Suppress (Access_Check, Addr_Param_Proc);
92 pragma Suppress (Access_Check, Get_Address_Call);
93 pragma Suppress (Access_Check, Set_Address_Call);
94 pragma Suppress (Access_Check, Set_Address_Call2);
95 pragma Suppress (Access_Check, Get_Integer_Call);
96 pragma Suppress (Access_Check, Set_Integer_Call);
97 pragma Suppress (Access_Check, Get_EOA_Call);
98 pragma Suppress (Access_Check, Set_EOA_Call);
99 pragma Suppress (Access_Check, Timed_Delay_Call);
100 pragma Suppress (Access_Check, Get_Stack_Access_Call);
102 -- The following one is not related to tasking/no-tasking but to the
103 -- traceback decorators for exceptions.
105 type Traceback_Decorator_Wrapper_Call is access
106 function (Traceback : System.Address;
110 -- Declarations for the no tasking versions of the required routines
112 procedure Abort_Defer_NT;
113 -- Defer task abortion (non-tasking case, does nothing)
115 procedure Abort_Undefer_NT;
116 -- Undefer task abortion (non-tasking case, does nothing)
118 procedure Abort_Handler_NT;
119 -- Handle task abortion (non-tasking case, does nothing). Currently,
120 -- only VMS uses this.
122 procedure Update_Exception_NT
123 (X : EO := Current_Target_Exception);
124 -- Handle exception setting. This routine is provided for targets
125 -- which have built-in exception handling such as the Java Virtual
126 -- Machine. Currently, only JGNAT uses this. See 4jexcept.ads for
127 -- an explanation on how this routine is used.
129 function Check_Abort_Status_NT return Integer;
130 -- Returns Boolean'Pos (True) iff abort signal should raise
131 -- Standard.Abort_Signal.
133 procedure Task_Lock_NT;
134 -- Lock out other tasks (non-tasking case, does nothing)
136 procedure Task_Unlock_NT;
137 -- Release lock set by Task_Lock (non-tasking case, does nothing)
139 procedure Null_Adafinal;
140 -- Shuts down the runtime system (non-tasking no-finalization case,
143 Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
144 pragma Suppress (Access_Check, Abort_Defer);
145 -- Defer task abortion (task/non-task case as appropriate)
147 Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
148 pragma Suppress (Access_Check, Abort_Undefer);
149 -- Undefer task abortion (task/non-task case as appropriate)
151 Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
152 -- Handle task abortion (task/non-task case as appropriate)
154 Update_Exception : Special_EO_Call := Update_Exception_NT'Access;
155 -- Handle exception setting and tasking polling when appropriate
157 Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access;
158 -- Called when Abort_Signal is delivered to the process. Checks to
159 -- see if signal should result in raising Standard.Abort_Signal.
161 Lock_Task : No_Param_Proc := Task_Lock_NT'Access;
162 -- Locks out other tasks. Preceding a section of code by Task_Lock and
163 -- following it by Task_Unlock creates a critical region. This is used
164 -- for ensuring that a region of non-tasking code (such as code used to
165 -- allocate memory) is tasking safe. Note that it is valid for calls to
166 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
167 -- only the corresponding outer level Task_Unlock will actually unlock.
168 -- This routine also prevents against asynchronous aborts (abort is
171 Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access;
172 -- Releases lock previously set by call to Lock_Task. In the nested case,
173 -- all nested locks must be released before other tasks competing for the
174 -- tasking lock are released.
176 -- In the non nested case, this routine terminates the protection against
177 -- asynchronous aborts introduced by Lock_Task (unless abort was already
178 -- deferred before the call to Lock_Task (e.g in a protected procedures).
180 -- Note: the recommended protocol for using Lock_Task and Unlock_Task
183 -- Locked_Processing : begin
184 -- System.Soft_Links.Lock_Task.all;
186 -- System.Soft_Links..Unlock_Task.all;
190 -- System.Soft_Links..Unlock_Task.all;
192 -- end Locked_Processing;
194 -- This ensures that the lock is not left set if an exception is raised
195 -- explicitly or implicitly during the critical locked region.
197 Adafinal : No_Param_Proc := Null_Adafinal'Access;
198 -- Performs the finalization of the Ada Runtime.
200 function Get_Jmpbuf_Address_NT return Address;
201 procedure Set_Jmpbuf_Address_NT (Addr : Address);
203 Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access;
204 Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access;
206 function Get_Sec_Stack_Addr_NT return Address;
207 procedure Set_Sec_Stack_Addr_NT (Addr : Address);
209 Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access;
210 Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access;
212 function Get_Machine_State_Addr_NT return Address;
213 procedure Set_Machine_State_Addr_NT (Addr : Address);
215 Get_Machine_State_Addr : Get_Address_Call
216 := Get_Machine_State_Addr_NT'Access;
217 Set_Machine_State_Addr : Set_Address_Call
218 := Set_Machine_State_Addr_NT'Access;
220 function Get_Exc_Stack_Addr_NT return Address;
221 procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address);
222 -- Self_ID is a Task_ID, but in the non-tasking case there is no
223 -- Task_ID type available, so make do with Address.
225 Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
226 Set_Exc_Stack_Addr : Set_Address_Call2 := Set_Exc_Stack_Addr_NT'Access;
228 function Get_Current_Excep_NT return EOA;
230 Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
232 function Get_Stack_Info_NT return Stack_Checking.Stack_Access;
234 Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;
236 --------------------------
237 -- Master_Id Soft-Links --
238 --------------------------
240 -- Soft-Links are used for procedures that manipulate Master_Ids because
241 -- a Master_Id must be generated for access to limited class-wide types,
242 -- whose root may be extended with task components.
244 function Current_Master_NT return Integer;
245 procedure Enter_Master_NT;
246 procedure Complete_Master_NT;
248 Current_Master : Get_Integer_Call := Current_Master_NT'Access;
249 Enter_Master : No_Param_Proc := Enter_Master_NT'Access;
250 Complete_Master : No_Param_Proc := Complete_Master_NT'Access;
252 ----------------------
253 -- Delay Soft-Links --
254 ----------------------
256 -- Soft-Links are used for procedures that manipulate time to avoid
257 -- dragging the tasking run time when using delay statements.
259 Timed_Delay : Timed_Delay_Call;
261 -------------------------------------
262 -- Exception Tracebacks Soft-Links --
263 -------------------------------------
265 Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call;
266 -- Wrapper to the possible user specified traceback decorator to be
267 -- called during automatic output of exception data.
269 -- The nullity of this wrapper shall correspond to the nullity of the
270 -- current actual decorator. This is ensured first by the null initial
271 -- value of the corresponding variables, and then by Set_Trace_Decorator
274 pragma Atomic (Traceback_Decorator_Wrapper);
275 -- Since concurrent read/write operations may occur on this variable.
276 -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for
277 -- a more detailed description of the potential problems.
279 ------------------------
280 -- Task Specific Data --
281 ------------------------
283 -- Here we define a single type that encapsulates the various task
284 -- specific data. This type is used to store the necessary data into
285 -- the Task_Control_Block or into a global variable in the non tasking
289 Pri_Stack_Info : aliased Stack_Checking.Stack_Info;
290 -- Information on stack (Base/Limit/Size) that is used
291 -- by System.Stack_Checking. If this TSD does not belong to
292 -- the environment task, the Size field must be initialized
293 -- to the tasks requested stack size before the task can do
294 -- its first stack check.
296 Jmpbuf_Address : Address := Null_Address;
297 -- Address of jump buffer used to store the address of the
298 -- current longjmp/setjmp buffer for exception management.
299 -- These buffers are threaded into a stack, and the address
300 -- here is the top of the stack. A null address means that
301 -- no exception handler is currently active.
303 Sec_Stack_Addr : Address := Null_Address;
304 -- Address of currently allocated secondary stack
306 Exc_Stack_Addr : Address := Null_Address;
307 -- Address of a task-specific stack used for the propagation of
308 -- exceptions in response to synchronous faults. This alternate
309 -- stack is necessary when propagating Storage_Error resulting
310 -- from a stack overflow, as the task's primary stack is full.
311 -- This is currently only used on the SGI, and this value stays
312 -- null on other platforms.
314 Current_Excep : aliased EO;
315 -- Exception occurrence that contains the information for the
316 -- current exception. Note that any exception in the same task
317 -- destroys this information, so the data in this variable must
318 -- be copied out before another exception can occur.
320 Machine_State_Addr : Address := Null_Address;
324 procedure Create_TSD (New_TSD : in out TSD);
325 pragma Inline (Create_TSD);
326 -- Called from s-tassta when a new thread is created to perform
327 -- any required initialization of the TSD.
329 procedure Destroy_TSD (Old_TSD : in out TSD);
330 pragma Inline (Destroy_TSD);
331 -- Called from s-tassta just before a thread is destroyed to perform
332 -- any required finalization.
334 function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
335 pragma Inline (Get_GNAT_Exception);
336 -- This function obtains the Exception_Id from the Exception_Occurrence
337 -- referenced by the Current_Excep field of the task specific data, i.e.
338 -- the call is equivalent to
339 -- Exception_Identity (Get_Current_Exception.all)
341 -- Export the Get/Set routines for the various Task Specific Data (TSD)
342 -- elements as callable subprograms instead of objects of access to
345 function Get_Jmpbuf_Address_Soft return Address;
346 procedure Set_Jmpbuf_Address_Soft (Addr : Address);
347 pragma Inline (Get_Jmpbuf_Address_Soft);
348 pragma Inline (Set_Jmpbuf_Address_Soft);
350 function Get_Sec_Stack_Addr_Soft return Address;
351 procedure Set_Sec_Stack_Addr_Soft (Addr : Address);
352 pragma Inline (Get_Sec_Stack_Addr_Soft);
353 pragma Inline (Set_Sec_Stack_Addr_Soft);
355 function Get_Exc_Stack_Addr_Soft return Address;
356 procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address);
357 pragma Inline (Get_Exc_Stack_Addr_Soft);
358 pragma Inline (Set_Exc_Stack_Addr_Soft);
360 function Get_Machine_State_Addr_Soft return Address;
361 procedure Set_Machine_State_Addr_Soft (Addr : Address);
362 pragma Inline (Get_Machine_State_Addr_Soft);
363 pragma Inline (Set_Machine_State_Addr_Soft);
365 end System.Soft_Links;