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