|
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 . S T A G E S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-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 Polling (Off);
|
|
|
33 -- Turn off polling, we do not want ATC polling to take place during tasking
|
|
|
34 -- operations. It causes infinite loops and other problems.
|
|
|
35
|
|
|
36 pragma Partition_Elaboration_Policy (Concurrent);
|
|
|
37 -- This package only implements the concurrent elaboration policy. This pragma
|
|
|
38 -- will enforce it (and detect conflicts with user specified policy).
|
|
|
39
|
|
|
40 with Ada.Exceptions;
|
|
|
41 with Ada.Unchecked_Deallocation;
|
|
|
42
|
|
|
43 with System.Interrupt_Management;
|
|
|
44 with System.Tasking.Debug;
|
|
|
45 with System.Address_Image;
|
|
|
46 with System.Task_Primitives;
|
|
|
47 with System.Task_Primitives.Operations;
|
|
|
48 with System.Tasking.Utilities;
|
|
|
49 with System.Tasking.Queuing;
|
|
|
50 with System.Tasking.Rendezvous;
|
|
|
51 with System.OS_Primitives;
|
|
|
52 with System.Secondary_Stack;
|
|
|
53 with System.Restrictions;
|
|
|
54 with System.Standard_Library;
|
|
|
55 with System.Stack_Usage;
|
|
|
56 with System.Storage_Elements;
|
|
|
57
|
|
|
58 with System.Soft_Links;
|
|
|
59 -- These are procedure pointers to non-tasking routines that use task
|
|
|
60 -- specific data. In the absence of tasking, these routines refer to global
|
|
|
61 -- data. In the presence of tasking, they must be replaced with pointers to
|
|
|
62 -- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current
|
|
|
63 -- _Excep, Finalize_Library_Objects, Task_Termination, Handler.
|
|
|
64
|
|
|
65 with System.Tasking.Initialization;
|
|
|
66 pragma Elaborate_All (System.Tasking.Initialization);
|
|
|
67 -- This insures that tasking is initialized if any tasks are created
|
|
|
68
|
|
|
69 package body System.Tasking.Stages is
|
|
|
70
|
|
|
71 package STPO renames System.Task_Primitives.Operations;
|
|
|
72 package SSL renames System.Soft_Links;
|
|
|
73 package SSE renames System.Storage_Elements;
|
|
|
74
|
|
|
75 use Ada.Exceptions;
|
|
|
76
|
|
|
77 use Parameters;
|
|
|
78 use Secondary_Stack;
|
|
|
79 use Task_Primitives;
|
|
|
80 use Task_Primitives.Operations;
|
|
|
81
|
|
|
82 -----------------------
|
|
|
83 -- Local Subprograms --
|
|
|
84 -----------------------
|
|
|
85
|
|
|
86 procedure Free is new
|
|
|
87 Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
|
|
|
88
|
|
|
89 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
|
|
|
90 -- This procedure outputs the task specific message for exception
|
|
|
91 -- tracing purposes.
|
|
|
92
|
|
|
93 procedure Task_Wrapper (Self_ID : Task_Id);
|
|
|
94 pragma Convention (C, Task_Wrapper);
|
|
|
95 -- This is the procedure that is called by the GNULL from the new context
|
|
|
96 -- when a task is created. It waits for activation and then calls the task
|
|
|
97 -- body procedure. When the task body procedure completes, it terminates
|
|
|
98 -- the task.
|
|
|
99 --
|
|
|
100 -- The Task_Wrapper's address will be provided to the underlying threads
|
|
|
101 -- library as the task entry point. Convention C is what makes most sense
|
|
|
102 -- for that purpose (Export C would make the function globally visible,
|
|
|
103 -- and affect the link name on which GDB depends). This will in addition
|
|
|
104 -- trigger an automatic stack alignment suitable for GCC's assumptions if
|
|
|
105 -- need be.
|
|
|
106
|
|
|
107 -- "Vulnerable_..." in the procedure names below means they must be called
|
|
|
108 -- with abort deferred.
|
|
|
109
|
|
|
110 procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
|
|
|
111 -- Complete the calling task. This procedure must be called with
|
|
|
112 -- abort deferred. It should only be called by Complete_Task and
|
|
|
113 -- Finalize_Global_Tasks (for the environment task).
|
|
|
114
|
|
|
115 procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
|
|
|
116 -- Complete the current master of the calling task. This procedure
|
|
|
117 -- must be called with abort deferred. It should only be called by
|
|
|
118 -- Vulnerable_Complete_Task and Complete_Master.
|
|
|
119
|
|
|
120 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
|
|
|
121 -- Signal to Self_ID's activator that Self_ID has completed activation.
|
|
|
122 -- This procedure must be called with abort deferred.
|
|
|
123
|
|
|
124 procedure Abort_Dependents (Self_ID : Task_Id);
|
|
|
125 -- Abort all the direct dependents of Self at its current master nesting
|
|
|
126 -- level, plus all of their dependents, transitively. RTS_Lock should be
|
|
|
127 -- locked by the caller.
|
|
|
128
|
|
|
129 procedure Vulnerable_Free_Task (T : Task_Id);
|
|
|
130 -- Recover all runtime system storage associated with the task T. This
|
|
|
131 -- should only be called after T has terminated and will no longer be
|
|
|
132 -- referenced.
|
|
|
133 --
|
|
|
134 -- For tasks created by an allocator that fails, due to an exception, it is
|
|
|
135 -- called from Expunge_Unactivated_Tasks.
|
|
|
136 --
|
|
|
137 -- Different code is used at master completion, in Terminate_Dependents,
|
|
|
138 -- due to a need for tighter synchronization with the master.
|
|
|
139
|
|
|
140 ----------------------
|
|
|
141 -- Abort_Dependents --
|
|
|
142 ----------------------
|
|
|
143
|
|
|
144 procedure Abort_Dependents (Self_ID : Task_Id) is
|
|
|
145 C : Task_Id;
|
|
|
146 P : Task_Id;
|
|
|
147
|
|
|
148 -- Each task C will take care of its own dependents, so there is no
|
|
|
149 -- need to worry about them here. In fact, it would be wrong to abort
|
|
|
150 -- indirect dependents here, because we can't distinguish between
|
|
|
151 -- duplicate master ids. For example, suppose we have three nested
|
|
|
152 -- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and
|
|
|
153 -- both P and Q are task masters). Q will have the same master id as
|
|
131
|
154 -- Master_Of_Task of T3. Previous versions of this would abort T3 when
|
|
111
|
155 -- Q calls Complete_Master, which was completely wrong.
|
|
|
156
|
|
|
157 begin
|
|
|
158 C := All_Tasks_List;
|
|
|
159 while C /= null loop
|
|
|
160 P := C.Common.Parent;
|
|
|
161
|
|
|
162 if P = Self_ID then
|
|
131
|
163 if C.Master_Of_Task = Self_ID.Master_Within then
|
|
111
|
164 pragma Debug
|
|
|
165 (Debug.Trace (Self_ID, "Aborting", 'X', C));
|
|
|
166 Utilities.Abort_One_Task (Self_ID, C);
|
|
|
167 C.Dependents_Aborted := True;
|
|
|
168 end if;
|
|
|
169 end if;
|
|
|
170
|
|
|
171 C := C.Common.All_Tasks_Link;
|
|
|
172 end loop;
|
|
|
173
|
|
|
174 Self_ID.Dependents_Aborted := True;
|
|
|
175 end Abort_Dependents;
|
|
|
176
|
|
|
177 -----------------
|
|
|
178 -- Abort_Tasks --
|
|
|
179 -----------------
|
|
|
180
|
|
|
181 procedure Abort_Tasks (Tasks : Task_List) is
|
|
|
182 begin
|
|
|
183 Utilities.Abort_Tasks (Tasks);
|
|
|
184 end Abort_Tasks;
|
|
|
185
|
|
|
186 --------------------
|
|
|
187 -- Activate_Tasks --
|
|
|
188 --------------------
|
|
|
189
|
|
|
190 -- Note that locks of activator and activated task are both locked here.
|
|
|
191 -- This is necessary because C.Common.State and Self.Common.Wait_Count have
|
|
|
192 -- to be synchronized. This is safe from deadlock because the activator is
|
|
|
193 -- always created before the activated task. That satisfies our
|
|
|
194 -- in-order-of-creation ATCB locking policy.
|
|
|
195
|
|
|
196 -- At one point, we may also lock the parent, if the parent is different
|
|
|
197 -- from the activator. That is also consistent with the lock ordering
|
|
|
198 -- policy, since the activator cannot be created before the parent.
|
|
|
199
|
|
|
200 -- Since we are holding both the activator's lock, and Task_Wrapper locks
|
|
|
201 -- that before it does anything more than initialize the low-level ATCB
|
|
|
202 -- components, it should be safe to wait to update the counts until we see
|
|
|
203 -- that the thread creation is successful.
|
|
|
204
|
|
|
205 -- If the thread creation fails, we do need to close the entries of the
|
|
|
206 -- task. The first phase, of dequeuing calls, only requires locking the
|
|
|
207 -- acceptor's ATCB, but the waking up of the callers requires locking the
|
|
|
208 -- caller's ATCB. We cannot safely do this while we are holding other
|
|
|
209 -- locks. Therefore, the queue-clearing operation is done in a separate
|
|
|
210 -- pass over the activation chain.
|
|
|
211
|
|
|
212 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
|
|
|
213 Self_ID : constant Task_Id := STPO.Self;
|
|
|
214 P : Task_Id;
|
|
|
215 C : Task_Id;
|
|
|
216 Next_C, Last_C : Task_Id;
|
|
|
217 Activate_Prio : System.Any_Priority;
|
|
|
218 Success : Boolean;
|
|
|
219 All_Elaborated : Boolean := True;
|
|
|
220
|
|
|
221 begin
|
|
|
222 -- If pragma Detect_Blocking is active, then we must check whether this
|
|
|
223 -- potentially blocking operation is called from a protected action.
|
|
|
224
|
|
|
225 if System.Tasking.Detect_Blocking
|
|
|
226 and then Self_ID.Common.Protected_Action_Nesting > 0
|
|
|
227 then
|
|
|
228 raise Program_Error with "potentially blocking operation";
|
|
|
229 end if;
|
|
|
230
|
|
|
231 pragma Debug
|
|
|
232 (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
|
|
|
233
|
|
|
234 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
235
|
|
|
236 pragma Assert (Self_ID.Common.Wait_Count = 0);
|
|
|
237
|
|
|
238 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
|
|
|
239 -- we finish activating the chain.
|
|
|
240
|
|
|
241 Lock_RTS;
|
|
|
242
|
|
|
243 -- Check that all task bodies have been elaborated
|
|
|
244
|
|
|
245 C := Chain_Access.T_ID;
|
|
|
246 Last_C := null;
|
|
|
247 while C /= null loop
|
|
|
248 if C.Common.Elaborated /= null
|
|
|
249 and then not C.Common.Elaborated.all
|
|
|
250 then
|
|
|
251 All_Elaborated := False;
|
|
|
252 end if;
|
|
|
253
|
|
|
254 -- Reverse the activation chain so that tasks are activated in the
|
|
|
255 -- same order they're declared.
|
|
|
256
|
|
|
257 Next_C := C.Common.Activation_Link;
|
|
|
258 C.Common.Activation_Link := Last_C;
|
|
|
259 Last_C := C;
|
|
|
260 C := Next_C;
|
|
|
261 end loop;
|
|
|
262
|
|
|
263 Chain_Access.T_ID := Last_C;
|
|
|
264
|
|
|
265 if not All_Elaborated then
|
|
|
266 Unlock_RTS;
|
|
|
267 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
268 raise Program_Error with "Some tasks have not been elaborated";
|
|
|
269 end if;
|
|
|
270
|
|
|
271 -- Activate all the tasks in the chain. Creation of the thread of
|
|
|
272 -- control was deferred until activation. So create it now.
|
|
|
273
|
|
|
274 C := Chain_Access.T_ID;
|
|
|
275 while C /= null loop
|
|
|
276 if C.Common.State /= Terminated then
|
|
|
277 pragma Assert (C.Common.State = Unactivated);
|
|
|
278
|
|
|
279 P := C.Common.Parent;
|
|
|
280 Write_Lock (P);
|
|
|
281 Write_Lock (C);
|
|
|
282
|
|
|
283 Activate_Prio :=
|
|
|
284 (if C.Common.Base_Priority < Get_Priority (Self_ID)
|
|
|
285 then Get_Priority (Self_ID)
|
|
|
286 else C.Common.Base_Priority);
|
|
|
287
|
|
|
288 System.Task_Primitives.Operations.Create_Task
|
|
|
289 (C, Task_Wrapper'Address,
|
|
|
290 Parameters.Size_Type
|
|
|
291 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
|
|
|
292 Activate_Prio, Success);
|
|
|
293
|
|
|
294 -- There would be a race between the created task and the creator
|
|
|
295 -- to do the following initialization, if we did not have a
|
|
|
296 -- Lock/Unlock_RTS pair in the task wrapper to prevent it from
|
|
|
297 -- racing ahead.
|
|
|
298
|
|
|
299 if Success then
|
|
|
300 C.Common.State := Activating;
|
|
|
301 C.Awake_Count := 1;
|
|
|
302 C.Alive_Count := 1;
|
|
|
303 P.Awake_Count := P.Awake_Count + 1;
|
|
|
304 P.Alive_Count := P.Alive_Count + 1;
|
|
|
305
|
|
|
306 if P.Common.State = Master_Completion_Sleep and then
|
|
131
|
307 C.Master_Of_Task = P.Master_Within
|
|
111
|
308 then
|
|
|
309 pragma Assert (Self_ID /= P);
|
|
|
310 P.Common.Wait_Count := P.Common.Wait_Count + 1;
|
|
|
311 end if;
|
|
|
312
|
|
|
313 for J in System.Tasking.Debug.Known_Tasks'Range loop
|
|
|
314 if System.Tasking.Debug.Known_Tasks (J) = null then
|
|
|
315 System.Tasking.Debug.Known_Tasks (J) := C;
|
|
|
316 C.Known_Tasks_Index := J;
|
|
|
317 exit;
|
|
|
318 end if;
|
|
|
319 end loop;
|
|
|
320
|
|
|
321 if Global_Task_Debug_Event_Set then
|
|
|
322 Debug.Signal_Debug_Event
|
|
|
323 (Debug.Debug_Event_Activating, C);
|
|
|
324 end if;
|
|
|
325
|
|
|
326 C.Common.State := Runnable;
|
|
|
327
|
|
|
328 Unlock (C);
|
|
|
329 Unlock (P);
|
|
|
330
|
|
|
331 else
|
|
|
332 -- No need to set Awake_Count, State, etc. here since the loop
|
|
|
333 -- below will do that for any Unactivated tasks.
|
|
|
334
|
|
|
335 Unlock (C);
|
|
|
336 Unlock (P);
|
|
|
337 Self_ID.Common.Activation_Failed := True;
|
|
|
338 end if;
|
|
|
339 end if;
|
|
|
340
|
|
|
341 C := C.Common.Activation_Link;
|
|
|
342 end loop;
|
|
|
343
|
|
|
344 if not Single_Lock then
|
|
|
345 Unlock_RTS;
|
|
|
346 end if;
|
|
|
347
|
|
|
348 -- Close the entries of any tasks that failed thread creation, and count
|
|
|
349 -- those that have not finished activation.
|
|
|
350
|
|
|
351 Write_Lock (Self_ID);
|
|
|
352 Self_ID.Common.State := Activator_Sleep;
|
|
|
353
|
|
|
354 C := Chain_Access.T_ID;
|
|
|
355 while C /= null loop
|
|
|
356 Write_Lock (C);
|
|
|
357
|
|
|
358 if C.Common.State = Unactivated then
|
|
|
359 C.Common.Activator := null;
|
|
|
360 C.Common.State := Terminated;
|
|
|
361 C.Callable := False;
|
|
|
362 Utilities.Cancel_Queued_Entry_Calls (C);
|
|
|
363
|
|
|
364 elsif C.Common.Activator /= null then
|
|
|
365 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
|
|
|
366 end if;
|
|
|
367
|
|
|
368 Unlock (C);
|
|
|
369 P := C.Common.Activation_Link;
|
|
|
370 C.Common.Activation_Link := null;
|
|
|
371 C := P;
|
|
|
372 end loop;
|
|
|
373
|
|
|
374 -- Wait for the activated tasks to complete activation. It is
|
|
|
375 -- unsafe to abort any of these tasks until the count goes to zero.
|
|
|
376
|
|
|
377 loop
|
|
|
378 exit when Self_ID.Common.Wait_Count = 0;
|
|
|
379 Sleep (Self_ID, Activator_Sleep);
|
|
|
380 end loop;
|
|
|
381
|
|
|
382 Self_ID.Common.State := Runnable;
|
|
|
383 Unlock (Self_ID);
|
|
|
384
|
|
|
385 if Single_Lock then
|
|
|
386 Unlock_RTS;
|
|
|
387 end if;
|
|
|
388
|
|
|
389 -- Remove the tasks from the chain
|
|
|
390
|
|
|
391 Chain_Access.T_ID := null;
|
|
|
392 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
393
|
|
|
394 if Self_ID.Common.Activation_Failed then
|
|
|
395 Self_ID.Common.Activation_Failed := False;
|
|
|
396 raise Tasking_Error with "Failure during activation";
|
|
|
397 end if;
|
|
|
398 end Activate_Tasks;
|
|
|
399
|
|
|
400 -------------------------
|
|
|
401 -- Complete_Activation --
|
|
|
402 -------------------------
|
|
|
403
|
|
|
404 procedure Complete_Activation is
|
|
|
405 Self_ID : constant Task_Id := STPO.Self;
|
|
|
406
|
|
|
407 begin
|
|
|
408 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
409
|
|
|
410 if Single_Lock then
|
|
|
411 Lock_RTS;
|
|
|
412 end if;
|
|
|
413
|
|
|
414 Vulnerable_Complete_Activation (Self_ID);
|
|
|
415
|
|
|
416 if Single_Lock then
|
|
|
417 Unlock_RTS;
|
|
|
418 end if;
|
|
|
419
|
|
|
420 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
421
|
|
|
422 -- ??? Why do we need to allow for nested deferral here?
|
|
|
423
|
|
|
424 end Complete_Activation;
|
|
|
425
|
|
|
426 ---------------------
|
|
|
427 -- Complete_Master --
|
|
|
428 ---------------------
|
|
|
429
|
|
|
430 procedure Complete_Master is
|
|
|
431 Self_ID : constant Task_Id := STPO.Self;
|
|
|
432 begin
|
|
|
433 pragma Assert
|
|
|
434 (Self_ID.Deferral_Level > 0
|
|
|
435 or else not System.Restrictions.Abort_Allowed);
|
|
|
436 Vulnerable_Complete_Master (Self_ID);
|
|
|
437 end Complete_Master;
|
|
|
438
|
|
|
439 -------------------
|
|
|
440 -- Complete_Task --
|
|
|
441 -------------------
|
|
|
442
|
|
|
443 -- See comments on Vulnerable_Complete_Task for details
|
|
|
444
|
|
|
445 procedure Complete_Task is
|
|
|
446 Self_ID : constant Task_Id := STPO.Self;
|
|
|
447
|
|
|
448 begin
|
|
|
449 pragma Assert
|
|
|
450 (Self_ID.Deferral_Level > 0
|
|
|
451 or else not System.Restrictions.Abort_Allowed);
|
|
|
452
|
|
|
453 Vulnerable_Complete_Task (Self_ID);
|
|
|
454
|
|
|
455 -- All of our dependents have terminated, never undefer abort again
|
|
|
456
|
|
|
457 end Complete_Task;
|
|
|
458
|
|
|
459 -----------------
|
|
|
460 -- Create_Task --
|
|
|
461 -----------------
|
|
|
462
|
|
|
463 -- Compiler interface only. Do not call from within the RTS. This must be
|
|
|
464 -- called to create a new task.
|
|
|
465
|
|
|
466 procedure Create_Task
|
|
|
467 (Priority : Integer;
|
|
|
468 Stack_Size : System.Parameters.Size_Type;
|
|
|
469 Secondary_Stack_Size : System.Parameters.Size_Type;
|
|
|
470 Task_Info : System.Task_Info.Task_Info_Type;
|
|
|
471 CPU : Integer;
|
|
|
472 Relative_Deadline : Ada.Real_Time.Time_Span;
|
|
|
473 Domain : Dispatching_Domain_Access;
|
|
|
474 Num_Entries : Task_Entry_Index;
|
|
|
475 Master : Master_Level;
|
|
|
476 State : Task_Procedure_Access;
|
|
|
477 Discriminants : System.Address;
|
|
|
478 Elaborated : Access_Boolean;
|
|
|
479 Chain : in out Activation_Chain;
|
|
|
480 Task_Image : String;
|
|
|
481 Created_Task : out Task_Id)
|
|
|
482 is
|
|
|
483 T, P : Task_Id;
|
|
|
484 Self_ID : constant Task_Id := STPO.Self;
|
|
|
485 Success : Boolean;
|
|
|
486 Base_Priority : System.Any_Priority;
|
|
|
487 Len : Natural;
|
|
|
488 Base_CPU : System.Multiprocessors.CPU_Range;
|
|
|
489
|
|
|
490 use type System.Multiprocessors.CPU_Range;
|
|
|
491
|
|
|
492 pragma Unreferenced (Relative_Deadline);
|
|
|
493 -- EDF scheduling is not supported by any of the target platforms so
|
|
|
494 -- this parameter is not passed any further.
|
|
|
495
|
|
|
496 begin
|
|
|
497 -- If Master is greater than the current master, it means that Master
|
|
|
498 -- has already awaited its dependent tasks. This raises Program_Error,
|
|
|
499 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
|
|
|
500
|
|
131
|
501 if Self_ID.Master_Of_Task /= Foreign_Task_Level
|
|
111
|
502 and then Master > Self_ID.Master_Within
|
|
|
503 then
|
|
|
504 raise Program_Error with
|
|
|
505 "create task after awaiting termination";
|
|
|
506 end if;
|
|
|
507
|
|
|
508 -- If pragma Detect_Blocking is active must be checked whether this
|
|
|
509 -- potentially blocking operation is called from a protected action.
|
|
|
510
|
|
|
511 if System.Tasking.Detect_Blocking
|
|
|
512 and then Self_ID.Common.Protected_Action_Nesting > 0
|
|
|
513 then
|
|
|
514 raise Program_Error with "potentially blocking operation";
|
|
|
515 end if;
|
|
|
516
|
|
|
517 pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C'));
|
|
|
518
|
|
|
519 Base_Priority :=
|
|
|
520 (if Priority = Unspecified_Priority
|
|
|
521 then Self_ID.Common.Base_Priority
|
|
|
522 else System.Any_Priority (Priority));
|
|
|
523
|
|
|
524 -- Legal values of CPU are the special Unspecified_CPU value which is
|
|
|
525 -- inserted by the compiler for tasks without CPU aspect, and those in
|
|
|
526 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
|
|
|
527 -- the task is defined to have failed, and it becomes a completed task
|
|
|
528 -- (RM D.16(14/3)).
|
|
|
529
|
|
|
530 if CPU /= Unspecified_CPU
|
|
|
531 and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
|
|
|
532 or else
|
|
|
533 CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
|
|
|
534 then
|
|
|
535 raise Tasking_Error with "CPU not in range";
|
|
|
536
|
|
|
537 -- Normal CPU affinity
|
|
|
538
|
|
|
539 else
|
|
|
540 -- When the application code says nothing about the task affinity
|
|
|
541 -- (task without CPU aspect) then the compiler inserts the value
|
|
|
542 -- Unspecified_CPU which indicates to the run-time library that
|
|
|
543 -- the task will activate and execute on the same processor as its
|
|
|
544 -- activating task if the activating task is assigned a processor
|
|
|
545 -- (RM D.16(14/3)).
|
|
|
546
|
|
|
547 Base_CPU :=
|
|
|
548 (if CPU = Unspecified_CPU
|
|
|
549 then Self_ID.Common.Base_CPU
|
|
|
550 else System.Multiprocessors.CPU_Range (CPU));
|
|
|
551 end if;
|
|
|
552
|
|
|
553 -- Find parent P of new Task, via master level number. Independent
|
|
|
554 -- tasks should have Parent = Environment_Task, and all tasks created
|
|
|
555 -- by independent tasks are also independent. See, for example,
|
|
|
556 -- s-interr.adb, where Interrupt_Manager does "new Server_Task". The
|
|
|
557 -- access type is at library level, so the parent of the Server_Task
|
|
|
558 -- is Environment_Task.
|
|
|
559
|
|
|
560 P := Self_ID;
|
|
|
561
|
|
131
|
562 if P.Master_Of_Task <= Independent_Task_Level then
|
|
111
|
563 P := Environment_Task;
|
|
|
564 else
|
|
131
|
565 while P /= null and then P.Master_Of_Task >= Master loop
|
|
111
|
566 P := P.Common.Parent;
|
|
|
567 end loop;
|
|
|
568 end if;
|
|
|
569
|
|
|
570 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
571
|
|
|
572 begin
|
|
|
573 T := New_ATCB (Num_Entries);
|
|
|
574 exception
|
|
|
575 when others =>
|
|
|
576 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
577 raise Storage_Error with "Cannot allocate task";
|
|
|
578 end;
|
|
|
579
|
|
|
580 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this
|
|
|
581 -- point, it is possible that we may be part of a family of tasks that
|
|
|
582 -- is being aborted.
|
|
|
583
|
|
|
584 Lock_RTS;
|
|
|
585 Write_Lock (Self_ID);
|
|
|
586
|
|
|
587 -- Now, we must check that we have not been aborted. If so, we should
|
|
|
588 -- give up on creating this task, and simply return.
|
|
|
589
|
|
|
590 if not Self_ID.Callable then
|
|
|
591 pragma Assert (Self_ID.Pending_ATC_Level = 0);
|
|
|
592 pragma Assert (Self_ID.Pending_Action);
|
|
|
593 pragma Assert
|
|
|
594 (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
|
|
|
595
|
|
|
596 Unlock (Self_ID);
|
|
|
597 Unlock_RTS;
|
|
|
598 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
599
|
|
|
600 -- ??? Should never get here
|
|
|
601
|
|
|
602 pragma Assert (False);
|
|
|
603 raise Standard'Abort_Signal;
|
|
|
604 end if;
|
|
|
605
|
|
|
606 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
|
|
|
607 Base_Priority, Base_CPU, Domain, Task_Info, Stack_Size, T, Success);
|
|
|
608
|
|
|
609 if not Success then
|
|
|
610 Free (T);
|
|
|
611 Unlock (Self_ID);
|
|
|
612 Unlock_RTS;
|
|
|
613 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
614 raise Storage_Error with "Failed to initialize task";
|
|
|
615 end if;
|
|
|
616
|
|
|
617 if Master = Foreign_Task_Level + 2 then
|
|
|
618
|
|
|
619 -- This should not happen, except when a foreign task creates non
|
|
|
620 -- library-level Ada tasks. In this case, we pretend the master is
|
|
|
621 -- a regular library level task, otherwise the run-time will get
|
|
|
622 -- confused when waiting for these tasks to terminate.
|
|
|
623
|
|
131
|
624 T.Master_Of_Task := Library_Task_Level;
|
|
111
|
625
|
|
|
626 else
|
|
131
|
627 T.Master_Of_Task := Master;
|
|
111
|
628 end if;
|
|
|
629
|
|
131
|
630 T.Master_Within := T.Master_Of_Task + 1;
|
|
111
|
631
|
|
|
632 for L in T.Entry_Calls'Range loop
|
|
|
633 T.Entry_Calls (L).Self := T;
|
|
|
634 T.Entry_Calls (L).Level := L;
|
|
|
635 end loop;
|
|
|
636
|
|
|
637 if Task_Image'Length = 0 then
|
|
|
638 T.Common.Task_Image_Len := 0;
|
|
|
639 else
|
|
|
640 Len := 1;
|
|
|
641 T.Common.Task_Image (1) := Task_Image (Task_Image'First);
|
|
|
642
|
|
|
643 -- Remove unwanted blank space generated by 'Image
|
|
|
644
|
|
|
645 for J in Task_Image'First + 1 .. Task_Image'Last loop
|
|
|
646 if Task_Image (J) /= ' '
|
|
|
647 or else Task_Image (J - 1) /= '('
|
|
|
648 then
|
|
|
649 Len := Len + 1;
|
|
|
650 T.Common.Task_Image (Len) := Task_Image (J);
|
|
|
651 exit when Len = T.Common.Task_Image'Last;
|
|
|
652 end if;
|
|
|
653 end loop;
|
|
|
654
|
|
|
655 T.Common.Task_Image_Len := Len;
|
|
|
656 end if;
|
|
|
657
|
|
131
|
658 -- Note: we used to have code here to initialize T.Common.Domain, but
|
|
111
|
659 -- that is not needed, since this is initialized in System.Tasking.
|
|
|
660
|
|
|
661 Unlock (Self_ID);
|
|
|
662 Unlock_RTS;
|
|
|
663
|
|
|
664 -- The CPU associated to the task (if any) must belong to the
|
|
|
665 -- dispatching domain.
|
|
|
666
|
|
|
667 if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
|
|
|
668 and then
|
|
|
669 (Base_CPU not in T.Common.Domain'Range
|
|
|
670 or else not T.Common.Domain (Base_CPU))
|
|
|
671 then
|
|
|
672 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
673 raise Tasking_Error with "CPU not in dispatching domain";
|
|
|
674 end if;
|
|
|
675
|
|
|
676 -- To handle the interaction between pragma CPU and dispatching domains
|
|
|
677 -- we need to signal that this task is being allocated to a processor.
|
|
|
678 -- This is needed only for tasks belonging to the system domain (the
|
|
|
679 -- creation of new dispatching domains can only take processors from the
|
|
|
680 -- system domain) and only before the environment task calls the main
|
|
|
681 -- procedure (dispatching domains cannot be created after this).
|
|
|
682
|
|
|
683 if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
|
|
|
684 and then T.Common.Domain = System.Tasking.System_Domain
|
|
|
685 and then not System.Tasking.Dispatching_Domains_Frozen
|
|
|
686 then
|
|
|
687 -- Increase the number of tasks attached to the CPU to which this
|
|
|
688 -- task is being moved.
|
|
|
689
|
|
|
690 Dispatching_Domain_Tasks (Base_CPU) :=
|
|
|
691 Dispatching_Domain_Tasks (Base_CPU) + 1;
|
|
|
692 end if;
|
|
|
693
|
|
|
694 -- Create the secondary stack for the task as early as possible during
|
|
|
695 -- in the creation of a task, since it may be used by the operation of
|
|
|
696 -- Ada code within the task.
|
|
|
697
|
|
|
698 begin
|
|
|
699 SSL.Create_TSD (T.Common.Compiler_Data, null, Secondary_Stack_Size);
|
|
|
700 exception
|
|
|
701 when others =>
|
|
|
702 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
703 raise Storage_Error with "Secondary stack could not be allocated";
|
|
|
704 end;
|
|
|
705
|
|
|
706 T.Common.Activation_Link := Chain.T_ID;
|
|
|
707 Chain.T_ID := T;
|
|
|
708 Created_Task := T;
|
|
|
709 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
710
|
|
|
711 pragma Debug
|
|
|
712 (Debug.Trace
|
|
131
|
713 (Self_ID, "Created task in " & T.Master_Of_Task'Img, 'C', T));
|
|
111
|
714 end Create_Task;
|
|
|
715
|
|
|
716 --------------------
|
|
|
717 -- Current_Master --
|
|
|
718 --------------------
|
|
|
719
|
|
|
720 function Current_Master return Master_Level is
|
|
|
721 begin
|
|
|
722 return STPO.Self.Master_Within;
|
|
|
723 end Current_Master;
|
|
|
724
|
|
|
725 ------------------
|
|
|
726 -- Enter_Master --
|
|
|
727 ------------------
|
|
|
728
|
|
|
729 procedure Enter_Master is
|
|
|
730 Self_ID : constant Task_Id := STPO.Self;
|
|
|
731 begin
|
|
|
732 Self_ID.Master_Within := Self_ID.Master_Within + 1;
|
|
|
733 pragma Debug
|
|
|
734 (Debug.Trace
|
|
|
735 (Self_ID, "Enter_Master ->" & Self_ID.Master_Within'Img, 'M'));
|
|
|
736 end Enter_Master;
|
|
|
737
|
|
|
738 -------------------------------
|
|
|
739 -- Expunge_Unactivated_Tasks --
|
|
|
740 -------------------------------
|
|
|
741
|
|
|
742 -- See procedure Close_Entries for the general case
|
|
|
743
|
|
|
744 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
|
|
|
745 Self_ID : constant Task_Id := STPO.Self;
|
|
|
746 C : Task_Id;
|
|
|
747 Call : Entry_Call_Link;
|
|
|
748 Temp : Task_Id;
|
|
|
749
|
|
|
750 begin
|
|
|
751 pragma Debug
|
|
|
752 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
|
|
|
753
|
|
|
754 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
755
|
|
|
756 -- ???
|
|
|
757 -- Experimentation has shown that abort is sometimes (but not always)
|
|
|
758 -- already deferred when this is called.
|
|
|
759
|
|
|
760 -- That may indicate an error. Find out what is going on
|
|
|
761
|
|
|
762 C := Chain.T_ID;
|
|
|
763 while C /= null loop
|
|
|
764 pragma Assert (C.Common.State = Unactivated);
|
|
|
765
|
|
|
766 Temp := C.Common.Activation_Link;
|
|
|
767
|
|
|
768 if C.Common.State = Unactivated then
|
|
|
769 Lock_RTS;
|
|
|
770 Write_Lock (C);
|
|
|
771
|
|
|
772 for J in 1 .. C.Entry_Num loop
|
|
|
773 Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
|
|
|
774 pragma Assert (Call = null);
|
|
|
775 end loop;
|
|
|
776
|
|
|
777 Unlock (C);
|
|
|
778
|
|
|
779 Initialization.Remove_From_All_Tasks_List (C);
|
|
|
780 Unlock_RTS;
|
|
|
781
|
|
|
782 Vulnerable_Free_Task (C);
|
|
|
783 C := Temp;
|
|
|
784 end if;
|
|
|
785 end loop;
|
|
|
786
|
|
|
787 Chain.T_ID := null;
|
|
|
788 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
789 end Expunge_Unactivated_Tasks;
|
|
|
790
|
|
|
791 ---------------------------
|
|
|
792 -- Finalize_Global_Tasks --
|
|
|
793 ---------------------------
|
|
|
794
|
|
|
795 -- ???
|
|
|
796 -- We have a potential problem here if finalization of global objects does
|
|
|
797 -- anything with signals or the timer server, since by that time those
|
|
|
798 -- servers have terminated.
|
|
|
799
|
|
|
800 -- It is hard to see how that would occur
|
|
|
801
|
|
|
802 -- However, a better solution might be to do all this finalization
|
|
|
803 -- using the global finalization chain.
|
|
|
804
|
|
|
805 procedure Finalize_Global_Tasks is
|
|
|
806 Self_ID : constant Task_Id := STPO.Self;
|
|
|
807
|
|
|
808 Ignore_1 : Boolean;
|
|
|
809 Ignore_2 : Boolean;
|
|
|
810
|
|
|
811 function State
|
|
|
812 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
|
|
|
813 pragma Import (C, State, "__gnat_get_interrupt_state");
|
|
|
814 -- Get interrupt state for interrupt number Int. Defined in init.c
|
|
|
815
|
|
|
816 Default : constant Character := 's';
|
|
|
817 -- 's' Interrupt_State pragma set state to System (use "default"
|
|
|
818 -- system handler)
|
|
|
819
|
|
|
820 begin
|
|
|
821 if Self_ID.Deferral_Level = 0 then
|
|
|
822 -- ???
|
|
|
823 -- In principle, we should be able to predict whether abort is
|
|
|
824 -- already deferred here (and it should not be deferred yet but in
|
|
|
825 -- practice it seems Finalize_Global_Tasks is being called sometimes,
|
|
|
826 -- from RTS code for exceptions, with abort already deferred.
|
|
|
827
|
|
|
828 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
829
|
|
|
830 -- Never undefer again
|
|
|
831 end if;
|
|
|
832
|
|
|
833 -- This code is only executed by the environment task
|
|
|
834
|
|
|
835 pragma Assert (Self_ID = Environment_Task);
|
|
|
836
|
|
|
837 -- Set Environment_Task'Callable to false to notify library-level tasks
|
|
|
838 -- that it is waiting for them.
|
|
|
839
|
|
|
840 Self_ID.Callable := False;
|
|
|
841
|
|
|
842 -- Exit level 2 master, for normal tasks in library-level packages
|
|
|
843
|
|
|
844 Complete_Master;
|
|
|
845
|
|
|
846 -- Force termination of "independent" library-level server tasks
|
|
|
847
|
|
|
848 Lock_RTS;
|
|
|
849
|
|
|
850 Abort_Dependents (Self_ID);
|
|
|
851
|
|
|
852 if not Single_Lock then
|
|
|
853 Unlock_RTS;
|
|
|
854 end if;
|
|
|
855
|
|
|
856 -- We need to explicitly wait for the task to be terminated here
|
|
|
857 -- because on true concurrent system, we may end this procedure before
|
|
|
858 -- the tasks are really terminated.
|
|
|
859
|
|
|
860 Write_Lock (Self_ID);
|
|
|
861
|
|
|
862 -- If the Abort_Task signal is set to system, it means that we may
|
|
|
863 -- not have been able to abort all independent tasks (in particular,
|
|
|
864 -- Server_Task may be blocked, waiting for a signal), in which case, do
|
|
|
865 -- not wait for Independent_Task_Count to go down to 0. We arbitrarily
|
|
|
866 -- limit the number of loop iterations; if an independent task does not
|
|
|
867 -- terminate, we do not want to hang here. In that case, the thread will
|
|
|
868 -- be terminated when the process exits.
|
|
|
869
|
|
|
870 if State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
|
|
|
871 then
|
|
|
872 for J in 1 .. 10 loop
|
|
|
873 exit when Utilities.Independent_Task_Count = 0;
|
|
|
874
|
|
|
875 -- We used to yield here, but this did not take into account low
|
|
|
876 -- priority tasks that would cause dead lock in some cases (true
|
|
|
877 -- FIFO scheduling).
|
|
|
878
|
|
|
879 Timed_Sleep
|
|
|
880 (Self_ID, 0.01, System.OS_Primitives.Relative,
|
|
|
881 Self_ID.Common.State, Ignore_1, Ignore_2);
|
|
|
882 end loop;
|
|
|
883 end if;
|
|
|
884
|
|
|
885 -- ??? On multi-processor environments, it seems that the above loop
|
|
|
886 -- isn't sufficient, so we need to add an additional delay.
|
|
|
887
|
|
|
888 Timed_Sleep
|
|
|
889 (Self_ID, 0.01, System.OS_Primitives.Relative,
|
|
|
890 Self_ID.Common.State, Ignore_1, Ignore_2);
|
|
|
891
|
|
|
892 Unlock (Self_ID);
|
|
|
893
|
|
|
894 if Single_Lock then
|
|
|
895 Unlock_RTS;
|
|
|
896 end if;
|
|
|
897
|
|
|
898 -- Complete the environment task
|
|
|
899
|
|
|
900 Vulnerable_Complete_Task (Self_ID);
|
|
|
901
|
|
|
902 -- Handle normal task termination by the environment task, but only
|
|
|
903 -- for the normal task termination. In the case of Abnormal and
|
|
|
904 -- Unhandled_Exception they must have been handled before, and the
|
|
|
905 -- task termination soft link must have been changed so the task
|
|
|
906 -- termination routine is not executed twice.
|
|
|
907
|
|
|
908 SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
|
|
|
909
|
|
|
910 -- Finalize all library-level controlled objects
|
|
|
911
|
|
|
912 if not SSL."=" (SSL.Finalize_Library_Objects, null) then
|
|
|
913 SSL.Finalize_Library_Objects.all;
|
|
|
914 end if;
|
|
|
915
|
|
|
916 -- Reset the soft links to non-tasking
|
|
|
917
|
|
|
918 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
|
|
|
919 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
|
|
|
920 SSL.Lock_Task := SSL.Task_Lock_NT'Access;
|
|
|
921 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access;
|
|
|
922 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
|
|
|
923 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
|
|
|
924 SSL.Get_Sec_Stack := SSL.Get_Sec_Stack_NT'Access;
|
|
|
925 SSL.Set_Sec_Stack := SSL.Set_Sec_Stack_NT'Access;
|
|
|
926 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
|
|
|
927 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
|
|
|
928
|
|
|
929 -- Don't bother trying to finalize Initialization.Global_Task_Lock
|
|
|
930 -- and System.Task_Primitives.RTS_Lock.
|
|
|
931
|
|
|
932 end Finalize_Global_Tasks;
|
|
|
933
|
|
|
934 ---------------
|
|
|
935 -- Free_Task --
|
|
|
936 ---------------
|
|
|
937
|
|
|
938 procedure Free_Task (T : Task_Id) is
|
|
|
939 Self_Id : constant Task_Id := Self;
|
|
|
940
|
|
|
941 begin
|
|
|
942 if T.Common.State = Terminated then
|
|
|
943
|
|
|
944 -- It is not safe to call Abort_Defer or Write_Lock at this stage
|
|
|
945
|
|
|
946 Initialization.Task_Lock (Self_Id);
|
|
|
947
|
|
|
948 Lock_RTS;
|
|
|
949 Initialization.Finalize_Attributes (T);
|
|
|
950 Initialization.Remove_From_All_Tasks_List (T);
|
|
|
951 Unlock_RTS;
|
|
|
952
|
|
|
953 Initialization.Task_Unlock (Self_Id);
|
|
|
954
|
|
|
955 System.Task_Primitives.Operations.Finalize_TCB (T);
|
|
|
956
|
|
|
957 else
|
|
|
958 -- If the task is not terminated, then mark the task as to be freed
|
|
|
959 -- upon termination.
|
|
|
960
|
|
|
961 T.Free_On_Termination := True;
|
|
|
962 end if;
|
|
|
963 end Free_Task;
|
|
|
964
|
|
|
965 ---------------------------
|
|
|
966 -- Move_Activation_Chain --
|
|
|
967 ---------------------------
|
|
|
968
|
|
|
969 procedure Move_Activation_Chain
|
|
|
970 (From, To : Activation_Chain_Access;
|
|
|
971 New_Master : Master_ID)
|
|
|
972 is
|
|
|
973 Self_ID : constant Task_Id := STPO.Self;
|
|
|
974 C : Task_Id;
|
|
|
975
|
|
|
976 begin
|
|
|
977 pragma Debug
|
|
|
978 (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
|
|
|
979
|
|
|
980 -- Nothing to do if From is empty, and we can check that without
|
|
|
981 -- deferring aborts.
|
|
|
982
|
|
|
983 C := From.all.T_ID;
|
|
|
984
|
|
|
985 if C = null then
|
|
|
986 return;
|
|
|
987 end if;
|
|
|
988
|
|
|
989 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
990
|
|
131
|
991 -- Loop through the From chain, changing their Master_Of_Task fields,
|
|
111
|
992 -- and to find the end of the chain.
|
|
|
993
|
|
|
994 loop
|
|
131
|
995 C.Master_Of_Task := New_Master;
|
|
111
|
996 exit when C.Common.Activation_Link = null;
|
|
|
997 C := C.Common.Activation_Link;
|
|
|
998 end loop;
|
|
|
999
|
|
|
1000 -- Hook From in at the start of To
|
|
|
1001
|
|
|
1002 C.Common.Activation_Link := To.all.T_ID;
|
|
|
1003 To.all.T_ID := From.all.T_ID;
|
|
|
1004
|
|
|
1005 -- Set From to empty
|
|
|
1006
|
|
|
1007 From.all.T_ID := null;
|
|
|
1008
|
|
|
1009 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
1010 end Move_Activation_Chain;
|
|
|
1011
|
|
|
1012 ------------------
|
|
|
1013 -- Task_Wrapper --
|
|
|
1014 ------------------
|
|
|
1015
|
|
|
1016 -- The task wrapper is a procedure that is called first for each task body
|
|
|
1017 -- and which in turn calls the compiler-generated task body procedure.
|
|
|
1018 -- The wrapper's main job is to do initialization for the task. It also
|
|
|
1019 -- has some locally declared objects that serve as per-task local data.
|
|
|
1020 -- Task finalization is done by Complete_Task, which is called from an
|
|
|
1021 -- at-end handler that the compiler generates.
|
|
|
1022
|
|
|
1023 procedure Task_Wrapper (Self_ID : Task_Id) is
|
|
|
1024 use System.Standard_Library;
|
|
|
1025 use System.Stack_Usage;
|
|
|
1026
|
|
|
1027 Bottom_Of_Stack : aliased Integer;
|
|
|
1028
|
|
|
1029 Task_Alternate_Stack :
|
|
|
1030 aliased SSE.Storage_Array (1 .. Alternate_Stack_Size);
|
|
|
1031 -- The alternate signal stack for this task, if any
|
|
|
1032
|
|
|
1033 Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
|
|
|
1034 -- Whether to use above alternate signal stack for stack overflows
|
|
|
1035
|
|
|
1036 SEH_Table : aliased SSE.Storage_Array (1 .. 8);
|
|
|
1037 -- Structured Exception Registration table (2 words)
|
|
|
1038
|
|
|
1039 procedure Install_SEH_Handler (Addr : System.Address);
|
|
|
1040 pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
|
|
|
1041 -- Install the SEH (Structured Exception Handling) handler
|
|
|
1042
|
|
|
1043 Cause : Cause_Of_Termination := Normal;
|
|
|
1044 -- Indicates the reason why this task terminates. Normal corresponds to
|
|
|
1045 -- a task terminating due to completing the last statement of its body,
|
|
|
1046 -- or as a result of waiting on a terminate alternative. If the task
|
|
|
1047 -- terminates because it is being aborted then Cause will be set
|
|
|
1048 -- to Abnormal. If the task terminates because of an exception
|
|
|
1049 -- raised by the execution of its task body, then Cause is set
|
|
|
1050 -- to Unhandled_Exception.
|
|
|
1051
|
|
|
1052 EO : Exception_Occurrence;
|
|
|
1053 -- If the task terminates because of an exception raised by the
|
|
|
1054 -- execution of its task body, then EO will contain the associated
|
|
|
1055 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
|
|
|
1056
|
|
|
1057 TH : Termination_Handler := null;
|
|
|
1058 -- Pointer to the protected procedure to be executed upon task
|
|
|
1059 -- termination.
|
|
|
1060
|
|
|
1061 procedure Search_Fall_Back_Handler (ID : Task_Id);
|
|
|
1062 -- Procedure that searches recursively a fall-back handler through the
|
|
|
1063 -- master relationship. If the handler is found, its pointer is stored
|
|
|
1064 -- in TH. It stops when the handler is found or when the ID is null.
|
|
|
1065
|
|
|
1066 ------------------------------
|
|
|
1067 -- Search_Fall_Back_Handler --
|
|
|
1068 ------------------------------
|
|
|
1069
|
|
|
1070 procedure Search_Fall_Back_Handler (ID : Task_Id) is
|
|
|
1071 begin
|
|
|
1072 -- A null Task_Id indicates that we have reached the root of the
|
|
|
1073 -- task hierarchy and no handler has been found.
|
|
|
1074
|
|
|
1075 if ID = null then
|
|
|
1076 return;
|
|
|
1077
|
|
|
1078 -- If there is a fall back handler, store its pointer for later
|
|
|
1079 -- execution.
|
|
|
1080
|
|
|
1081 elsif ID.Common.Fall_Back_Handler /= null then
|
|
|
1082 TH := ID.Common.Fall_Back_Handler;
|
|
|
1083
|
|
|
1084 -- Otherwise look for a fall back handler in the parent
|
|
|
1085
|
|
|
1086 else
|
|
|
1087 Search_Fall_Back_Handler (ID.Common.Parent);
|
|
|
1088 end if;
|
|
|
1089 end Search_Fall_Back_Handler;
|
|
|
1090
|
|
|
1091 -- Start of processing for Task_Wrapper
|
|
|
1092
|
|
|
1093 begin
|
|
|
1094 pragma Assert (Self_ID.Deferral_Level = 1);
|
|
|
1095
|
|
|
1096 Debug.Master_Hook
|
|
131
|
1097 (Self_ID, Self_ID.Common.Parent, Self_ID.Master_Of_Task);
|
|
111
|
1098
|
|
|
1099 if Use_Alternate_Stack then
|
|
|
1100 Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address;
|
|
|
1101 end if;
|
|
|
1102
|
|
|
1103 -- Set the guard page at the bottom of the stack. The call to unprotect
|
|
|
1104 -- the page is done in Terminate_Task
|
|
|
1105
|
|
|
1106 Stack_Guard (Self_ID, True);
|
|
|
1107
|
|
|
1108 -- Initialize low-level TCB components, that cannot be initialized by
|
|
|
1109 -- the creator. Enter_Task sets Self_ID.LL.Thread.
|
|
|
1110
|
|
|
1111 Enter_Task (Self_ID);
|
|
|
1112
|
|
|
1113 -- Initialize dynamic stack usage
|
|
|
1114
|
|
|
1115 if System.Stack_Usage.Is_Enabled then
|
|
|
1116 declare
|
|
|
1117 Guard_Page_Size : constant := 16 * 1024;
|
|
|
1118 -- Part of the stack used as a guard page. This is an OS dependent
|
|
|
1119 -- value, so we need to use the maximum. This value is only used
|
|
|
1120 -- when the stack address is known, that is currently Windows.
|
|
|
1121
|
|
|
1122 Small_Overflow_Guard : constant := 12 * 1024;
|
|
|
1123 -- Note: this used to be 4K, but was changed to 12K, since
|
|
|
1124 -- smaller values resulted in segmentation faults from dynamic
|
|
|
1125 -- stack analysis.
|
|
|
1126
|
|
|
1127 Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024;
|
|
|
1128 Small_Stack_Limit : constant := 64 * 1024;
|
|
|
1129 -- ??? These three values are experimental, and seem to work on
|
|
|
1130 -- most platforms. They still need to be analyzed further. They
|
|
|
1131 -- also need documentation, what are they and why does the logic
|
|
|
1132 -- differ depending on whether the stack is large or small???
|
|
|
1133
|
|
|
1134 Pattern_Size : Natural :=
|
|
|
1135 Natural (Self_ID.Common.
|
|
|
1136 Compiler_Data.Pri_Stack_Info.Size);
|
|
|
1137 -- Size of the pattern
|
|
|
1138
|
|
|
1139 Stack_Base : Address;
|
|
|
1140 -- Address of the base of the stack
|
|
|
1141
|
|
|
1142 begin
|
|
|
1143 Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base;
|
|
|
1144
|
|
|
1145 if Stack_Base = Null_Address then
|
|
|
1146
|
|
|
1147 -- On many platforms, we don't know the real stack base
|
|
|
1148 -- address. Estimate it using an address in the frame.
|
|
|
1149
|
|
|
1150 Stack_Base := Bottom_Of_Stack'Address;
|
|
|
1151
|
|
|
1152 -- Adjustments for inner frames
|
|
|
1153
|
|
|
1154 Pattern_Size := Pattern_Size -
|
|
|
1155 (if Pattern_Size < Small_Stack_Limit
|
|
|
1156 then Small_Overflow_Guard
|
|
|
1157 else Big_Overflow_Guard);
|
|
|
1158 else
|
|
|
1159 -- Reduce by the size of the final guard page
|
|
|
1160
|
|
|
1161 Pattern_Size := Pattern_Size - Guard_Page_Size;
|
|
|
1162 end if;
|
|
|
1163
|
|
|
1164 STPO.Lock_RTS;
|
|
|
1165 Initialize_Analyzer
|
|
|
1166 (Self_ID.Common.Analyzer,
|
|
|
1167 Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len),
|
|
|
1168 Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size),
|
|
|
1169 SSE.To_Integer (Stack_Base),
|
|
|
1170 Pattern_Size);
|
|
|
1171 STPO.Unlock_RTS;
|
|
|
1172 Fill_Stack (Self_ID.Common.Analyzer);
|
|
|
1173 end;
|
|
|
1174 end if;
|
|
|
1175
|
|
|
1176 -- We setup the SEH (Structured Exception Handling) handler if supported
|
|
|
1177 -- on the target.
|
|
|
1178
|
|
|
1179 Install_SEH_Handler (SEH_Table'Address);
|
|
|
1180
|
|
|
1181 -- Initialize exception occurrence
|
|
|
1182
|
|
|
1183 Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
|
|
|
1184
|
|
|
1185 -- We lock RTS_Lock to wait for activator to finish activating the rest
|
|
|
1186 -- of the chain, so that everyone in the chain comes out in priority
|
|
|
1187 -- order.
|
|
|
1188
|
|
|
1189 -- This also protects the value of
|
|
|
1190 -- Self_ID.Common.Activator.Common.Wait_Count.
|
|
|
1191
|
|
|
1192 Lock_RTS;
|
|
|
1193 Unlock_RTS;
|
|
|
1194
|
|
|
1195 if not System.Restrictions.Abort_Allowed then
|
|
|
1196
|
|
|
1197 -- If Abort is not allowed, reset the deferral level since it will
|
|
|
1198 -- not get changed by the generated code. Keeping a default value
|
|
|
1199 -- of one would prevent some operations (e.g. select or delay) to
|
|
|
1200 -- proceed successfully.
|
|
|
1201
|
|
|
1202 Self_ID.Deferral_Level := 0;
|
|
|
1203 end if;
|
|
|
1204
|
|
|
1205 if Global_Task_Debug_Event_Set then
|
|
|
1206 Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID);
|
|
|
1207 end if;
|
|
|
1208
|
|
|
1209 begin
|
|
|
1210 -- We are separating the following portion of the code in order to
|
|
|
1211 -- place the exception handlers in a different block. In this way,
|
|
|
1212 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
|
|
|
1213 -- set Self in Enter_Task
|
|
|
1214
|
|
|
1215 -- Call the task body procedure
|
|
|
1216
|
|
|
1217 -- The task body is called with abort still deferred. That
|
|
|
1218 -- eliminates a dangerous window, for which we had to patch-up in
|
|
|
1219 -- Terminate_Task.
|
|
|
1220
|
|
|
1221 -- During the expansion of the task body, we insert an RTS-call
|
|
|
1222 -- to Abort_Undefer, at the first point where abort should be
|
|
|
1223 -- allowed.
|
|
|
1224
|
|
|
1225 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
|
|
|
1226 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
1227
|
|
|
1228 exception
|
|
|
1229 -- We can't call Terminate_Task in the exception handlers below,
|
|
|
1230 -- since there may be (e.g. in the case of GCC exception handling)
|
|
|
1231 -- clean ups associated with the exception handler that need to
|
|
|
1232 -- access task specific data.
|
|
|
1233
|
|
|
1234 -- Defer abort so that this task can't be aborted while exiting
|
|
|
1235
|
|
|
1236 when Standard'Abort_Signal =>
|
|
|
1237 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
1238
|
|
|
1239 -- Update the cause that motivated the task termination so that
|
|
|
1240 -- the appropriate information is passed to the task termination
|
|
|
1241 -- procedure. Task termination as a result of waiting on a
|
|
|
1242 -- terminate alternative is a normal termination, although it is
|
|
|
1243 -- implemented using the abort mechanisms.
|
|
|
1244
|
|
|
1245 if Self_ID.Terminate_Alternative then
|
|
|
1246 Cause := Normal;
|
|
|
1247
|
|
|
1248 if Global_Task_Debug_Event_Set then
|
|
|
1249 Debug.Signal_Debug_Event
|
|
|
1250 (Debug.Debug_Event_Terminated, Self_ID);
|
|
|
1251 end if;
|
|
|
1252 else
|
|
|
1253 Cause := Abnormal;
|
|
|
1254
|
|
|
1255 if Global_Task_Debug_Event_Set then
|
|
|
1256 Debug.Signal_Debug_Event
|
|
|
1257 (Debug.Debug_Event_Abort_Terminated, Self_ID);
|
|
|
1258 end if;
|
|
|
1259 end if;
|
|
|
1260
|
|
|
1261 when others =>
|
|
|
1262 -- ??? Using an E : others here causes CD2C11A to fail on Tru64
|
|
|
1263
|
|
|
1264 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
1265
|
|
|
1266 -- Perform the task specific exception tracing duty. We handle
|
|
|
1267 -- these outputs here and not in the common notification routine
|
|
|
1268 -- because we need access to tasking related data and we don't
|
|
|
1269 -- want to drag dependencies against tasking related units in the
|
|
|
1270 -- the common notification units. Additionally, no trace is ever
|
|
|
1271 -- triggered from the common routine for the Unhandled_Raise case
|
|
|
1272 -- in tasks, since an exception never appears unhandled in this
|
|
|
1273 -- context because of this handler.
|
|
|
1274
|
|
|
1275 if Exception_Trace = Unhandled_Raise then
|
|
|
1276 Trace_Unhandled_Exception_In_Task (Self_ID);
|
|
|
1277 end if;
|
|
|
1278
|
|
|
1279 -- Update the cause that motivated the task termination so that
|
|
|
1280 -- the appropriate information is passed to the task termination
|
|
|
1281 -- procedure, as well as the associated Exception_Occurrence.
|
|
|
1282
|
|
|
1283 Cause := Unhandled_Exception;
|
|
|
1284
|
|
|
1285 Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
|
|
|
1286
|
|
|
1287 if Global_Task_Debug_Event_Set then
|
|
|
1288 Debug.Signal_Debug_Event
|
|
|
1289 (Debug.Debug_Event_Exception_Terminated, Self_ID);
|
|
|
1290 end if;
|
|
|
1291 end;
|
|
|
1292
|
|
|
1293 -- Look for a task termination handler. This code is for all tasks but
|
|
|
1294 -- the environment task. The task termination code for the environment
|
|
|
1295 -- task is executed by SSL.Task_Termination_Handler.
|
|
|
1296
|
|
|
1297 if Single_Lock then
|
|
|
1298 Lock_RTS;
|
|
|
1299 end if;
|
|
|
1300
|
|
|
1301 Write_Lock (Self_ID);
|
|
|
1302
|
|
|
1303 if Self_ID.Common.Specific_Handler /= null then
|
|
|
1304 TH := Self_ID.Common.Specific_Handler;
|
|
|
1305
|
|
|
1306 -- Independent tasks should not call the Fall_Back_Handler (of the
|
|
|
1307 -- environment task), because they are implementation artifacts that
|
|
|
1308 -- should be invisible to Ada programs.
|
|
|
1309
|
|
131
|
1310 elsif Self_ID.Master_Of_Task /= Independent_Task_Level then
|
|
111
|
1311
|
|
|
1312 -- Look for a fall-back handler following the master relationship
|
|
|
1313 -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back
|
|
|
1314 -- handler applies only to the dependent tasks of the task". Hence,
|
|
|
1315 -- if the terminating tasks (Self_ID) had a fall-back handler, it
|
|
|
1316 -- would not apply to itself, so we start the search with the parent.
|
|
|
1317
|
|
|
1318 Search_Fall_Back_Handler (Self_ID.Common.Parent);
|
|
|
1319 end if;
|
|
|
1320
|
|
|
1321 Unlock (Self_ID);
|
|
|
1322
|
|
|
1323 if Single_Lock then
|
|
|
1324 Unlock_RTS;
|
|
|
1325 end if;
|
|
|
1326
|
|
|
1327 -- Execute the task termination handler if we found it
|
|
|
1328
|
|
|
1329 if TH /= null then
|
|
|
1330 begin
|
|
|
1331 TH.all (Cause, Self_ID, EO);
|
|
|
1332
|
|
|
1333 exception
|
|
|
1334
|
|
|
1335 -- RM-C.7.3 requires all exceptions raised here to be ignored
|
|
|
1336
|
|
|
1337 when others =>
|
|
|
1338 null;
|
|
|
1339 end;
|
|
|
1340 end if;
|
|
|
1341
|
|
|
1342 if System.Stack_Usage.Is_Enabled then
|
|
|
1343 Compute_Result (Self_ID.Common.Analyzer);
|
|
|
1344 Report_Result (Self_ID.Common.Analyzer);
|
|
|
1345 end if;
|
|
|
1346
|
|
|
1347 Terminate_Task (Self_ID);
|
|
|
1348 end Task_Wrapper;
|
|
|
1349
|
|
|
1350 --------------------
|
|
|
1351 -- Terminate_Task --
|
|
|
1352 --------------------
|
|
|
1353
|
|
|
1354 -- Before we allow the thread to exit, we must clean up. This is a delicate
|
|
|
1355 -- job. We must wake up the task's master, who may immediately try to
|
|
|
1356 -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING.
|
|
|
1357
|
|
|
1358 -- To avoid this, the parent task must be blocked up to the latest
|
|
|
1359 -- statement executed. The trouble is that we have another step that we
|
|
|
1360 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
|
|
|
1361 -- We have to postpone that until the end because compiler-generated code
|
|
|
1362 -- is likely to try to access that data at just about any point.
|
|
|
1363
|
|
|
1364 -- We can't call Destroy_TSD while we are holding any other locks, because
|
|
|
1365 -- it locks Global_Task_Lock, and our deadlock prevention rules require
|
|
|
1366 -- that to be the outermost lock. Our first "solution" was to just lock
|
|
|
1367 -- Global_Task_Lock in addition to the other locks, and force the parent to
|
|
|
1368 -- also lock this lock between its wakeup and its freeing of the ATCB. See
|
|
|
1369 -- Complete_Task for the parent-side of the code that has the matching
|
|
|
1370 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
|
|
|
1371 -- since the operation Task_Unlock continued to access the ATCB after
|
|
|
1372 -- unlocking, after which the parent was observed to race ahead, deallocate
|
|
|
1373 -- the ATCB, and then reallocate it to another task. The call to
|
|
|
1374 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
|
|
|
1375 -- the data of the new task that reused the ATCB. To solve this problem, we
|
|
|
1376 -- introduced the new operation Final_Task_Unlock.
|
|
|
1377
|
|
|
1378 procedure Terminate_Task (Self_ID : Task_Id) is
|
|
|
1379 Environment_Task : constant Task_Id := STPO.Environment_Task;
|
|
131
|
1380 Master_Of_Task : Integer;
|
|
111
|
1381 Deallocate : Boolean;
|
|
|
1382
|
|
|
1383 begin
|
|
|
1384 Debug.Task_Termination_Hook;
|
|
|
1385
|
|
|
1386 -- Since GCC cannot allocate stack chunks efficiently without reordering
|
|
|
1387 -- some of the allocations, we have to handle this unexpected situation
|
|
|
1388 -- here. Normally we never have to call Vulnerable_Complete_Task here.
|
|
|
1389
|
|
|
1390 if Self_ID.Common.Activator /= null then
|
|
|
1391 Vulnerable_Complete_Task (Self_ID);
|
|
|
1392 end if;
|
|
|
1393
|
|
|
1394 Initialization.Task_Lock (Self_ID);
|
|
|
1395
|
|
|
1396 if Single_Lock then
|
|
|
1397 Lock_RTS;
|
|
|
1398 end if;
|
|
|
1399
|
|
131
|
1400 Master_Of_Task := Self_ID.Master_Of_Task;
|
|
111
|
1401
|
|
|
1402 -- Check if the current task is an independent task If so, decrement
|
|
|
1403 -- the Independent_Task_Count value.
|
|
|
1404
|
|
131
|
1405 if Master_Of_Task = Independent_Task_Level then
|
|
111
|
1406 if Single_Lock then
|
|
|
1407 Utilities.Independent_Task_Count :=
|
|
|
1408 Utilities.Independent_Task_Count - 1;
|
|
|
1409
|
|
|
1410 else
|
|
|
1411 Write_Lock (Environment_Task);
|
|
|
1412 Utilities.Independent_Task_Count :=
|
|
|
1413 Utilities.Independent_Task_Count - 1;
|
|
|
1414 Unlock (Environment_Task);
|
|
|
1415 end if;
|
|
|
1416 end if;
|
|
|
1417
|
|
|
1418 -- Unprotect the guard page if needed
|
|
|
1419
|
|
|
1420 Stack_Guard (Self_ID, False);
|
|
|
1421
|
|
|
1422 Utilities.Make_Passive (Self_ID, Task_Completed => True);
|
|
|
1423 Deallocate := Self_ID.Free_On_Termination;
|
|
|
1424
|
|
|
1425 if Single_Lock then
|
|
|
1426 Unlock_RTS;
|
|
|
1427 end if;
|
|
|
1428
|
|
|
1429 pragma Assert (Check_Exit (Self_ID));
|
|
|
1430
|
|
|
1431 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
|
|
|
1432 Initialization.Final_Task_Unlock (Self_ID);
|
|
|
1433
|
|
|
1434 -- WARNING: past this point, this thread must assume that the ATCB has
|
|
|
1435 -- been deallocated, and can't access it anymore (which is why we have
|
|
|
1436 -- saved the Free_On_Termination flag in a temporary variable).
|
|
|
1437
|
|
|
1438 if Deallocate then
|
|
|
1439 Free_Task (Self_ID);
|
|
|
1440 end if;
|
|
|
1441
|
|
131
|
1442 if Master_Of_Task > 0 then
|
|
111
|
1443 STPO.Exit_Task;
|
|
|
1444 end if;
|
|
|
1445 end Terminate_Task;
|
|
|
1446
|
|
|
1447 ----------------
|
|
|
1448 -- Terminated --
|
|
|
1449 ----------------
|
|
|
1450
|
|
|
1451 function Terminated (T : Task_Id) return Boolean is
|
|
|
1452 Self_ID : constant Task_Id := STPO.Self;
|
|
|
1453 Result : Boolean;
|
|
|
1454
|
|
|
1455 begin
|
|
|
1456 Initialization.Defer_Abort_Nestable (Self_ID);
|
|
|
1457
|
|
|
1458 if Single_Lock then
|
|
|
1459 Lock_RTS;
|
|
|
1460 end if;
|
|
|
1461
|
|
|
1462 Write_Lock (T);
|
|
|
1463 Result := T.Common.State = Terminated;
|
|
|
1464 Unlock (T);
|
|
|
1465
|
|
|
1466 if Single_Lock then
|
|
|
1467 Unlock_RTS;
|
|
|
1468 end if;
|
|
|
1469
|
|
|
1470 Initialization.Undefer_Abort_Nestable (Self_ID);
|
|
|
1471 return Result;
|
|
|
1472 end Terminated;
|
|
|
1473
|
|
|
1474 ----------------------------------------
|
|
|
1475 -- Trace_Unhandled_Exception_In_Task --
|
|
|
1476 ----------------------------------------
|
|
|
1477
|
|
|
1478 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
|
|
|
1479 procedure To_Stderr (S : String);
|
|
|
1480 pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
|
|
|
1481
|
|
|
1482 use System.Soft_Links;
|
|
|
1483
|
|
|
1484 function To_Address is new
|
|
|
1485 Ada.Unchecked_Conversion
|
|
|
1486 (Task_Id, System.Task_Primitives.Task_Address);
|
|
|
1487
|
|
|
1488 Excep : constant Exception_Occurrence_Access :=
|
|
|
1489 SSL.Get_Current_Excep.all;
|
|
|
1490
|
|
|
1491 begin
|
|
|
1492 -- This procedure is called by the task outermost handler in
|
|
|
1493 -- Task_Wrapper below, so only once the task stack has been fully
|
|
|
1494 -- unwound. The common notification routine has been called at the
|
|
|
1495 -- raise point already.
|
|
|
1496
|
|
|
1497 -- Lock to prevent unsynchronized output
|
|
|
1498
|
|
|
1499 Initialization.Task_Lock (Self_Id);
|
|
|
1500 To_Stderr ("task ");
|
|
|
1501
|
|
|
1502 if Self_Id.Common.Task_Image_Len /= 0 then
|
|
|
1503 To_Stderr
|
|
|
1504 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
|
|
|
1505 To_Stderr ("_");
|
|
|
1506 end if;
|
|
|
1507
|
|
|
1508 To_Stderr (System.Address_Image (To_Address (Self_Id)));
|
|
|
1509 To_Stderr (" terminated by unhandled exception");
|
|
|
1510 To_Stderr ((1 => ASCII.LF));
|
|
|
1511 To_Stderr (Exception_Information (Excep.all));
|
|
|
1512 Initialization.Task_Unlock (Self_Id);
|
|
|
1513 end Trace_Unhandled_Exception_In_Task;
|
|
|
1514
|
|
|
1515 ------------------------------------
|
|
|
1516 -- Vulnerable_Complete_Activation --
|
|
|
1517 ------------------------------------
|
|
|
1518
|
|
|
1519 -- As in several other places, the locks of the activator and activated
|
|
|
1520 -- task are both locked here. This follows our deadlock prevention lock
|
|
|
1521 -- ordering policy, since the activated task must be created after the
|
|
|
1522 -- activator.
|
|
|
1523
|
|
|
1524 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
|
|
|
1525 Activator : constant Task_Id := Self_ID.Common.Activator;
|
|
|
1526
|
|
|
1527 begin
|
|
|
1528 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
|
|
|
1529
|
|
|
1530 Write_Lock (Activator);
|
|
|
1531 Write_Lock (Self_ID);
|
|
|
1532
|
|
|
1533 pragma Assert (Self_ID.Common.Activator /= null);
|
|
|
1534
|
|
|
1535 -- Remove dangling reference to Activator, since a task may outlive its
|
|
|
1536 -- activator.
|
|
|
1537
|
|
|
1538 Self_ID.Common.Activator := null;
|
|
|
1539
|
|
|
1540 -- Wake up the activator, if it is waiting for a chain of tasks to
|
|
|
1541 -- activate, and we are the last in the chain to complete activation.
|
|
|
1542
|
|
|
1543 if Activator.Common.State = Activator_Sleep then
|
|
|
1544 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
|
|
|
1545
|
|
|
1546 if Activator.Common.Wait_Count = 0 then
|
|
|
1547 Wakeup (Activator, Activator_Sleep);
|
|
|
1548 end if;
|
|
|
1549 end if;
|
|
|
1550
|
|
|
1551 -- The activator raises a Tasking_Error if any task it is activating
|
|
|
1552 -- is completed before the activation is done. However, if the reason
|
|
|
1553 -- for the task completion is an abort, we do not raise an exception.
|
|
|
1554 -- See RM 9.2(5).
|
|
|
1555
|
|
|
1556 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
|
|
|
1557 Activator.Common.Activation_Failed := True;
|
|
|
1558 end if;
|
|
|
1559
|
|
|
1560 Unlock (Self_ID);
|
|
|
1561 Unlock (Activator);
|
|
|
1562
|
|
|
1563 -- After the activation, active priority should be the same as base
|
|
|
1564 -- priority. We must unlock the Activator first, though, since it
|
|
|
1565 -- should not wait if we have lower priority.
|
|
|
1566
|
|
|
1567 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
|
|
|
1568 Write_Lock (Self_ID);
|
|
|
1569 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
|
|
|
1570 Unlock (Self_ID);
|
|
|
1571 end if;
|
|
|
1572 end Vulnerable_Complete_Activation;
|
|
|
1573
|
|
|
1574 --------------------------------
|
|
|
1575 -- Vulnerable_Complete_Master --
|
|
|
1576 --------------------------------
|
|
|
1577
|
|
|
1578 procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
|
|
|
1579 C : Task_Id;
|
|
|
1580 P : Task_Id;
|
|
|
1581 CM : constant Master_Level := Self_ID.Master_Within;
|
|
|
1582 T : aliased Task_Id;
|
|
|
1583
|
|
|
1584 To_Be_Freed : Task_Id;
|
|
|
1585 -- This is a list of ATCBs to be freed, after we have released all RTS
|
|
|
1586 -- locks. This is necessary because of the locking order rules, since
|
|
|
1587 -- the storage manager uses Global_Task_Lock.
|
|
|
1588
|
|
|
1589 pragma Warnings (Off);
|
|
|
1590 function Check_Unactivated_Tasks return Boolean;
|
|
|
1591 pragma Warnings (On);
|
|
|
1592 -- Temporary error-checking code below. This is part of the checks
|
|
|
1593 -- added in the new run time. Call it only inside a pragma Assert.
|
|
|
1594
|
|
|
1595 -----------------------------
|
|
|
1596 -- Check_Unactivated_Tasks --
|
|
|
1597 -----------------------------
|
|
|
1598
|
|
|
1599 function Check_Unactivated_Tasks return Boolean is
|
|
|
1600 begin
|
|
|
1601 if not Single_Lock then
|
|
|
1602 Lock_RTS;
|
|
|
1603 end if;
|
|
|
1604
|
|
|
1605 Write_Lock (Self_ID);
|
|
|
1606
|
|
|
1607 C := All_Tasks_List;
|
|
|
1608 while C /= null loop
|
|
131
|
1609 if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then
|
|
111
|
1610 return False;
|
|
|
1611 end if;
|
|
|
1612
|
|
131
|
1613 if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
|
|
111
|
1614 Write_Lock (C);
|
|
|
1615
|
|
|
1616 if C.Common.State = Unactivated then
|
|
|
1617 return False;
|
|
|
1618 end if;
|
|
|
1619
|
|
|
1620 Unlock (C);
|
|
|
1621 end if;
|
|
|
1622
|
|
|
1623 C := C.Common.All_Tasks_Link;
|
|
|
1624 end loop;
|
|
|
1625
|
|
|
1626 Unlock (Self_ID);
|
|
|
1627
|
|
|
1628 if not Single_Lock then
|
|
|
1629 Unlock_RTS;
|
|
|
1630 end if;
|
|
|
1631
|
|
|
1632 return True;
|
|
|
1633 end Check_Unactivated_Tasks;
|
|
|
1634
|
|
|
1635 -- Start of processing for Vulnerable_Complete_Master
|
|
|
1636
|
|
|
1637 begin
|
|
|
1638 pragma Debug
|
|
|
1639 (Debug.Trace (Self_ID, "V_Complete_Master(" & CM'Img & ")", 'C'));
|
|
|
1640
|
|
|
1641 pragma Assert (Self_ID.Common.Wait_Count = 0);
|
|
|
1642 pragma Assert
|
|
|
1643 (Self_ID.Deferral_Level > 0
|
|
|
1644 or else not System.Restrictions.Abort_Allowed);
|
|
|
1645
|
|
|
1646 -- Count how many active dependent tasks this master currently has, and
|
|
|
1647 -- record this in Wait_Count.
|
|
|
1648
|
|
|
1649 -- This count should start at zero, since it is initialized to zero for
|
|
|
1650 -- new tasks, and the task should not exit the sleep-loops that use this
|
|
|
1651 -- count until the count reaches zero.
|
|
|
1652
|
|
|
1653 -- While we're counting, if we run across any unactivated tasks that
|
|
|
1654 -- belong to this master, we summarily terminate them as required by
|
|
|
1655 -- RM-9.2(6).
|
|
|
1656
|
|
|
1657 Lock_RTS;
|
|
|
1658 Write_Lock (Self_ID);
|
|
|
1659
|
|
|
1660 C := All_Tasks_List;
|
|
|
1661 while C /= null loop
|
|
|
1662
|
|
|
1663 -- Terminate unactivated (never-to-be activated) tasks
|
|
|
1664
|
|
131
|
1665 if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then
|
|
|
1666
|
|
|
1667 -- Usually, C.Common.Activator = Self_ID implies C.Master_Of_Task
|
|
111
|
1668 -- = CM. The only case where C is pending activation by this
|
|
|
1669 -- task, but the master of C is not CM is in Ada 2005, when C is
|
|
|
1670 -- part of a return object of a build-in-place function.
|
|
|
1671
|
|
|
1672 pragma Assert (C.Common.State = Unactivated);
|
|
|
1673
|
|
|
1674 Write_Lock (C);
|
|
|
1675 C.Common.Activator := null;
|
|
|
1676 C.Common.State := Terminated;
|
|
|
1677 C.Callable := False;
|
|
|
1678 Utilities.Cancel_Queued_Entry_Calls (C);
|
|
|
1679 Unlock (C);
|
|
|
1680 end if;
|
|
|
1681
|
|
|
1682 -- Count it if directly dependent on this master
|
|
|
1683
|
|
131
|
1684 if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
|
|
111
|
1685 Write_Lock (C);
|
|
|
1686
|
|
|
1687 if C.Awake_Count /= 0 then
|
|
|
1688 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
|
|
|
1689 end if;
|
|
|
1690
|
|
|
1691 Unlock (C);
|
|
|
1692 end if;
|
|
|
1693
|
|
|
1694 C := C.Common.All_Tasks_Link;
|
|
|
1695 end loop;
|
|
|
1696
|
|
|
1697 Self_ID.Common.State := Master_Completion_Sleep;
|
|
|
1698 Unlock (Self_ID);
|
|
|
1699
|
|
|
1700 if not Single_Lock then
|
|
|
1701 Unlock_RTS;
|
|
|
1702 end if;
|
|
|
1703
|
|
|
1704 -- Wait until dependent tasks are all terminated or ready to terminate.
|
|
|
1705 -- While waiting, the task may be awakened if the task's priority needs
|
|
|
1706 -- changing, or this master is aborted. In the latter case, we abort the
|
|
|
1707 -- dependents, and resume waiting until Wait_Count goes to zero.
|
|
|
1708
|
|
|
1709 Write_Lock (Self_ID);
|
|
|
1710
|
|
|
1711 loop
|
|
|
1712 exit when Self_ID.Common.Wait_Count = 0;
|
|
|
1713
|
|
|
1714 -- Here is a difference as compared to Complete_Master
|
|
|
1715
|
|
|
1716 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
|
|
1717 and then not Self_ID.Dependents_Aborted
|
|
|
1718 then
|
|
|
1719 if Single_Lock then
|
|
|
1720 Abort_Dependents (Self_ID);
|
|
|
1721 else
|
|
|
1722 Unlock (Self_ID);
|
|
|
1723 Lock_RTS;
|
|
|
1724 Abort_Dependents (Self_ID);
|
|
|
1725 Unlock_RTS;
|
|
|
1726 Write_Lock (Self_ID);
|
|
|
1727 end if;
|
|
|
1728 else
|
|
|
1729 pragma Debug
|
|
|
1730 (Debug.Trace (Self_ID, "master_completion_sleep", 'C'));
|
|
|
1731 Sleep (Self_ID, Master_Completion_Sleep);
|
|
|
1732 end if;
|
|
|
1733 end loop;
|
|
|
1734
|
|
|
1735 Self_ID.Common.State := Runnable;
|
|
|
1736 Unlock (Self_ID);
|
|
|
1737
|
|
|
1738 -- Dependents are all terminated or on terminate alternatives. Now,
|
|
|
1739 -- force those on terminate alternatives to terminate, by aborting them.
|
|
|
1740
|
|
|
1741 pragma Assert (Check_Unactivated_Tasks);
|
|
|
1742
|
|
|
1743 if Self_ID.Alive_Count > 1 then
|
|
|
1744 -- ???
|
|
|
1745 -- Consider finding a way to skip the following extra steps if there
|
|
|
1746 -- are no dependents with terminate alternatives. This could be done
|
|
|
1747 -- by adding another count to the ATCB, similar to Awake_Count, but
|
|
|
1748 -- keeping track of tasks that are on terminate alternatives.
|
|
|
1749
|
|
|
1750 pragma Assert (Self_ID.Common.Wait_Count = 0);
|
|
|
1751
|
|
|
1752 -- Force any remaining dependents to terminate by aborting them
|
|
|
1753
|
|
|
1754 if not Single_Lock then
|
|
|
1755 Lock_RTS;
|
|
|
1756 end if;
|
|
|
1757
|
|
|
1758 Abort_Dependents (Self_ID);
|
|
|
1759
|
|
|
1760 -- Above, when we "abort" the dependents we are simply using this
|
|
|
1761 -- operation for convenience. We are not required to support the full
|
|
|
1762 -- abort-statement semantics; in particular, we are not required to
|
|
|
1763 -- immediately cancel any queued or in-service entry calls. That is
|
|
|
1764 -- good, because if we tried to cancel a call we would need to lock
|
|
|
1765 -- the caller, in order to wake the caller up. Our anti-deadlock
|
|
|
1766 -- rules prevent us from doing that without releasing the locks on C
|
|
|
1767 -- and Self_ID. Releasing and retaking those locks would be wasteful
|
|
|
1768 -- at best, and should not be considered further without more
|
|
|
1769 -- detailed analysis of potential concurrent accesses to the ATCBs
|
|
|
1770 -- of C and Self_ID.
|
|
|
1771
|
|
|
1772 -- Count how many "alive" dependent tasks this master currently has,
|
|
|
1773 -- and record this in Wait_Count. This count should start at zero,
|
|
|
1774 -- since it is initialized to zero for new tasks, and the task should
|
|
|
1775 -- not exit the sleep-loops that use this count until the count
|
|
|
1776 -- reaches zero.
|
|
|
1777
|
|
|
1778 pragma Assert (Self_ID.Common.Wait_Count = 0);
|
|
|
1779
|
|
|
1780 Write_Lock (Self_ID);
|
|
|
1781
|
|
|
1782 C := All_Tasks_List;
|
|
|
1783 while C /= null loop
|
|
131
|
1784 if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
|
|
111
|
1785 Write_Lock (C);
|
|
|
1786
|
|
|
1787 pragma Assert (C.Awake_Count = 0);
|
|
|
1788
|
|
|
1789 if C.Alive_Count > 0 then
|
|
|
1790 pragma Assert (C.Terminate_Alternative);
|
|
|
1791 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
|
|
|
1792 end if;
|
|
|
1793
|
|
|
1794 Unlock (C);
|
|
|
1795 end if;
|
|
|
1796
|
|
|
1797 C := C.Common.All_Tasks_Link;
|
|
|
1798 end loop;
|
|
|
1799
|
|
|
1800 Self_ID.Common.State := Master_Phase_2_Sleep;
|
|
|
1801 Unlock (Self_ID);
|
|
|
1802
|
|
|
1803 if not Single_Lock then
|
|
|
1804 Unlock_RTS;
|
|
|
1805 end if;
|
|
|
1806
|
|
|
1807 -- Wait for all counted tasks to finish terminating themselves
|
|
|
1808
|
|
|
1809 Write_Lock (Self_ID);
|
|
|
1810
|
|
|
1811 loop
|
|
|
1812 exit when Self_ID.Common.Wait_Count = 0;
|
|
|
1813 Sleep (Self_ID, Master_Phase_2_Sleep);
|
|
|
1814 end loop;
|
|
|
1815
|
|
|
1816 Self_ID.Common.State := Runnable;
|
|
|
1817 Unlock (Self_ID);
|
|
|
1818 end if;
|
|
|
1819
|
|
|
1820 -- We don't wake up for abort here. We are already terminating just as
|
|
|
1821 -- fast as we can, so there is no point.
|
|
|
1822
|
|
|
1823 -- Remove terminated tasks from the list of Self_ID's dependents, but
|
|
|
1824 -- don't free their ATCBs yet, because of lock order restrictions, which
|
|
|
1825 -- don't allow us to call "free" or "malloc" while holding any other
|
|
|
1826 -- locks. Instead, we put those ATCBs to be freed onto a temporary list,
|
|
|
1827 -- called To_Be_Freed.
|
|
|
1828
|
|
|
1829 if not Single_Lock then
|
|
|
1830 Lock_RTS;
|
|
|
1831 end if;
|
|
|
1832
|
|
|
1833 C := All_Tasks_List;
|
|
|
1834 P := null;
|
|
|
1835 while C /= null loop
|
|
|
1836
|
|
|
1837 -- If Free_On_Termination is set, do nothing here, and let the
|
|
|
1838 -- task free itself if not already done, otherwise we risk a race
|
|
|
1839 -- condition where Vulnerable_Free_Task is called in the loop below,
|
|
|
1840 -- while the task calls Free_Task itself, in Terminate_Task.
|
|
|
1841
|
|
|
1842 if C.Common.Parent = Self_ID
|
|
131
|
1843 and then C.Master_Of_Task >= CM
|
|
111
|
1844 and then not C.Free_On_Termination
|
|
|
1845 then
|
|
|
1846 if P /= null then
|
|
|
1847 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
|
|
|
1848 else
|
|
|
1849 All_Tasks_List := C.Common.All_Tasks_Link;
|
|
|
1850 end if;
|
|
|
1851
|
|
|
1852 T := C.Common.All_Tasks_Link;
|
|
|
1853 C.Common.All_Tasks_Link := To_Be_Freed;
|
|
|
1854 To_Be_Freed := C;
|
|
|
1855 C := T;
|
|
|
1856
|
|
|
1857 else
|
|
|
1858 P := C;
|
|
|
1859 C := C.Common.All_Tasks_Link;
|
|
|
1860 end if;
|
|
|
1861 end loop;
|
|
|
1862
|
|
|
1863 Unlock_RTS;
|
|
|
1864
|
|
|
1865 -- Free all the ATCBs on the list To_Be_Freed
|
|
|
1866
|
|
|
1867 -- The ATCBs in the list are no longer in All_Tasks_List, and after
|
|
|
1868 -- any interrupt entries are detached from them they should no longer
|
|
|
1869 -- be referenced.
|
|
|
1870
|
|
|
1871 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
|
|
|
1872 -- avoid a race between a terminating task and its parent. The parent
|
|
|
1873 -- might try to deallocate the ACTB out from underneath the exiting
|
|
|
1874 -- task. Note that Free will also lock Global_Task_Lock, but that is
|
|
|
1875 -- OK, since this is the *one* lock for which we have a mechanism to
|
|
|
1876 -- support nested locking. See Task_Wrapper and its finalizer for more
|
|
|
1877 -- explanation.
|
|
|
1878
|
|
|
1879 -- ???
|
|
|
1880 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
|
|
|
1881 -- references to terminated library-level tasks, which could otherwise
|
|
|
1882 -- occur during finalization of library-level objects. A better solution
|
|
|
1883 -- might be to hook task objects into the finalization chain and
|
|
|
1884 -- deallocate the ATCB when the task object is deallocated. However,
|
|
|
1885 -- this change is not likely to gain anything significant, since all
|
|
|
1886 -- this storage should be recovered en-masse when the process exits.
|
|
|
1887
|
|
|
1888 while To_Be_Freed /= null loop
|
|
|
1889 T := To_Be_Freed;
|
|
|
1890 To_Be_Freed := T.Common.All_Tasks_Link;
|
|
|
1891
|
|
|
1892 -- ??? On SGI there is currently no Interrupt_Manager, that's why we
|
|
|
1893 -- need to check if the Interrupt_Manager_ID is null.
|
|
|
1894
|
|
|
1895 if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then
|
|
|
1896 declare
|
|
|
1897 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
|
|
|
1898 -- Corresponds to the entry index of System.Interrupts.
|
|
|
1899 -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure
|
|
|
1900 -- to update this value when changing Interrupt_Manager specs.
|
|
|
1901
|
|
|
1902 type Param_Type is access all Task_Id;
|
|
|
1903
|
|
|
1904 Param : aliased Param_Type := T'Access;
|
|
|
1905
|
|
|
1906 begin
|
|
|
1907 System.Tasking.Rendezvous.Call_Simple
|
|
|
1908 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
|
|
|
1909 Param'Address);
|
|
|
1910 end;
|
|
|
1911 end if;
|
|
|
1912
|
|
|
1913 if (T.Common.Parent /= null
|
|
|
1914 and then T.Common.Parent.Common.Parent /= null)
|
|
131
|
1915 or else T.Master_Of_Task > Library_Task_Level
|
|
111
|
1916 then
|
|
|
1917 Initialization.Task_Lock (Self_ID);
|
|
|
1918
|
|
|
1919 -- If Sec_Stack_Ptr is not null, it means that Destroy_TSD
|
|
|
1920 -- has not been called yet (case of an unactivated task).
|
|
|
1921
|
|
|
1922 if T.Common.Compiler_Data.Sec_Stack_Ptr /= null then
|
|
|
1923 SSL.Destroy_TSD (T.Common.Compiler_Data);
|
|
|
1924 end if;
|
|
|
1925
|
|
|
1926 Vulnerable_Free_Task (T);
|
|
|
1927 Initialization.Task_Unlock (Self_ID);
|
|
|
1928 end if;
|
|
|
1929 end loop;
|
|
|
1930
|
|
|
1931 -- It might seem nice to let the terminated task deallocate its own
|
|
|
1932 -- ATCB. That would not cover the case of unactivated tasks. It also
|
|
|
1933 -- would force us to keep the underlying thread around past termination,
|
|
|
1934 -- since references to the ATCB are possible past termination.
|
|
|
1935
|
|
|
1936 -- Currently, we get rid of the thread as soon as the task terminates,
|
|
|
1937 -- and let the parent recover the ATCB later.
|
|
|
1938
|
|
|
1939 -- Some day, if we want to recover the ATCB earlier, at task
|
|
|
1940 -- termination, we could consider using "fat task IDs", that include the
|
|
|
1941 -- serial number with the ATCB pointer, to catch references to tasks
|
|
|
1942 -- that no longer have ATCBs. It is not clear how much this would gain,
|
|
|
1943 -- since the user-level task object would still be occupying storage.
|
|
|
1944
|
|
|
1945 -- Make next master level up active. We don't need to lock the ATCB,
|
|
|
1946 -- since the value is only updated by each task for itself.
|
|
|
1947
|
|
|
1948 Self_ID.Master_Within := CM - 1;
|
|
|
1949
|
|
|
1950 Debug.Master_Completed_Hook (Self_ID, CM);
|
|
|
1951 end Vulnerable_Complete_Master;
|
|
|
1952
|
|
|
1953 ------------------------------
|
|
|
1954 -- Vulnerable_Complete_Task --
|
|
|
1955 ------------------------------
|
|
|
1956
|
|
|
1957 -- Complete the calling task
|
|
|
1958
|
|
|
1959 -- This procedure must be called with abort deferred. It should only be
|
|
|
1960 -- called by Complete_Task and Finalize_Global_Tasks (for the environment
|
|
|
1961 -- task).
|
|
|
1962
|
|
|
1963 -- The effect is similar to that of Complete_Master. Differences include
|
|
|
1964 -- the closing of entries here, and computation of the number of active
|
|
|
1965 -- dependent tasks in Complete_Master.
|
|
|
1966
|
|
|
1967 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
|
|
|
1968 -- because that does its own locking, and because we do not need the lock
|
|
|
1969 -- to test Self_ID.Common.Activator. That value should only be read and
|
|
|
1970 -- modified by Self.
|
|
|
1971
|
|
|
1972 procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
|
|
|
1973 begin
|
|
|
1974 pragma Assert
|
|
|
1975 (Self_ID.Deferral_Level > 0
|
|
|
1976 or else not System.Restrictions.Abort_Allowed);
|
|
|
1977 pragma Assert (Self_ID = Self);
|
|
|
1978 pragma Assert
|
|
|
1979 (Self_ID.Master_Within in
|
|
131
|
1980 Self_ID.Master_Of_Task .. Self_ID.Master_Of_Task + 3);
|
|
111
|
1981 pragma Assert (Self_ID.Common.Wait_Count = 0);
|
|
|
1982 pragma Assert (Self_ID.Open_Accepts = null);
|
|
|
1983 pragma Assert (Self_ID.ATC_Nesting_Level = 1);
|
|
|
1984
|
|
|
1985 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
|
|
|
1986
|
|
|
1987 if Single_Lock then
|
|
|
1988 Lock_RTS;
|
|
|
1989 end if;
|
|
|
1990
|
|
|
1991 Write_Lock (Self_ID);
|
|
|
1992 Self_ID.Callable := False;
|
|
|
1993
|
|
|
1994 -- In theory, Self should have no pending entry calls left on its
|
|
|
1995 -- call-stack. Each async. select statement should clean its own call,
|
|
|
1996 -- and blocking entry calls should defer abort until the calls are
|
|
|
1997 -- cancelled, then clean up.
|
|
|
1998
|
|
|
1999 Utilities.Cancel_Queued_Entry_Calls (Self_ID);
|
|
|
2000 Unlock (Self_ID);
|
|
|
2001
|
|
|
2002 if Self_ID.Common.Activator /= null then
|
|
|
2003 Vulnerable_Complete_Activation (Self_ID);
|
|
|
2004 end if;
|
|
|
2005
|
|
|
2006 if Single_Lock then
|
|
|
2007 Unlock_RTS;
|
|
|
2008 end if;
|
|
|
2009
|
|
131
|
2010 -- If Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 we may have
|
|
111
|
2011 -- dependent tasks for which we need to wait. Otherwise we just exit.
|
|
|
2012
|
|
131
|
2013 if Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 then
|
|
111
|
2014 Vulnerable_Complete_Master (Self_ID);
|
|
|
2015 end if;
|
|
|
2016 end Vulnerable_Complete_Task;
|
|
|
2017
|
|
|
2018 --------------------------
|
|
|
2019 -- Vulnerable_Free_Task --
|
|
|
2020 --------------------------
|
|
|
2021
|
|
|
2022 -- Recover all runtime system storage associated with the task T. This
|
|
|
2023 -- should only be called after T has terminated and will no longer be
|
|
|
2024 -- referenced.
|
|
|
2025
|
|
|
2026 -- For tasks created by an allocator that fails, due to an exception, it
|
|
|
2027 -- is called from Expunge_Unactivated_Tasks.
|
|
|
2028
|
|
|
2029 -- For tasks created by elaboration of task object declarations it is
|
|
|
2030 -- called from the finalization code of the Task_Wrapper procedure.
|
|
|
2031
|
|
|
2032 procedure Vulnerable_Free_Task (T : Task_Id) is
|
|
|
2033 begin
|
|
|
2034 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
|
|
|
2035
|
|
|
2036 if Single_Lock then
|
|
|
2037 Lock_RTS;
|
|
|
2038 end if;
|
|
|
2039
|
|
|
2040 Write_Lock (T);
|
|
|
2041 Initialization.Finalize_Attributes (T);
|
|
|
2042 Unlock (T);
|
|
|
2043
|
|
|
2044 if Single_Lock then
|
|
|
2045 Unlock_RTS;
|
|
|
2046 end if;
|
|
|
2047
|
|
|
2048 System.Task_Primitives.Operations.Finalize_TCB (T);
|
|
|
2049 end Vulnerable_Free_Task;
|
|
|
2050
|
|
|
2051 -- Package elaboration code
|
|
|
2052
|
|
|
2053 begin
|
|
|
2054 -- Establish the Adafinal softlink
|
|
|
2055
|
|
|
2056 -- This is not done inside the central RTS initialization routine
|
|
|
2057 -- to avoid with'ing this package from System.Tasking.Initialization.
|
|
|
2058
|
|
|
2059 SSL.Adafinal := Finalize_Global_Tasks'Access;
|
|
|
2060
|
|
|
2061 -- Establish soft links for subprograms that manipulate master_id's.
|
|
|
2062 -- This cannot be done when the RTS is initialized, because of various
|
|
|
2063 -- elaboration constraints.
|
|
|
2064
|
|
|
2065 SSL.Current_Master := Stages.Current_Master'Access;
|
|
|
2066 SSL.Enter_Master := Stages.Enter_Master'Access;
|
|
|
2067 SSL.Complete_Master := Stages.Complete_Master'Access;
|
|
|
2068 end System.Tasking.Stages;
|
