1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S O F T _ L I N K S --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This package contains a set of subprogram access variables that access
35 -- some low-level primitives that are different depending whether tasking is
36 -- involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a
37 -- different value for each task). To avoid dragging in the tasking runtimes
38 -- all the time, we use a system of soft links where the links are
39 -- initialized to non-tasking versions, and then if the tasking support is
40 -- initialized, they are set to the real tasking versions.
43 with System.Stack_Checking;
45 package System.Soft_Links is
46 pragma Warnings (Off);
47 pragma Preelaborate_05;
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, "__gnat_current_target_exception");
56 -- Import this subprogram from the private part of Ada.Exceptions
58 -- First we have the access subprogram types used to establish the links.
59 -- The approach is to establish variables containing access subprogram
60 -- values, which by default point to dummy no tasking versions of routines.
62 type No_Param_Proc is access procedure;
63 type Addr_Param_Proc is access procedure (Addr : Address);
64 type EO_Param_Proc is access procedure (Excep : EO);
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 type Task_Name_Call is access
88 function return String;
90 -- Suppress checks on all these types, since we know the corrresponding
91 -- values can never be null (the soft links are always initialized).
93 pragma Suppress (Access_Check, No_Param_Proc);
94 pragma Suppress (Access_Check, Addr_Param_Proc);
95 pragma Suppress (Access_Check, EO_Param_Proc);
96 pragma Suppress (Access_Check, Get_Address_Call);
97 pragma Suppress (Access_Check, Set_Address_Call);
98 pragma Suppress (Access_Check, Set_Address_Call2);
99 pragma Suppress (Access_Check, Get_Integer_Call);
100 pragma Suppress (Access_Check, Set_Integer_Call);
101 pragma Suppress (Access_Check, Get_EOA_Call);
102 pragma Suppress (Access_Check, Set_EOA_Call);
103 pragma Suppress (Access_Check, Timed_Delay_Call);
104 pragma Suppress (Access_Check, Get_Stack_Access_Call);
105 pragma Suppress (Access_Check, Task_Name_Call);
107 -- The following one is not related to tasking/no-tasking but to the
108 -- traceback decorators for exceptions.
110 type Traceback_Decorator_Wrapper_Call is access
111 function (Traceback : System.Address;
115 -- Declarations for the no tasking versions of the required routines
117 procedure Abort_Defer_NT;
118 -- Defer task abort (non-tasking case, does nothing)
120 procedure Abort_Undefer_NT;
121 -- Undefer task abort (non-tasking case, does nothing)
123 procedure Abort_Handler_NT;
124 -- Handle task abort (non-tasking case, does nothing). Currently, only VMS
127 procedure Update_Exception_NT (X : EO := Current_Target_Exception);
128 -- Handle exception setting. This routine is provided for targets that
129 -- have built-in exception handling such as the Java Virtual Machine.
130 -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on
131 -- how this routine is used.
133 function Check_Abort_Status_NT return Integer;
134 -- Returns Boolean'Pos (True) iff abort signal should raise
135 -- Standard.Abort_Signal.
137 procedure Task_Lock_NT;
138 -- Lock out other tasks (non-tasking case, does nothing)
140 procedure Task_Unlock_NT;
141 -- Release lock set by Task_Lock (non-tasking case, does nothing)
143 procedure Task_Termination_NT (Excep : EO);
144 -- Handle task termination routines for the environment task (non-tasking
145 -- case, does nothing).
147 procedure Null_Finalize_Global_List;
148 -- Finalize global list for controlled objects (does nothing)
150 procedure Adafinal_NT;
151 -- Shuts down the runtime system (non-tasking case)
153 Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
154 pragma Suppress (Access_Check, Abort_Defer);
155 -- Defer task abort (task/non-task case as appropriate)
157 Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
158 pragma Suppress (Access_Check, Abort_Undefer);
159 -- Undefer task abort (task/non-task case as appropriate)
161 Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
162 -- Handle task abort (task/non-task case as appropriate)
164 Update_Exception : Special_EO_Call := Update_Exception_NT'Access;
165 -- Handle exception setting and tasking polling when appropriate
167 Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access;
168 -- Called when Abort_Signal is delivered to the process. Checks to
169 -- see if signal should result in raising Standard.Abort_Signal.
171 Lock_Task : No_Param_Proc := Task_Lock_NT'Access;
172 -- Locks out other tasks. Preceding a section of code by Task_Lock and
173 -- following it by Task_Unlock creates a critical region. This is used
174 -- for ensuring that a region of non-tasking code (such as code used to
175 -- allocate memory) is tasking safe. Note that it is valid for calls to
176 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
177 -- only the corresponding outer level Task_Unlock will actually unlock.
178 -- This routine also prevents against asynchronous aborts (abort is
181 Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access;
182 -- Releases lock previously set by call to Lock_Task. In the nested case,
183 -- all nested locks must be released before other tasks competing for the
184 -- tasking lock are released.
186 -- In the non nested case, this routine terminates the protection against
187 -- asynchronous aborts introduced by Lock_Task (unless abort was already
188 -- deferred before the call to Lock_Task (e.g in a protected procedures).
190 -- Note: the recommended protocol for using Lock_Task and Unlock_Task
193 -- Locked_Processing : begin
194 -- System.Soft_Links.Lock_Task.all;
196 -- System.Soft_Links..Unlock_Task.all;
200 -- System.Soft_Links..Unlock_Task.all;
202 -- end Locked_Processing;
204 -- This ensures that the lock is not left set if an exception is raised
205 -- explicitly or implicitly during the critical locked region.
207 Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
208 -- Handle task termination routines (task/non-task case as appropriate)
210 Finalize_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access;
211 -- Performs finalization of global list for controlled objects
213 Adafinal : No_Param_Proc := Adafinal_NT'Access;
214 -- Performs the finalization of the Ada Runtime
216 function Get_Jmpbuf_Address_NT return Address;
217 procedure Set_Jmpbuf_Address_NT (Addr : Address);
219 Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access;
220 Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access;
222 function Get_Sec_Stack_Addr_NT return Address;
223 procedure Set_Sec_Stack_Addr_NT (Addr : Address);
225 Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access;
226 Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access;
228 function Get_Exc_Stack_Addr_NT return Address;
229 Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
231 function Get_Current_Excep_NT return EOA;
233 Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
235 function Get_Stack_Info_NT return Stack_Checking.Stack_Access;
237 Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;
239 --------------------------
240 -- Master_Id Soft-Links --
241 --------------------------
243 -- Soft-Links are used for procedures that manipulate Master_Ids because
244 -- a Master_Id must be generated for access to limited class-wide types,
245 -- whose root may be extended with task components.
247 function Current_Master_NT return Integer;
248 procedure Enter_Master_NT;
249 procedure Complete_Master_NT;
251 Current_Master : Get_Integer_Call := Current_Master_NT'Access;
252 Enter_Master : No_Param_Proc := Enter_Master_NT'Access;
253 Complete_Master : No_Param_Proc := Complete_Master_NT'Access;
255 ----------------------
256 -- Delay Soft-Links --
257 ----------------------
259 -- Soft-Links are used for procedures that manipulate time to avoid
260 -- dragging the tasking run time when using delay statements.
262 Timed_Delay : Timed_Delay_Call;
264 --------------------------
265 -- Task Name Soft-Links --
266 --------------------------
268 function Task_Name_NT return String;
270 Task_Name : Task_Name_Call := Task_Name_NT'Access;
272 -------------------------------------
273 -- Exception Tracebacks Soft-Links --
274 -------------------------------------
276 Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call;
277 -- Wrapper to the possible user specified traceback decorator to be
278 -- called during automatic output of exception data.
280 -- The nullity of this wrapper shall correspond to the nullity of the
281 -- current actual decorator. This is ensured first by the null initial
282 -- value of the corresponding variables, and then by Set_Trace_Decorator
285 pragma Atomic (Traceback_Decorator_Wrapper);
286 -- Since concurrent read/write operations may occur on this variable.
287 -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for
288 -- a more detailed description of the potential problems.
290 ------------------------
291 -- Task Specific Data --
292 ------------------------
294 -- Here we define a single type that encapsulates the various task
295 -- specific data. This type is used to store the necessary data into
296 -- the Task_Control_Block or into a global variable in the non tasking
300 Pri_Stack_Info : aliased Stack_Checking.Stack_Info;
301 -- Information on stack (Base/Limit/Size) that is used
302 -- by System.Stack_Checking. If this TSD does not belong to
303 -- the environment task, the Size field must be initialized
304 -- to the tasks requested stack size before the task can do
305 -- its first stack check.
307 pragma Warnings (Off);
308 Jmpbuf_Address : System.Address := System.Null_Address;
309 -- Address of jump buffer used to store the address of the
310 -- current longjmp/setjmp buffer for exception management.
311 -- These buffers are threaded into a stack, and the address
312 -- here is the top of the stack. A null address means that
313 -- no exception handler is currently active.
315 Sec_Stack_Addr : System.Address := System.Null_Address;
316 pragma Warnings (On);
317 -- Address of currently allocated secondary stack
319 Current_Excep : aliased EO;
320 -- Exception occurrence that contains the information for the
321 -- current exception. Note that any exception in the same task
322 -- destroys this information, so the data in this variable must
323 -- be copied out before another exception can occur.
325 -- Also act as a list of the active exceptions in the case of the GCC
326 -- exception mechanism, organized as a stack with the most recent first.
329 procedure Create_TSD (New_TSD : in out TSD);
330 pragma Inline (Create_TSD);
331 -- Called from s-tassta when a new thread is created to perform
332 -- any required initialization of the TSD.
334 procedure Destroy_TSD (Old_TSD : in out TSD);
335 pragma Inline (Destroy_TSD);
336 -- Called from s-tassta just before a thread is destroyed to perform
337 -- any required finalization.
339 function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
340 pragma Inline (Get_GNAT_Exception);
341 -- This function obtains the Exception_Id from the Exception_Occurrence
342 -- referenced by the Current_Excep field of the task specific data, i.e.
343 -- the call is equivalent to
344 -- Exception_Identity (Get_Current_Exception.all)
346 -- Export the Get/Set routines for the various Task Specific Data (TSD)
347 -- elements as callable subprograms instead of objects of access to
350 function Get_Jmpbuf_Address_Soft return Address;
351 procedure Set_Jmpbuf_Address_Soft (Addr : Address);
352 pragma Inline (Get_Jmpbuf_Address_Soft);
353 pragma Inline (Set_Jmpbuf_Address_Soft);
355 function Get_Sec_Stack_Addr_Soft return Address;
356 procedure Set_Sec_Stack_Addr_Soft (Addr : Address);
357 pragma Inline (Get_Sec_Stack_Addr_Soft);
358 pragma Inline (Set_Sec_Stack_Addr_Soft);
360 function Get_Exc_Stack_Addr_Soft return Address;
362 end System.Soft_Links;