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