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