]>
Commit | Line | Data |
---|---|---|
cacbc350 RK |
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 | -- -- | |
bb9c600b | 9 | -- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- |
cacbc350 RK |
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- -- | |
748086b7 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
cacbc350 RK |
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 -- | |
748086b7 JJ |
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/>. -- | |
cacbc350 RK |
26 | -- -- |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
cacbc350 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | -- This package contains a set of subprogram access variables that access | |
87ace727 RD |
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. | |
cacbc350 | 39 | |
2d9ea47f | 40 | pragma Compiler_Unit; |
2d9ea47f | 41 | |
cacbc350 RK |
42 | with Ada.Exceptions; |
43 | with System.Stack_Checking; | |
44 | ||
45 | package System.Soft_Links is | |
e4f422b8 | 46 | pragma Preelaborate; |
cacbc350 RK |
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 | |
a99ada67 | 53 | (Ada, Current_Target_Exception, "__gnat_current_target_exception"); |
1a49cf99 | 54 | -- Import this subprogram from the private part of Ada.Exceptions |
cacbc350 RK |
55 | |
56 | -- First we have the access subprogram types used to establish the links. | |
57 | -- The approach is to establish variables containing access subprogram | |
87ace727 | 58 | -- values, which by default point to dummy no tasking versions of routines. |
cacbc350 RK |
59 | |
60 | type No_Param_Proc is access procedure; | |
90de1450 | 61 | pragma Favor_Top_Level (No_Param_Proc); |
df3e68b1 HK |
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 | |
f9ad6b62 | 65 | -- elaboration. |
df3e68b1 | 66 | |
cacbc350 | 67 | type Addr_Param_Proc is access procedure (Addr : Address); |
90de1450 | 68 | pragma Favor_Top_Level (Addr_Param_Proc); |
81408d49 | 69 | type EO_Param_Proc is access procedure (Excep : EO); |
90de1450 | 70 | pragma Favor_Top_Level (EO_Param_Proc); |
cacbc350 RK |
71 | |
72 | type Get_Address_Call is access function return Address; | |
90de1450 | 73 | pragma Favor_Top_Level (Get_Address_Call); |
cacbc350 | 74 | type Set_Address_Call is access procedure (Addr : Address); |
90de1450 | 75 | pragma Favor_Top_Level (Set_Address_Call); |
cacbc350 RK |
76 | type Set_Address_Call2 is access procedure |
77 | (Self_ID : Address; Addr : Address); | |
90de1450 | 78 | pragma Favor_Top_Level (Set_Address_Call2); |
cacbc350 RK |
79 | |
80 | type Get_Integer_Call is access function return Integer; | |
90de1450 | 81 | pragma Favor_Top_Level (Get_Integer_Call); |
cacbc350 | 82 | type Set_Integer_Call is access procedure (Len : Integer); |
90de1450 | 83 | pragma Favor_Top_Level (Set_Integer_Call); |
cacbc350 RK |
84 | |
85 | type Get_EOA_Call is access function return EOA; | |
90de1450 | 86 | pragma Favor_Top_Level (Get_EOA_Call); |
cacbc350 | 87 | type Set_EOA_Call is access procedure (Excep : EOA); |
90de1450 | 88 | pragma Favor_Top_Level (Set_EOA_Call); |
cacbc350 | 89 | type Set_EO_Call is access procedure (Excep : EO); |
90de1450 | 90 | pragma Favor_Top_Level (Set_EO_Call); |
cacbc350 RK |
91 | |
92 | type Special_EO_Call is access | |
93 | procedure (Excep : EO := Current_Target_Exception); | |
90de1450 | 94 | pragma Favor_Top_Level (Special_EO_Call); |
cacbc350 RK |
95 | |
96 | type Timed_Delay_Call is access | |
97 | procedure (Time : Duration; Mode : Integer); | |
90de1450 | 98 | pragma Favor_Top_Level (Timed_Delay_Call); |
cacbc350 RK |
99 | |
100 | type Get_Stack_Access_Call is access | |
101 | function return Stack_Checking.Stack_Access; | |
90de1450 | 102 | pragma Favor_Top_Level (Get_Stack_Access_Call); |
cacbc350 | 103 | |
07fc65c4 GB |
104 | type Task_Name_Call is access |
105 | function return String; | |
90de1450 | 106 | pragma Favor_Top_Level (Task_Name_Call); |
07fc65c4 | 107 | |
12a13f01 | 108 | -- Suppress checks on all these types, since we know the corresponding |
cacbc350 RK |
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); | |
81408d49 | 113 | pragma Suppress (Access_Check, EO_Param_Proc); |
cacbc350 RK |
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); | |
07fc65c4 | 123 | pragma Suppress (Access_Check, Task_Name_Call); |
cacbc350 RK |
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; | |
90de1450 | 132 | pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call); |
cacbc350 RK |
133 | |
134 | -- Declarations for the no tasking versions of the required routines | |
135 | ||
136 | procedure Abort_Defer_NT; | |
1a49cf99 | 137 | -- Defer task abort (non-tasking case, does nothing) |
cacbc350 RK |
138 | |
139 | procedure Abort_Undefer_NT; | |
1a49cf99 | 140 | -- Undefer task abort (non-tasking case, does nothing) |
cacbc350 RK |
141 | |
142 | procedure Abort_Handler_NT; | |
1a49cf99 AC |
143 | -- Handle task abort (non-tasking case, does nothing). Currently, only VMS |
144 | -- uses this. | |
cacbc350 | 145 | |
984a64bc | 146 | procedure Update_Exception_NT (X : EO := Current_Target_Exception); |
87ace727 | 147 | -- Handle exception setting. This routine is provided for targets that |
1a49cf99 AC |
148 | -- have built-in exception handling such as the Java Virtual Machine. |
149 | -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on | |
150 | -- how this routine is used. | |
cacbc350 RK |
151 | |
152 | function Check_Abort_Status_NT return Integer; | |
153 | -- Returns Boolean'Pos (True) iff abort signal should raise | |
c228a069 | 154 | -- Standard'Abort_Signal. |
cacbc350 RK |
155 | |
156 | procedure Task_Lock_NT; | |
157 | -- Lock out other tasks (non-tasking case, does nothing) | |
158 | ||
159 | procedure Task_Unlock_NT; | |
160 | -- Release lock set by Task_Lock (non-tasking case, does nothing) | |
161 | ||
81408d49 DR |
162 | procedure Task_Termination_NT (Excep : EO); |
163 | -- Handle task termination routines for the environment task (non-tasking | |
164 | -- case, does nothing). | |
165 | ||
81408d49 DR |
166 | procedure Adafinal_NT; |
167 | -- Shuts down the runtime system (non-tasking case) | |
cacbc350 RK |
168 | |
169 | Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; | |
170 | pragma Suppress (Access_Check, Abort_Defer); | |
1a49cf99 | 171 | -- Defer task abort (task/non-task case as appropriate) |
cacbc350 RK |
172 | |
173 | Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; | |
174 | pragma Suppress (Access_Check, Abort_Undefer); | |
1a49cf99 | 175 | -- Undefer task abort (task/non-task case as appropriate) |
cacbc350 RK |
176 | |
177 | Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; | |
1a49cf99 | 178 | -- Handle task abort (task/non-task case as appropriate) |
cacbc350 RK |
179 | |
180 | Update_Exception : Special_EO_Call := Update_Exception_NT'Access; | |
181 | -- Handle exception setting and tasking polling when appropriate | |
182 | ||
183 | Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; | |
184 | -- Called when Abort_Signal is delivered to the process. Checks to | |
c228a069 | 185 | -- see if signal should result in raising Standard'Abort_Signal. |
cacbc350 RK |
186 | |
187 | Lock_Task : No_Param_Proc := Task_Lock_NT'Access; | |
188 | -- Locks out other tasks. Preceding a section of code by Task_Lock and | |
189 | -- following it by Task_Unlock creates a critical region. This is used | |
190 | -- for ensuring that a region of non-tasking code (such as code used to | |
191 | -- allocate memory) is tasking safe. Note that it is valid for calls to | |
192 | -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. | |
193 | -- only the corresponding outer level Task_Unlock will actually unlock. | |
194 | -- This routine also prevents against asynchronous aborts (abort is | |
195 | -- deferred). | |
196 | ||
197 | Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access; | |
198 | -- Releases lock previously set by call to Lock_Task. In the nested case, | |
199 | -- all nested locks must be released before other tasks competing for the | |
200 | -- tasking lock are released. | |
201 | -- | |
202 | -- In the non nested case, this routine terminates the protection against | |
203 | -- asynchronous aborts introduced by Lock_Task (unless abort was already | |
204 | -- deferred before the call to Lock_Task (e.g in a protected procedures). | |
205 | -- | |
206 | -- Note: the recommended protocol for using Lock_Task and Unlock_Task | |
207 | -- is as follows: | |
208 | -- | |
209 | -- Locked_Processing : begin | |
210 | -- System.Soft_Links.Lock_Task.all; | |
211 | -- ... | |
a52fefe6 | 212 | -- System.Soft_Links.Unlock_Task.all; |
cacbc350 RK |
213 | -- |
214 | -- exception | |
215 | -- when others => | |
a52fefe6 | 216 | -- System.Soft_Links.Unlock_Task.all; |
cacbc350 RK |
217 | -- raise; |
218 | -- end Locked_Processing; | |
219 | -- | |
220 | -- This ensures that the lock is not left set if an exception is raised | |
221 | -- explicitly or implicitly during the critical locked region. | |
222 | ||
81408d49 DR |
223 | Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access; |
224 | -- Handle task termination routines (task/non-task case as appropriate) | |
225 | ||
df3e68b1 HK |
226 | Finalize_Library_Objects : No_Param_Proc; |
227 | pragma Export (C, Finalize_Library_Objects, | |
228 | "__gnat_finalize_library_objects"); | |
f9ad6b62 | 229 | -- Will be initialized by the binder |
81408d49 DR |
230 | |
231 | Adafinal : No_Param_Proc := Adafinal_NT'Access; | |
1a49cf99 | 232 | -- Performs the finalization of the Ada Runtime |
cacbc350 RK |
233 | |
234 | function Get_Jmpbuf_Address_NT return Address; | |
235 | procedure Set_Jmpbuf_Address_NT (Addr : Address); | |
236 | ||
237 | Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access; | |
238 | Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access; | |
239 | ||
240 | function Get_Sec_Stack_Addr_NT return Address; | |
241 | procedure Set_Sec_Stack_Addr_NT (Addr : Address); | |
242 | ||
243 | Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; | |
244 | Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; | |
245 | ||
a73734f5 | 246 | function Get_Current_Excep_NT return EOA; |
cacbc350 RK |
247 | |
248 | Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access; | |
249 | ||
250 | function Get_Stack_Info_NT return Stack_Checking.Stack_Access; | |
251 | ||
252 | Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access; | |
253 | ||
254 | -------------------------- | |
255 | -- Master_Id Soft-Links -- | |
256 | -------------------------- | |
257 | ||
87ace727 | 258 | -- Soft-Links are used for procedures that manipulate Master_Ids because |
cacbc350 RK |
259 | -- a Master_Id must be generated for access to limited class-wide types, |
260 | -- whose root may be extended with task components. | |
261 | ||
262 | function Current_Master_NT return Integer; | |
263 | procedure Enter_Master_NT; | |
264 | procedure Complete_Master_NT; | |
265 | ||
266 | Current_Master : Get_Integer_Call := Current_Master_NT'Access; | |
267 | Enter_Master : No_Param_Proc := Enter_Master_NT'Access; | |
268 | Complete_Master : No_Param_Proc := Complete_Master_NT'Access; | |
269 | ||
270 | ---------------------- | |
271 | -- Delay Soft-Links -- | |
272 | ---------------------- | |
273 | ||
274 | -- Soft-Links are used for procedures that manipulate time to avoid | |
275 | -- dragging the tasking run time when using delay statements. | |
276 | ||
277 | Timed_Delay : Timed_Delay_Call; | |
278 | ||
07fc65c4 GB |
279 | -------------------------- |
280 | -- Task Name Soft-Links -- | |
281 | -------------------------- | |
282 | ||
283 | function Task_Name_NT return String; | |
284 | ||
285 | Task_Name : Task_Name_Call := Task_Name_NT'Access; | |
286 | ||
cacbc350 RK |
287 | ------------------------------------- |
288 | -- Exception Tracebacks Soft-Links -- | |
289 | ------------------------------------- | |
290 | ||
df3e68b1 | 291 | Library_Exception : EO; |
df3e68b1 HK |
292 | -- Library-level finalization routines use this common reference to store |
293 | -- the first library-level exception which occurs during finalization. | |
294 | ||
295 | Library_Exception_Set : Boolean := False; | |
df3e68b1 HK |
296 | -- Used in conjunction with Library_Exception, set when an exception has |
297 | -- been stored. | |
298 | ||
cacbc350 RK |
299 | Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call; |
300 | -- Wrapper to the possible user specified traceback decorator to be | |
301 | -- called during automatic output of exception data. | |
302 | ||
303 | -- The nullity of this wrapper shall correspond to the nullity of the | |
304 | -- current actual decorator. This is ensured first by the null initial | |
305 | -- value of the corresponding variables, and then by Set_Trace_Decorator | |
306 | -- in g-exctra.adb. | |
307 | ||
308 | pragma Atomic (Traceback_Decorator_Wrapper); | |
309 | -- Since concurrent read/write operations may occur on this variable. | |
310 | -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for | |
311 | -- a more detailed description of the potential problems. | |
312 | ||
e5a22243 | 313 | procedure Save_Library_Occurrence (E : EOA); |
df3e68b1 HK |
314 | -- When invoked, this routine saves an exception occurrence into a hidden |
315 | -- reference. Subsequent calls will have no effect. | |
316 | ||
cacbc350 RK |
317 | ------------------------ |
318 | -- Task Specific Data -- | |
319 | ------------------------ | |
320 | ||
321 | -- Here we define a single type that encapsulates the various task | |
74e63df1 RD |
322 | -- specific data. This type is used to store the necessary data into the |
323 | -- Task_Control_Block or into a global variable in the non tasking case. | |
cacbc350 RK |
324 | |
325 | type TSD is record | |
326 | Pri_Stack_Info : aliased Stack_Checking.Stack_Info; | |
74e63df1 RD |
327 | -- Information on stack (Base/Limit/Size) used by System.Stack_Checking. |
328 | -- If this TSD does not belong to the environment task, the Size field | |
329 | -- must be initialized to the tasks requested stack size before the task | |
330 | -- can do its first stack check. | |
cacbc350 | 331 | |
3b91d88e | 332 | pragma Warnings (Off); |
74e63df1 RD |
333 | -- Needed because we are giving a non-static default to an object in |
334 | -- a preelaborated unit, which is formally not permitted, but OK here. | |
335 | ||
3b91d88e | 336 | Jmpbuf_Address : System.Address := System.Null_Address; |
74e63df1 RD |
337 | -- Address of jump buffer used to store the address of the current |
338 | -- longjmp/setjmp buffer for exception management. These buffers are | |
339 | -- threaded into a stack, and the address here is the top of the stack. | |
340 | -- A null address means that no exception handler is currently active. | |
cacbc350 | 341 | |
3b91d88e AC |
342 | Sec_Stack_Addr : System.Address := System.Null_Address; |
343 | pragma Warnings (On); | |
cacbc350 RK |
344 | -- Address of currently allocated secondary stack |
345 | ||
cacbc350 | 346 | Current_Excep : aliased EO; |
74e63df1 RD |
347 | -- Exception occurrence that contains the information for the current |
348 | -- exception. Note that any exception in the same task destroys this | |
349 | -- information, so the data in this variable must be copied out before | |
350 | -- another exception can occur. | |
fbf5a39b AC |
351 | -- |
352 | -- Also act as a list of the active exceptions in the case of the GCC | |
353 | -- exception mechanism, organized as a stack with the most recent first. | |
cacbc350 RK |
354 | end record; |
355 | ||
356 | procedure Create_TSD (New_TSD : in out TSD); | |
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); | |
3b91d88e | 363 | -- Called from s-tassta just before a thread is destroyed to perform |
cacbc350 RK |
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_Addr_Soft return Address; | |
383 | procedure Set_Sec_Stack_Addr_Soft (Addr : Address); | |
384 | pragma Inline (Get_Sec_Stack_Addr_Soft); | |
385 | pragma Inline (Set_Sec_Stack_Addr_Soft); | |
386 | ||
7f8b32d5 HK |
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 | ||
cacbc350 | 408 | end System.Soft_Links; |