|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1999-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNARL 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 -- GNARL was developed by the GNARL team at Florida State University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 pragma Style_Checks (All_Checks);
|
|
|
33 -- Turn off subprogram alpha order check, since we group soft link
|
|
|
34 -- bodies and also separate off subprograms for restricted GNARLI.
|
|
|
35
|
|
|
36 -- This is a simplified version of the System.Tasking.Stages package,
|
|
|
37 -- intended to be used in a restricted run time.
|
|
|
38
|
|
|
39 -- This package represents the high level tasking interface used by the
|
|
|
40 -- compiler to expand Ada 95 tasking constructs into simpler run time calls.
|
|
|
41
|
|
|
42 pragma Polling (Off);
|
|
|
43 -- Turn off polling, we do not want ATC polling to take place during
|
|
|
44 -- tasking operations. It causes infinite loops and other problems.
|
|
|
45
|
|
|
46 with Ada.Exceptions;
|
|
|
47
|
|
|
48 with System.Task_Primitives.Operations;
|
|
|
49 with System.Soft_Links.Tasking;
|
|
|
50
|
|
|
51 with System.Soft_Links;
|
|
|
52 -- Used for the non-tasking routines (*_NT) that refer to global data. They
|
|
|
53 -- are needed here before the tasking run time has been elaborated. used for
|
|
|
54 -- Create_TSD This package also provides initialization routines for task
|
|
|
55 -- specific data. The GNARL must call these to be sure that all non-tasking
|
|
|
56 -- Ada constructs will work.
|
|
|
57
|
|
|
58 package body System.Tasking.Restricted.Stages is
|
|
|
59
|
|
|
60 package STPO renames System.Task_Primitives.Operations;
|
|
|
61 package SSL renames System.Soft_Links;
|
|
|
62
|
|
|
63 use Ada.Exceptions;
|
|
|
64
|
|
|
65 use Parameters;
|
|
|
66 use Task_Primitives.Operations;
|
|
|
67
|
|
|
68 Tasks_Activation_Chain : Task_Id;
|
|
|
69 -- Chain of all the tasks to activate
|
|
|
70
|
|
|
71 Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
|
|
|
72 -- This is a global lock; it is used to execute in mutual exclusion
|
|
|
73 -- from all other tasks. It is only used by Task_Lock and Task_Unlock.
|
|
|
74
|
|
|
75 -----------------------------------------------------------------
|
|
|
76 -- Tasking versions of services needed by non-tasking programs --
|
|
|
77 -----------------------------------------------------------------
|
|
|
78
|
|
|
79 function Get_Current_Excep return SSL.EOA;
|
|
|
80 -- Task-safe version of SSL.Get_Current_Excep
|
|
|
81
|
|
|
82 procedure Task_Lock;
|
|
|
83 -- Locks out other tasks. Preceding a section of code by Task_Lock and
|
|
|
84 -- following it by Task_Unlock creates a critical region. This is used
|
|
|
85 -- for ensuring that a region of non-tasking code (such as code used to
|
|
|
86 -- allocate memory) is tasking safe. Note that it is valid for calls to
|
|
|
87 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
|
|
|
88 -- only the corresponding outer level Task_Unlock will actually unlock.
|
|
|
89
|
|
|
90 procedure Task_Unlock;
|
|
|
91 -- Releases lock previously set by call to Task_Lock. In the nested case,
|
|
|
92 -- all nested locks must be released before other tasks competing for the
|
|
|
93 -- tasking lock are released.
|
|
|
94
|
|
|
95 -----------------------
|
|
|
96 -- Local Subprograms --
|
|
|
97 -----------------------
|
|
|
98
|
|
|
99 procedure Task_Wrapper (Self_ID : Task_Id);
|
|
|
100 -- This is the procedure that is called by the GNULL from the
|
|
|
101 -- new context when a task is created. It waits for activation
|
|
|
102 -- and then calls the task body procedure. When the task body
|
|
|
103 -- procedure completes, it terminates the task.
|
|
|
104
|
|
|
105 procedure Terminate_Task (Self_ID : Task_Id);
|
|
|
106 -- Terminate the calling task.
|
|
|
107 -- This should only be called by the Task_Wrapper procedure.
|
|
|
108
|
|
|
109 procedure Create_Restricted_Task
|
|
|
110 (Priority : Integer;
|
|
|
111 Stack_Address : System.Address;
|
|
|
112 Stack_Size : System.Parameters.Size_Type;
|
|
|
113 Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr;
|
|
|
114 Sec_Stack_Size : System.Parameters.Size_Type;
|
|
|
115 Task_Info : System.Task_Info.Task_Info_Type;
|
|
|
116 CPU : Integer;
|
|
|
117 State : Task_Procedure_Access;
|
|
|
118 Discriminants : System.Address;
|
|
|
119 Elaborated : Access_Boolean;
|
|
|
120 Task_Image : String;
|
|
|
121 Created_Task : Task_Id);
|
|
|
122 -- Code shared between Create_Restricted_Task (the concurrent version) and
|
|
|
123 -- Create_Restricted_Task_Sequential. See comment of the former in the
|
|
|
124 -- specification of this package.
|
|
|
125
|
|
|
126 procedure Activate_Tasks (Chain : Task_Id);
|
|
|
127 -- Activate the list of tasks started by Chain
|
|
|
128
|
|
|
129 procedure Init_RTS;
|
|
|
130 -- This procedure performs the initialization of the GNARL.
|
|
|
131 -- It consists of initializing the environment task, global locks, and
|
|
|
132 -- installing tasking versions of certain operations used by the compiler.
|
|
|
133 -- Init_RTS is called during elaboration.
|
|
|
134
|
|
|
135 -----------------------
|
|
|
136 -- Get_Current_Excep --
|
|
|
137 -----------------------
|
|
|
138
|
|
|
139 function Get_Current_Excep return SSL.EOA is
|
|
|
140 begin
|
|
|
141 return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
|
|
|
142 end Get_Current_Excep;
|
|
|
143
|
|
|
144 ---------------
|
|
|
145 -- Task_Lock --
|
|
|
146 ---------------
|
|
|
147
|
|
|
148 procedure Task_Lock is
|
|
|
149 Self_ID : constant Task_Id := STPO.Self;
|
|
|
150
|
|
|
151 begin
|
|
|
152 Self_ID.Common.Global_Task_Lock_Nesting :=
|
|
|
153 Self_ID.Common.Global_Task_Lock_Nesting + 1;
|
|
|
154
|
|
|
155 if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
|
|
|
156 STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
|
|
|
157 end if;
|
|
|
158 end Task_Lock;
|
|
|
159
|
|
|
160 -----------------
|
|
|
161 -- Task_Unlock --
|
|
|
162 -----------------
|
|
|
163
|
|
|
164 procedure Task_Unlock is
|
|
|
165 Self_ID : constant Task_Id := STPO.Self;
|
|
|
166
|
|
|
167 begin
|
|
|
168 pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0);
|
|
|
169 Self_ID.Common.Global_Task_Lock_Nesting :=
|
|
|
170 Self_ID.Common.Global_Task_Lock_Nesting - 1;
|
|
|
171
|
|
|
172 if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
|
|
|
173 STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
|
|
|
174 end if;
|
|
|
175 end Task_Unlock;
|
|
|
176
|
|
|
177 ------------------
|
|
|
178 -- Task_Wrapper --
|
|
|
179 ------------------
|
|
|
180
|
|
|
181 -- The task wrapper is a procedure that is called first for each task
|
|
|
182 -- task body, and which in turn calls the compiler-generated task body
|
|
|
183 -- procedure. The wrapper's main job is to do initialization for the task.
|
|
|
184
|
|
|
185 -- The variable ID in the task wrapper is used to implement the Self
|
|
|
186 -- function on targets where there is a fast way to find the stack base
|
|
|
187 -- of the current thread, since it should be at a fixed offset from the
|
|
|
188 -- stack base.
|
|
|
189
|
|
|
190 procedure Task_Wrapper (Self_ID : Task_Id) is
|
|
|
191 ID : Task_Id := Self_ID;
|
|
|
192 pragma Volatile (ID);
|
|
|
193 pragma Warnings (Off, ID);
|
|
|
194 -- Variable used on some targets to implement a fast self. We turn off
|
|
|
195 -- warnings because a stand alone volatile constant has to be imported,
|
|
|
196 -- so we don't want warnings about ID not being referenced, and volatile
|
|
|
197 -- having no effect.
|
|
|
198 --
|
|
|
199 -- DO NOT delete ID. As noted, it is needed on some targets.
|
|
|
200
|
|
|
201 Cause : Cause_Of_Termination := Normal;
|
|
|
202 -- Indicates the reason why this task terminates. Normal corresponds to
|
|
|
203 -- a task terminating due to completing the last statement of its body.
|
|
|
204 -- If the task terminates because of an exception raised by the
|
|
|
205 -- execution of its task body, then Cause is set to Unhandled_Exception.
|
|
|
206 -- Aborts are not allowed in the restricted profile to which this file
|
|
|
207 -- belongs.
|
|
|
208
|
|
|
209 EO : Exception_Occurrence;
|
|
|
210 -- If the task terminates because of an exception raised by the
|
|
|
211 -- execution of its task body, then EO will contain the associated
|
|
|
212 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
|
|
|
213
|
|
|
214 begin
|
|
|
215 -- Initialize low-level TCB components, that cannot be initialized by
|
|
|
216 -- the creator.
|
|
|
217
|
|
|
218 Enter_Task (Self_ID);
|
|
|
219
|
|
|
220 -- Call the task body procedure
|
|
|
221
|
|
|
222 begin
|
|
|
223 -- We are separating the following portion of the code in order to
|
|
|
224 -- place the exception handlers in a different block. In this way we
|
|
|
225 -- do not call Set_Jmpbuf_Address (which needs Self) before we set
|
|
|
226 -- Self in Enter_Task.
|
|
|
227
|
|
|
228 -- Note that in the case of Ravenscar HI-E where there are no
|
|
|
229 -- exception handlers, the exception handler is suppressed.
|
|
|
230
|
|
|
231 -- Call the task body procedure
|
|
|
232
|
|
|
233 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
|
|
|
234
|
|
|
235 -- Normal task termination
|
|
|
236
|
|
|
237 Cause := Normal;
|
|
|
238 Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
|
|
|
239
|
|
|
240 exception
|
|
|
241 when E : others =>
|
|
|
242
|
|
|
243 -- Task terminating because of an unhandled exception
|
|
|
244
|
|
|
245 Cause := Unhandled_Exception;
|
|
|
246 Save_Occurrence (EO, E);
|
|
|
247 end;
|
|
|
248
|
|
|
249 -- Look for a fall-back handler
|
|
|
250
|
|
|
251 -- This package is part of the restricted run time which supports
|
|
|
252 -- neither task hierarchies (No_Task_Hierarchy) nor specific task
|
|
|
253 -- termination handlers (No_Specific_Termination_Handlers).
|
|
|
254
|
|
|
255 -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies
|
|
|
256 -- only to the dependent tasks of the task". Hence, if the terminating
|
|
|
257 -- tasks (Self_ID) had a fall-back handler, it would not apply to
|
|
|
258 -- itself. This code is always executed by a task whose master is the
|
|
|
259 -- environment task (the task termination code for the environment task
|
|
|
260 -- is executed by SSL.Task_Termination_Handler), so the fall-back
|
|
|
261 -- handler to execute for this task can only be defined by its parent
|
|
|
262 -- (there is no grandparent).
|
|
|
263
|
|
|
264 declare
|
|
|
265 TH : Termination_Handler := null;
|
|
|
266
|
|
|
267 begin
|
|
|
268 if Single_Lock then
|
|
|
269 Lock_RTS;
|
|
|
270 end if;
|
|
|
271
|
|
|
272 Write_Lock (Self_ID.Common.Parent);
|
|
|
273
|
|
|
274 TH := Self_ID.Common.Parent.Common.Fall_Back_Handler;
|
|
|
275
|
|
|
276 Unlock (Self_ID.Common.Parent);
|
|
|
277
|
|
|
278 if Single_Lock then
|
|
|
279 Unlock_RTS;
|
|
|
280 end if;
|
|
|
281
|
|
|
282 -- Execute the task termination handler if we found it
|
|
|
283
|
|
|
284 if TH /= null then
|
|
|
285 TH.all (Cause, Self_ID, EO);
|
|
|
286 end if;
|
|
|
287 end;
|
|
|
288
|
|
|
289 Terminate_Task (Self_ID);
|
|
|
290 end Task_Wrapper;
|
|
|
291
|
|
|
292 -----------------------
|
|
|
293 -- Restricted GNARLI --
|
|
|
294 -----------------------
|
|
|
295
|
|
|
296 -----------------------------------
|
|
|
297 -- Activate_All_Tasks_Sequential --
|
|
|
298 -----------------------------------
|
|
|
299
|
|
|
300 procedure Activate_All_Tasks_Sequential is
|
|
|
301 begin
|
|
|
302 pragma Assert (Partition_Elaboration_Policy = 'S');
|
|
|
303
|
|
|
304 Activate_Tasks (Tasks_Activation_Chain);
|
|
|
305 Tasks_Activation_Chain := Null_Task;
|
|
|
306 end Activate_All_Tasks_Sequential;
|
|
|
307
|
|
|
308 -------------------------------
|
|
|
309 -- Activate_Restricted_Tasks --
|
|
|
310 -------------------------------
|
|
|
311
|
|
|
312 procedure Activate_Restricted_Tasks
|
|
|
313 (Chain_Access : Activation_Chain_Access) is
|
|
|
314 begin
|
|
|
315 if Partition_Elaboration_Policy = 'S' then
|
|
|
316
|
|
|
317 -- In sequential elaboration policy, the chain must be empty. This
|
|
|
318 -- procedure can be called if the unit has been compiled without
|
|
|
319 -- partition elaboration policy, but the partition has a sequential
|
|
|
320 -- elaboration policy.
|
|
|
321
|
|
|
322 pragma Assert (Chain_Access.T_ID = Null_Task);
|
|
|
323 null;
|
|
|
324 else
|
|
|
325 Activate_Tasks (Chain_Access.T_ID);
|
|
|
326 Chain_Access.T_ID := Null_Task;
|
|
|
327 end if;
|
|
|
328 end Activate_Restricted_Tasks;
|
|
|
329
|
|
|
330 --------------------
|
|
|
331 -- Activate_Tasks --
|
|
|
332 --------------------
|
|
|
333
|
|
|
334 -- Note that locks of activator and activated task are both locked here.
|
|
|
335 -- This is necessary because C.State and Self.Wait_Count have to be
|
|
|
336 -- synchronized. This is safe from deadlock because the activator is always
|
|
|
337 -- created before the activated task. That satisfies our
|
|
|
338 -- in-order-of-creation ATCB locking policy.
|
|
|
339
|
|
|
340 procedure Activate_Tasks (Chain : Task_Id) is
|
|
|
341 Self_ID : constant Task_Id := STPO.Self;
|
|
|
342 C : Task_Id;
|
|
|
343 Activate_Prio : System.Any_Priority;
|
|
|
344 Success : Boolean;
|
|
|
345
|
|
|
346 begin
|
|
|
347 pragma Assert (Self_ID = Environment_Task);
|
|
|
348 pragma Assert (Self_ID.Common.Wait_Count = 0);
|
|
|
349
|
|
|
350 if Single_Lock then
|
|
|
351 Lock_RTS;
|
|
|
352 end if;
|
|
|
353
|
|
|
354 -- Lock self, to prevent activated tasks from racing ahead before we
|
|
|
355 -- finish activating the chain.
|
|
|
356
|
|
|
357 Write_Lock (Self_ID);
|
|
|
358
|
|
|
359 -- Activate all the tasks in the chain. Creation of the thread of
|
|
|
360 -- control was deferred until activation. So create it now.
|
|
|
361
|
|
|
362 C := Chain;
|
|
|
363 while C /= null loop
|
|
|
364 if C.Common.State /= Terminated then
|
|
|
365 pragma Assert (C.Common.State = Unactivated);
|
|
|
366
|
|
|
367 Write_Lock (C);
|
|
|
368
|
|
|
369 Activate_Prio :=
|
|
|
370 (if C.Common.Base_Priority < Get_Priority (Self_ID)
|
|
|
371 then Get_Priority (Self_ID)
|
|
|
372 else C.Common.Base_Priority);
|
|
|
373
|
|
|
374 STPO.Create_Task
|
|
|
375 (C, Task_Wrapper'Address,
|
|
|
376 Parameters.Size_Type
|
|
|
377 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
|
|
|
378 Activate_Prio, Success);
|
|
|
379
|
|
|
380 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
|
|
|
381
|
|
|
382 if Success then
|
|
|
383 C.Common.State := Runnable;
|
|
|
384 else
|
|
|
385 raise Program_Error;
|
|
|
386 end if;
|
|
|
387
|
|
|
388 Unlock (C);
|
|
|
389 end if;
|
|
|
390
|
|
|
391 C := C.Common.Activation_Link;
|
|
|
392 end loop;
|
|
|
393
|
|
|
394 Self_ID.Common.State := Activator_Sleep;
|
|
|
395
|
|
|
396 -- Wait for the activated tasks to complete activation. It is unsafe to
|
|
|
397 -- abort any of these tasks until the count goes to zero.
|
|
|
398
|
|
|
399 loop
|
|
|
400 exit when Self_ID.Common.Wait_Count = 0;
|
|
|
401 Sleep (Self_ID, Activator_Sleep);
|
|
|
402 end loop;
|
|
|
403
|
|
|
404 Self_ID.Common.State := Runnable;
|
|
|
405 Unlock (Self_ID);
|
|
|
406
|
|
|
407 if Single_Lock then
|
|
|
408 Unlock_RTS;
|
|
|
409 end if;
|
|
|
410 end Activate_Tasks;
|
|
|
411
|
|
|
412 ------------------------------------
|
|
|
413 -- Complete_Restricted_Activation --
|
|
|
414 ------------------------------------
|
|
|
415
|
|
|
416 -- As in several other places, the locks of the activator and activated
|
|
|
417 -- task are both locked here. This follows our deadlock prevention lock
|
|
|
418 -- ordering policy, since the activated task must be created after the
|
|
|
419 -- activator.
|
|
|
420
|
|
|
421 procedure Complete_Restricted_Activation is
|
|
|
422 Self_ID : constant Task_Id := STPO.Self;
|
|
|
423 Activator : constant Task_Id := Self_ID.Common.Activator;
|
|
|
424
|
|
|
425 begin
|
|
|
426 if Single_Lock then
|
|
|
427 Lock_RTS;
|
|
|
428 end if;
|
|
|
429
|
|
|
430 Write_Lock (Activator);
|
|
|
431 Write_Lock (Self_ID);
|
|
|
432
|
|
|
433 -- Remove dangling reference to Activator, since a task may outlive its
|
|
|
434 -- activator.
|
|
|
435
|
|
|
436 Self_ID.Common.Activator := null;
|
|
|
437
|
|
|
438 -- Wake up the activator, if it is waiting for a chain of tasks to
|
|
|
439 -- activate, and we are the last in the chain to complete activation
|
|
|
440
|
|
|
441 if Activator.Common.State = Activator_Sleep then
|
|
|
442 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
|
|
|
443
|
|
|
444 if Activator.Common.Wait_Count = 0 then
|
|
|
445 Wakeup (Activator, Activator_Sleep);
|
|
|
446 end if;
|
|
|
447 end if;
|
|
|
448
|
|
|
449 Unlock (Self_ID);
|
|
|
450 Unlock (Activator);
|
|
|
451
|
|
|
452 if Single_Lock then
|
|
|
453 Unlock_RTS;
|
|
|
454 end if;
|
|
|
455
|
|
|
456 -- After the activation, active priority should be the same as base
|
|
|
457 -- priority. We must unlock the Activator first, though, since it should
|
|
|
458 -- not wait if we have lower priority.
|
|
|
459
|
|
|
460 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
|
|
|
461 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
|
|
|
462 end if;
|
|
|
463 end Complete_Restricted_Activation;
|
|
|
464
|
|
|
465 ------------------------------
|
|
|
466 -- Complete_Restricted_Task --
|
|
|
467 ------------------------------
|
|
|
468
|
|
|
469 procedure Complete_Restricted_Task is
|
|
|
470 begin
|
|
|
471 STPO.Self.Common.State := Terminated;
|
|
|
472 end Complete_Restricted_Task;
|
|
|
473
|
|
|
474 ----------------------------
|
|
|
475 -- Create_Restricted_Task --
|
|
|
476 ----------------------------
|
|
|
477
|
|
|
478 procedure Create_Restricted_Task
|
|
|
479 (Priority : Integer;
|
|
|
480 Stack_Address : System.Address;
|
|
|
481 Stack_Size : System.Parameters.Size_Type;
|
|
|
482 Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr;
|
|
|
483 Sec_Stack_Size : System.Parameters.Size_Type;
|
|
|
484 Task_Info : System.Task_Info.Task_Info_Type;
|
|
|
485 CPU : Integer;
|
|
|
486 State : Task_Procedure_Access;
|
|
|
487 Discriminants : System.Address;
|
|
|
488 Elaborated : Access_Boolean;
|
|
|
489 Task_Image : String;
|
|
|
490 Created_Task : Task_Id)
|
|
|
491 is
|
|
|
492 Self_ID : constant Task_Id := STPO.Self;
|
|
|
493 Base_Priority : System.Any_Priority;
|
|
|
494 Base_CPU : System.Multiprocessors.CPU_Range;
|
|
|
495 Success : Boolean;
|
|
|
496 Len : Integer;
|
|
|
497
|
|
|
498 begin
|
|
|
499 -- Stack is not preallocated on this target, so that Stack_Address must
|
|
|
500 -- be null.
|
|
|
501
|
|
|
502 pragma Assert (Stack_Address = Null_Address);
|
|
|
503
|
|
|
504 Base_Priority :=
|
|
|
505 (if Priority = Unspecified_Priority
|
|
|
506 then Self_ID.Common.Base_Priority
|
|
|
507 else System.Any_Priority (Priority));
|
|
|
508
|
|
|
509 -- Legal values of CPU are the special Unspecified_CPU value which is
|
|
|
510 -- inserted by the compiler for tasks without CPU aspect, and those in
|
|
|
511 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
|
|
|
512 -- the task is defined to have failed, and it becomes a completed task
|
|
|
513 -- (RM D.16(14/3)).
|
|
|
514
|
|
|
515 if CPU /= Unspecified_CPU
|
|
|
516 and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
|
|
|
517 or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
|
|
|
518 then
|
|
|
519 raise Tasking_Error with "CPU not in range";
|
|
|
520
|
|
|
521 -- Normal CPU affinity
|
|
|
522 else
|
|
|
523 -- When the application code says nothing about the task affinity
|
|
|
524 -- (task without CPU aspect) then the compiler inserts the
|
|
|
525 -- Unspecified_CPU value which indicates to the run-time library that
|
|
|
526 -- the task will activate and execute on the same processor as its
|
|
|
527 -- activating task if the activating task is assigned a processor
|
|
|
528 -- (RM D.16(14/3)).
|
|
|
529
|
|
|
530 Base_CPU :=
|
|
|
531 (if CPU = Unspecified_CPU
|
|
|
532 then Self_ID.Common.Base_CPU
|
|
|
533 else System.Multiprocessors.CPU_Range (CPU));
|
|
|
534 end if;
|
|
|
535
|
|
|
536 if Single_Lock then
|
|
|
537 Lock_RTS;
|
|
|
538 end if;
|
|
|
539
|
|
|
540 Write_Lock (Self_ID);
|
|
|
541
|
|
|
542 -- With no task hierarchy, the parent of all non-Environment tasks that
|
|
|
543 -- are created must be the Environment task. Dispatching domains are
|
|
|
544 -- not allowed in Ravenscar, so the dispatching domain parameter will
|
|
|
545 -- always be null.
|
|
|
546
|
|
|
547 Initialize_ATCB
|
|
|
548 (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
|
|
|
549 Base_CPU, null, Task_Info, Stack_Size, Created_Task, Success);
|
|
|
550
|
|
|
551 -- If we do our job right then there should never be any failures, which
|
|
|
552 -- was probably said about the Titanic; so just to be safe, let's retain
|
|
|
553 -- this code for now
|
|
|
554
|
|
|
555 if not Success then
|
|
|
556 Unlock (Self_ID);
|
|
|
557
|
|
|
558 if Single_Lock then
|
|
|
559 Unlock_RTS;
|
|
|
560 end if;
|
|
|
561
|
|
|
562 raise Program_Error;
|
|
|
563 end if;
|
|
|
564
|
|
|
565 Created_Task.Entry_Calls (1).Self := Created_Task;
|
|
|
566
|
|
|
567 Len :=
|
|
|
568 Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length);
|
|
|
569 Created_Task.Common.Task_Image_Len := Len;
|
|
|
570 Created_Task.Common.Task_Image (1 .. Len) :=
|
|
|
571 Task_Image (Task_Image'First .. Task_Image'First + Len - 1);
|
|
|
572
|
|
|
573 Unlock (Self_ID);
|
|
|
574
|
|
|
575 if Single_Lock then
|
|
|
576 Unlock_RTS;
|
|
|
577 end if;
|
|
|
578
|
|
|
579 -- Create TSD as early as possible in the creation of a task, since
|
|
|
580 -- it may be used by the operation of Ada code within the task. If the
|
|
|
581 -- compiler has not allocated a secondary stack, a stack will be
|
|
|
582 -- allocated fromt the binder generated pool.
|
|
|
583
|
|
|
584 SSL.Create_TSD
|
|
|
585 (Created_Task.Common.Compiler_Data,
|
|
|
586 Sec_Stack_Address,
|
|
|
587 Sec_Stack_Size);
|
|
|
588 end Create_Restricted_Task;
|
|
|
589
|
|
|
590 procedure Create_Restricted_Task
|
|
|
591 (Priority : Integer;
|
|
|
592 Stack_Address : System.Address;
|
|
|
593 Stack_Size : System.Parameters.Size_Type;
|
|
|
594 Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr;
|
|
|
595 Sec_Stack_Size : System.Parameters.Size_Type;
|
|
|
596 Task_Info : System.Task_Info.Task_Info_Type;
|
|
|
597 CPU : Integer;
|
|
|
598 State : Task_Procedure_Access;
|
|
|
599 Discriminants : System.Address;
|
|
|
600 Elaborated : Access_Boolean;
|
|
|
601 Chain : in out Activation_Chain;
|
|
|
602 Task_Image : String;
|
|
|
603 Created_Task : Task_Id)
|
|
|
604 is
|
|
|
605 begin
|
|
|
606 if Partition_Elaboration_Policy = 'S' then
|
|
|
607
|
|
|
608 -- A unit may have been compiled without partition elaboration
|
|
|
609 -- policy, and in this case the compiler will emit calls for the
|
|
|
610 -- default policy (concurrent). But if the partition policy is
|
|
|
611 -- sequential, activation must be deferred.
|
|
|
612
|
|
|
613 Create_Restricted_Task_Sequential
|
|
|
614 (Priority, Stack_Address, Stack_Size, Sec_Stack_Address,
|
|
|
615 Sec_Stack_Size, Task_Info, CPU, State, Discriminants, Elaborated,
|
|
|
616 Task_Image, Created_Task);
|
|
|
617
|
|
|
618 else
|
|
|
619 Create_Restricted_Task
|
|
|
620 (Priority, Stack_Address, Stack_Size, Sec_Stack_Address,
|
|
|
621 Sec_Stack_Size, Task_Info, CPU, State, Discriminants, Elaborated,
|
|
|
622 Task_Image, Created_Task);
|
|
|
623
|
|
|
624 -- Append this task to the activation chain
|
|
|
625
|
|
|
626 Created_Task.Common.Activation_Link := Chain.T_ID;
|
|
|
627 Chain.T_ID := Created_Task;
|
|
|
628 end if;
|
|
|
629 end Create_Restricted_Task;
|
|
|
630
|
|
|
631 ---------------------------------------
|
|
|
632 -- Create_Restricted_Task_Sequential --
|
|
|
633 ---------------------------------------
|
|
|
634
|
|
|
635 procedure Create_Restricted_Task_Sequential
|
|
|
636 (Priority : Integer;
|
|
|
637 Stack_Address : System.Address;
|
|
|
638 Stack_Size : System.Parameters.Size_Type;
|
|
|
639 Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr;
|
|
|
640 Sec_Stack_Size : System.Parameters.Size_Type;
|
|
|
641 Task_Info : System.Task_Info.Task_Info_Type;
|
|
|
642 CPU : Integer;
|
|
|
643 State : Task_Procedure_Access;
|
|
|
644 Discriminants : System.Address;
|
|
|
645 Elaborated : Access_Boolean;
|
|
|
646 Task_Image : String;
|
|
|
647 Created_Task : Task_Id)
|
|
|
648 is
|
|
|
649 begin
|
|
|
650 Create_Restricted_Task
|
|
|
651 (Priority, Stack_Address, Stack_Size, Sec_Stack_Address,
|
|
|
652 Sec_Stack_Size, Task_Info, CPU, State, Discriminants, Elaborated,
|
|
|
653 Task_Image, Created_Task);
|
|
|
654
|
|
|
655 -- Append this task to the activation chain
|
|
|
656
|
|
|
657 Created_Task.Common.Activation_Link := Tasks_Activation_Chain;
|
|
|
658 Tasks_Activation_Chain := Created_Task;
|
|
|
659 end Create_Restricted_Task_Sequential;
|
|
|
660
|
|
|
661 ---------------------------
|
|
|
662 -- Finalize_Global_Tasks --
|
|
|
663 ---------------------------
|
|
|
664
|
|
|
665 -- This is needed to support the compiler interface; it will only be called
|
|
|
666 -- by the Environment task. Instead, it will cause the Environment to block
|
|
|
667 -- forever, since none of the dependent tasks are expected to terminate
|
|
|
668
|
|
|
669 procedure Finalize_Global_Tasks is
|
|
|
670 Self_ID : constant Task_Id := STPO.Self;
|
|
|
671
|
|
|
672 begin
|
|
|
673 pragma Assert (Self_ID = STPO.Environment_Task);
|
|
|
674
|
|
|
675 if Single_Lock then
|
|
|
676 Lock_RTS;
|
|
|
677 end if;
|
|
|
678
|
|
|
679 -- Handle normal task termination by the environment task, but only for
|
|
|
680 -- the normal task termination. In the case of Abnormal and
|
|
|
681 -- Unhandled_Exception they must have been handled before, and the task
|
|
|
682 -- termination soft link must have been changed so the task termination
|
|
|
683 -- routine is not executed twice.
|
|
|
684
|
|
|
685 -- Note that in the "normal" implementation in s-tassta.adb the task
|
|
|
686 -- termination procedure for the environment task should be executed
|
|
|
687 -- after termination of library-level tasks. However, this
|
|
|
688 -- implementation is to be used when the Ravenscar restrictions are in
|
|
|
689 -- effect, and AI-394 says that if there is a fall-back handler set for
|
|
|
690 -- the partition it should be called when the first task (including the
|
|
|
691 -- environment task) attempts to terminate.
|
|
|
692
|
|
|
693 SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
|
|
|
694
|
|
|
695 Write_Lock (Self_ID);
|
|
|
696 Sleep (Self_ID, Master_Completion_Sleep);
|
|
|
697 Unlock (Self_ID);
|
|
|
698
|
|
|
699 if Single_Lock then
|
|
|
700 Unlock_RTS;
|
|
|
701 end if;
|
|
|
702
|
|
|
703 -- Should never return from Master Completion Sleep
|
|
|
704
|
|
|
705 raise Program_Error;
|
|
|
706 end Finalize_Global_Tasks;
|
|
|
707
|
|
|
708 ---------------------------
|
|
|
709 -- Restricted_Terminated --
|
|
|
710 ---------------------------
|
|
|
711
|
|
|
712 function Restricted_Terminated (T : Task_Id) return Boolean is
|
|
|
713 begin
|
|
|
714 return T.Common.State = Terminated;
|
|
|
715 end Restricted_Terminated;
|
|
|
716
|
|
|
717 --------------------
|
|
|
718 -- Terminate_Task --
|
|
|
719 --------------------
|
|
|
720
|
|
|
721 procedure Terminate_Task (Self_ID : Task_Id) is
|
|
|
722 begin
|
|
|
723 Self_ID.Common.State := Terminated;
|
|
|
724 end Terminate_Task;
|
|
|
725
|
|
|
726 --------------
|
|
|
727 -- Init_RTS --
|
|
|
728 --------------
|
|
|
729
|
|
|
730 procedure Init_RTS is
|
|
|
731 begin
|
|
|
732 Tasking.Initialize;
|
|
|
733
|
|
|
734 -- Initialize lock used to implement mutual exclusion between all tasks
|
|
|
735
|
|
|
736 STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
|
|
|
737
|
|
|
738 -- Notify that the tasking run time has been elaborated so that
|
|
|
739 -- the tasking version of the soft links can be used.
|
|
|
740
|
|
|
741 SSL.Lock_Task := Task_Lock'Access;
|
|
|
742 SSL.Unlock_Task := Task_Unlock'Access;
|
|
|
743 SSL.Adafinal := Finalize_Global_Tasks'Access;
|
|
|
744 SSL.Get_Current_Excep := Get_Current_Excep'Access;
|
|
|
745
|
|
|
746 -- Initialize the tasking soft links (if not done yet) that are common
|
|
|
747 -- to the full and the restricted run times.
|
|
|
748
|
|
|
749 SSL.Tasking.Init_Tasking_Soft_Links;
|
|
|
750 end Init_RTS;
|
|
|
751
|
|
|
752 begin
|
|
|
753 Init_RTS;
|
|
|
754 end System.Tasking.Restricted.Stages;
|
