File : s-soflin.ads
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . S O F T _ L I N K S --
6 -- --
7 -- S p e c --
8 -- --
9 -- Copyright (C) 1992-2015, 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 -- --
19 -- --
20 -- --
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 package contains a set of subprogram access variables that access
33 -- some low-level primitives that are different depending whether tasking is
34 -- involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a
35 -- different value for each task). To avoid dragging in the tasking runtimes
36 -- all the time, we use a system of soft links where the links are
37 -- initialized to non-tasking versions, and then if the tasking support is
38 -- initialized, they are set to the real tasking versions.
39
40 pragma Compiler_Unit_Warning;
41
42 with Ada.Exceptions;
43 with System.Stack_Checking;
44
45 package System.Soft_Links is
46 pragma Preelaborate;
47
48 subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
49 subtype EO is Ada.Exceptions.Exception_Occurrence;
50
51 function Current_Target_Exception return EO;
52 pragma Import
53 (Ada, Current_Target_Exception, "__gnat_current_target_exception");
54 -- Import this subprogram from the private part of Ada.Exceptions
55
56 -- First we have the access subprogram types used to establish the links.
57 -- The approach is to establish variables containing access subprogram
58 -- values, which by default point to dummy no tasking versions of routines.
59
60 type No_Param_Proc is access procedure;
61 pragma Favor_Top_Level (No_Param_Proc);
62 pragma Suppress_Initialization (No_Param_Proc);
63 -- Some uninitialized objects of that type are initialized by the Binder
64 -- so it is important that such objects are not reset to null during
65 -- elaboration.
66
67 type Addr_Param_Proc is access procedure (Addr : Address);
68 pragma Favor_Top_Level (Addr_Param_Proc);
69 type EO_Param_Proc is access procedure (Excep : EO);
70 pragma Favor_Top_Level (EO_Param_Proc);
71
72 type Get_Address_Call is access function return Address;
73 pragma Favor_Top_Level (Get_Address_Call);
74 type Set_Address_Call is access procedure (Addr : Address);
75 pragma Favor_Top_Level (Set_Address_Call);
76 type Set_Address_Call2 is access procedure
77 (Self_ID : Address; Addr : Address);
78 pragma Favor_Top_Level (Set_Address_Call2);
79
80 type Get_Integer_Call is access function return Integer;
81 pragma Favor_Top_Level (Get_Integer_Call);
82 type Set_Integer_Call is access procedure (Len : Integer);
83 pragma Favor_Top_Level (Set_Integer_Call);
84
85 type Get_EOA_Call is access function return EOA;
86 pragma Favor_Top_Level (Get_EOA_Call);
87 type Set_EOA_Call is access procedure (Excep : EOA);
88 pragma Favor_Top_Level (Set_EOA_Call);
89 type Set_EO_Call is access procedure (Excep : EO);
90 pragma Favor_Top_Level (Set_EO_Call);
91
92 type Special_EO_Call is access
93 procedure (Excep : EO := Current_Target_Exception);
94 pragma Favor_Top_Level (Special_EO_Call);
95
96 type Timed_Delay_Call is access
97 procedure (Time : Duration; Mode : Integer);
98 pragma Favor_Top_Level (Timed_Delay_Call);
99
100 type Get_Stack_Access_Call is access
101 function return Stack_Checking.Stack_Access;
102 pragma Favor_Top_Level (Get_Stack_Access_Call);
103
104 type Task_Name_Call is access
105 function return String;
106 pragma Favor_Top_Level (Task_Name_Call);
107
108 -- Suppress checks on all these types, since we know the corresponding
109 -- values can never be null (the soft links are always initialized).
110
111 pragma Suppress (Access_Check, No_Param_Proc);
112 pragma Suppress (Access_Check, Addr_Param_Proc);
113 pragma Suppress (Access_Check, EO_Param_Proc);
114 pragma Suppress (Access_Check, Get_Address_Call);
115 pragma Suppress (Access_Check, Set_Address_Call);
116 pragma Suppress (Access_Check, Set_Address_Call2);
117 pragma Suppress (Access_Check, Get_Integer_Call);
118 pragma Suppress (Access_Check, Set_Integer_Call);
119 pragma Suppress (Access_Check, Get_EOA_Call);
120 pragma Suppress (Access_Check, Set_EOA_Call);
121 pragma Suppress (Access_Check, Timed_Delay_Call);
122 pragma Suppress (Access_Check, Get_Stack_Access_Call);
123 pragma Suppress (Access_Check, Task_Name_Call);
124
125 -- The following one is not related to tasking/no-tasking but to the
126 -- traceback decorators for exceptions.
127
128 type Traceback_Decorator_Wrapper_Call is access
129 function (Traceback : System.Address;
130 Len : Natural)
131 return String;
132 pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call);
133
134 -- Declarations for the no tasking versions of the required routines
135
136 procedure Abort_Defer_NT;
137 -- Defer task abort (non-tasking case, does nothing)
138
139 procedure Abort_Undefer_NT;
140 -- Undefer task abort (non-tasking case, does nothing)
141
142 procedure Abort_Handler_NT;
143 -- Handle task abort (non-tasking case, does nothing). Currently, no port
144 -- makes use of this, but we retain the interface for possible future use.
145
146 function Check_Abort_Status_NT return Integer;
147 -- Returns Boolean'Pos (True) iff abort signal should raise
148 -- Standard'Abort_Signal.
149
150 procedure Task_Lock_NT;
151 -- Lock out other tasks (non-tasking case, does nothing)
152
153 procedure Task_Unlock_NT;
154 -- Release lock set by Task_Lock (non-tasking case, does nothing)
155
156 procedure Task_Termination_NT (Excep : EO);
157 -- Handle task termination routines for the environment task (non-tasking
158 -- case, does nothing).
159
160 procedure Adafinal_NT;
161 -- Shuts down the runtime system (non-tasking case)
162
163 Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
164 pragma Suppress (Access_Check, Abort_Defer);
165 -- Defer task abort (task/non-task case as appropriate)
166
167 Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
168 pragma Suppress (Access_Check, Abort_Undefer);
169 -- Undefer task abort (task/non-task case as appropriate)
170
171 Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
172 -- Handle task abort (task/non-task case as appropriate)
173
174 Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access;
175 -- Called when Abort_Signal is delivered to the process. Checks to
176 -- see if signal should result in raising Standard'Abort_Signal.
177
178 Lock_Task : No_Param_Proc := Task_Lock_NT'Access;
179 -- Locks out other tasks. Preceding a section of code by Task_Lock and
180 -- following it by Task_Unlock creates a critical region. This is used
181 -- for ensuring that a region of non-tasking code (such as code used to
182 -- allocate memory) is tasking safe. Note that it is valid for calls to
183 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
184 -- only the corresponding outer level Task_Unlock will actually unlock.
185 -- This routine also prevents against asynchronous aborts (abort is
186 -- deferred).
187
188 Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access;
189 -- Releases lock previously set by call to Lock_Task. In the nested case,
190 -- all nested locks must be released before other tasks competing for the
191 -- tasking lock are released.
192 --
193 -- In the non nested case, this routine terminates the protection against
194 -- asynchronous aborts introduced by Lock_Task (unless abort was already
195 -- deferred before the call to Lock_Task (e.g in a protected procedures).
196 --
197 -- Note: the recommended protocol for using Lock_Task and Unlock_Task
198 -- is as follows:
199 --
200 -- Locked_Processing : begin
201 -- System.Soft_Links.Lock_Task.all;
202 -- ...
203 -- System.Soft_Links.Unlock_Task.all;
204 --
205 -- exception
206 -- when others =>
207 -- System.Soft_Links.Unlock_Task.all;
208 -- raise;
209 -- end Locked_Processing;
210 --
211 -- This ensures that the lock is not left set if an exception is raised
212 -- explicitly or implicitly during the critical locked region.
213
214 Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
215 -- Handle task termination routines (task/non-task case as appropriate)
216
217 Finalize_Library_Objects : No_Param_Proc;
218 pragma Export (C, Finalize_Library_Objects,
219 "__gnat_finalize_library_objects");
220 -- Will be initialized by the binder
221
222 Adafinal : No_Param_Proc := Adafinal_NT'Access;
223 -- Performs the finalization of the Ada Runtime
224
225 function Get_Jmpbuf_Address_NT return Address;
226 procedure Set_Jmpbuf_Address_NT (Addr : Address);
227
228 Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access;
229 Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access;
230
231 function Get_Sec_Stack_Addr_NT return Address;
232 procedure Set_Sec_Stack_Addr_NT (Addr : Address);
233
234 Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access;
235 Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access;
236
237 function Get_Current_Excep_NT return EOA;
238
239 Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
240
241 function Get_Stack_Info_NT return Stack_Checking.Stack_Access;
242
243 Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;
244
245 --------------------------
246 -- Master_Id Soft-Links --
247 --------------------------
248
249 -- Soft-Links are used for procedures that manipulate Master_Ids because
250 -- a Master_Id must be generated for access to limited class-wide types,
251 -- whose root may be extended with task components.
252
253 function Current_Master_NT return Integer;
254 procedure Enter_Master_NT;
255 procedure Complete_Master_NT;
256
257 Current_Master : Get_Integer_Call := Current_Master_NT'Access;
258 Enter_Master : No_Param_Proc := Enter_Master_NT'Access;
259 Complete_Master : No_Param_Proc := Complete_Master_NT'Access;
260
261 ----------------------
262 -- Delay Soft-Links --
263 ----------------------
264
265 -- Soft-Links are used for procedures that manipulate time to avoid
266 -- dragging the tasking run time when using delay statements.
267
268 Timed_Delay : Timed_Delay_Call;
269
270 --------------------------
271 -- Task Name Soft-Links --
272 --------------------------
273
274 function Task_Name_NT return String;
275
276 Task_Name : Task_Name_Call := Task_Name_NT'Access;
277
278 -------------------------------------
279 -- Exception Tracebacks Soft-Links --
280 -------------------------------------
281
282 Library_Exception : EO;
283 -- Library-level finalization routines use this common reference to store
284 -- the first library-level exception which occurs during finalization.
285
286 Library_Exception_Set : Boolean := False;
287 -- Used in conjunction with Library_Exception, set when an exception has
288 -- been stored.
289
290 Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call;
291 -- Wrapper to the possible user specified traceback decorator to be
292 -- called during automatic output of exception data.
293
294 -- The null value of this wrapper correspond sto the null value of the
295 -- current actual decorator. This is ensured first by the null initial
296 -- value of the corresponding variables, and then by Set_Trace_Decorator
297 -- in g-exctra.adb.
298
299 pragma Atomic (Traceback_Decorator_Wrapper);
300 -- Since concurrent read/write operations may occur on this variable.
301 -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for
302 -- a more detailed description of the potential problems.
303
304 procedure Save_Library_Occurrence (E : EOA);
305 -- When invoked, this routine saves an exception occurrence into a hidden
306 -- reference. Subsequent calls will have no effect.
307
308 ------------------------
309 -- Task Specific Data --
310 ------------------------
311
312 -- Here we define a single type that encapsulates the various task
313 -- specific data. This type is used to store the necessary data into the
314 -- Task_Control_Block or into a global variable in the non tasking case.
315
316 type TSD is record
317 Pri_Stack_Info : aliased Stack_Checking.Stack_Info;
318 -- Information on stack (Base/Limit/Size) used by System.Stack_Checking.
319 -- If this TSD does not belong to the environment task, the Size field
320 -- must be initialized to the tasks requested stack size before the task
321 -- can do its first stack check.
322
323 pragma Warnings (Off);
324 -- Needed because we are giving a non-static default to an object in
325 -- a preelaborated unit, which is formally not permitted, but OK here.
326
327 Jmpbuf_Address : System.Address := System.Null_Address;
328 -- Address of jump buffer used to store the address of the current
329 -- longjmp/setjmp buffer for exception management. These buffers are
330 -- threaded into a stack, and the address here is the top of the stack.
331 -- A null address means that no exception handler is currently active.
332
333 Sec_Stack_Addr : System.Address := System.Null_Address;
334 pragma Warnings (On);
335 -- Address of currently allocated secondary stack
336
337 Current_Excep : aliased EO;
338 -- Exception occurrence that contains the information for the current
339 -- exception. Note that any exception in the same task destroys this
340 -- information, so the data in this variable must be copied out before
341 -- another exception can occur.
342 --
343 -- Also act as a list of the active exceptions in the case of the GCC
344 -- exception mechanism, organized as a stack with the most recent first.
345 end record;
346
347 procedure Create_TSD (New_TSD : in out TSD);
348 pragma Inline (Create_TSD);
349 -- Called from s-tassta when a new thread is created to perform
350 -- any required initialization of the TSD.
351
352 procedure Destroy_TSD (Old_TSD : in out TSD);
353 pragma Inline (Destroy_TSD);
354 -- Called from s-tassta just before a thread is destroyed to perform
355 -- any required finalization.
356
357 function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
358 pragma Inline (Get_GNAT_Exception);
359 -- This function obtains the Exception_Id from the Exception_Occurrence
360 -- referenced by the Current_Excep field of the task specific data, i.e.
361 -- the call is equivalent to
362 -- Exception_Identity (Get_Current_Exception.all)
363
364 -- Export the Get/Set routines for the various Task Specific Data (TSD)
365 -- elements as callable subprograms instead of objects of access to
366 -- subprogram types.
367
368 function Get_Jmpbuf_Address_Soft return Address;
369 procedure Set_Jmpbuf_Address_Soft (Addr : Address);
370 pragma Inline (Get_Jmpbuf_Address_Soft);
371 pragma Inline (Set_Jmpbuf_Address_Soft);
372
373 function Get_Sec_Stack_Addr_Soft return Address;
374 procedure Set_Sec_Stack_Addr_Soft (Addr : Address);
375 pragma Inline (Get_Sec_Stack_Addr_Soft);
376 pragma Inline (Set_Sec_Stack_Addr_Soft);
377
378 -- The following is a dummy record designed to mimic Communication_Block as
379 -- defined in s-tpobop.ads:
380
381 -- type Communication_Block is record
382 -- Self : Task_Id; -- An access type
383 -- Enqueued : Boolean := True;
384 -- Cancelled : Boolean := False;
385 -- end record;
386
387 -- The record is used in the construction of the predefined dispatching
388 -- primitive _disp_asynchronous_select in order to avoid the import of
389 -- System.Tasking.Protected_Objects.Operations. Note that this package
390 -- is always imported in the presence of interfaces since the dispatch
391 -- table uses entities from here.
392
393 type Dummy_Communication_Block is record
394 Comp_1 : Address; -- Address and access have the same size
395 Comp_2 : Boolean;
396 Comp_3 : Boolean;
397 end record;
398
399 end System.Soft_Links;