Dead
[official-gcc.git] / gomp-20050608-branch / gcc / ada / s-tassta.adb
blob38c1fca70edbd29154fd5e070bf2e458cb463f21
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-2006, 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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 pragma Polling (Off);
35 -- Turn off polling, we do not want ATC polling to take place during
36 -- tasking operations. It causes infinite loops and other problems.
38 with Ada.Exceptions;
39 -- Used for Raise_Exception
41 with System.Tasking.Debug;
42 -- Used for enabling tasking facilities with gdb
44 with System.Address_Image;
45 -- Used for the function itself
47 with System.Task_Primitives.Operations;
48 -- Used for Finalize_Lock
49 -- Enter_Task
50 -- Write_Lock
51 -- Unlock
52 -- Sleep
53 -- Wakeup
54 -- Get_Priority
55 -- Lock/Unlock_RTS
56 -- New_ATCB
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 presense of tasking, they must be replaced with pointers to
62 -- task-specific versions. Also used for Create_TSD, Destroy_TSD,
63 -- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler.
65 with System.Tasking.Initialization;
66 -- Used for Remove_From_All_Tasks_List
67 -- Defer_Abort
68 -- Undefer_Abort
69 -- Initialization.Poll_Base_Priority_Change
70 -- Finalize_Attributes_Link
71 -- Initialize_Attributes_Link
73 pragma Elaborate_All (System.Tasking.Initialization);
74 -- This insures that tasking is initialized if any tasks are created
76 with System.Tasking.Utilities;
77 -- Used for Make_Passive
78 -- Abort_One_Task
79 -- Abort_Tasks
81 with System.Tasking.Queuing;
82 -- Used for Dequeue_Head
84 with System.Tasking.Rendezvous;
85 -- Used for Call_Simple
87 with System.OS_Primitives;
88 -- Used for Delay_Modes
90 with System.Secondary_Stack;
91 -- Used for SS_Init
93 with System.Storage_Elements;
94 -- Used for Storage_Array
96 with System.Restrictions;
97 -- Used for Abort_Allowed
99 with System.Standard_Library;
100 -- Used for Exception_Trace
102 with System.Traces.Tasking;
103 -- Used for Send_Trace_Info
105 with Unchecked_Deallocation;
106 -- To recover from failure of ATCB initialization
108 with System.Stack_Usage;
110 package body System.Tasking.Stages is
112 package STPO renames System.Task_Primitives.Operations;
113 package SSL renames System.Soft_Links;
114 package SSE renames System.Storage_Elements;
115 package SST renames System.Secondary_Stack;
117 use Ada.Exceptions;
119 use Parameters;
120 use Task_Primitives;
121 use Task_Primitives.Operations;
122 use Task_Info;
124 use System.Traces;
125 use System.Traces.Tasking;
127 -----------------------
128 -- Local Subprograms --
129 -----------------------
131 procedure Free is new
132 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
134 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
135 -- This procedure outputs the task specific message for exception
136 -- tracing purposes.
138 procedure Task_Wrapper (Self_ID : Task_Id);
139 pragma Convention (C, Task_Wrapper);
140 -- This is the procedure that is called by the GNULL from the new context
141 -- when a task is created. It waits for activation and then calls the task
142 -- body procedure. When the task body procedure completes, it terminates
143 -- the task.
145 -- The Task_Wrapper's address will be provided to the underlying threads
146 -- library as the task entry point. Convention C is what makes most sense
147 -- for that purpose (Export C would make the function globally visible,
148 -- and affect the link name on which GDB depends). This will in addition
149 -- trigger an automatic stack alignment suitable for GCC's assumptions if
150 -- need be.
152 procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
153 -- Complete the calling task. This procedure must be called with
154 -- abort deferred. It should only be called by Complete_Task and
155 -- Finalizate_Global_Tasks (for the environment task).
157 procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
158 -- Complete the current master of the calling task. This procedure
159 -- must be called with abort deferred. It should only be called by
160 -- Vulnerable_Complete_Task and Complete_Master.
162 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
163 -- Signal to Self_ID's activator that Self_ID has completed activation.
164 -- This procedure must be called with abort deferred.
166 procedure Abort_Dependents (Self_ID : Task_Id);
167 -- Abort all the direct dependents of Self at its current master
168 -- nesting level, plus all of their dependents, transitively.
169 -- RTS_Lock should be locked by the caller.
171 procedure Vulnerable_Free_Task (T : Task_Id);
172 -- Recover all runtime system storage associated with the task T.
173 -- This should only be called after T has terminated and will no
174 -- longer be referenced.
176 -- For tasks created by an allocator that fails, due to an exception,
177 -- it is called from Expunge_Unactivated_Tasks.
179 -- It is also called from Unchecked_Deallocation, for objects that
180 -- are or contain tasks.
182 -- Different code is used at master completion, in Terminate_Dependents,
183 -- due to a need for tighter synchronization with the master.
185 ----------------------
186 -- Abort_Dependents --
187 ----------------------
189 procedure Abort_Dependents (Self_ID : Task_Id) is
190 C : Task_Id;
191 P : Task_Id;
193 begin
194 C := All_Tasks_List;
195 while C /= null loop
196 P := C.Common.Parent;
197 while P /= null loop
198 if P = Self_ID then
200 -- ??? C is supposed to take care of its own dependents, so
201 -- there should be no need to worry about them. Need to double
202 -- check this.
204 if C.Master_of_Task = Self_ID.Master_Within then
205 Utilities.Abort_One_Task (Self_ID, C);
206 C.Dependents_Aborted := True;
207 end if;
209 exit;
210 end if;
212 P := P.Common.Parent;
213 end loop;
215 C := C.Common.All_Tasks_Link;
216 end loop;
218 Self_ID.Dependents_Aborted := True;
219 end Abort_Dependents;
221 -----------------
222 -- Abort_Tasks --
223 -----------------
225 procedure Abort_Tasks (Tasks : Task_List) is
226 begin
227 Utilities.Abort_Tasks (Tasks);
228 end Abort_Tasks;
230 --------------------
231 -- Activate_Tasks --
232 --------------------
234 -- Note that locks of activator and activated task are both locked
235 -- here. This is necessary because C.Common.State and
236 -- Self.Common.Wait_Count have to be synchronized. This is safe from
237 -- deadlock because the activator is always created before the activated
238 -- task. That satisfies our in-order-of-creation ATCB locking policy.
240 -- At one point, we may also lock the parent, if the parent is
241 -- different from the activator. That is also consistent with the
242 -- lock ordering policy, since the activator cannot be created
243 -- before the parent.
245 -- Since we are holding both the activator's lock, and Task_Wrapper
246 -- locks that before it does anything more than initialize the
247 -- low-level ATCB components, it should be safe to wait to update
248 -- the counts until we see that the thread creation is successful.
250 -- If the thread creation fails, we do need to close the entries
251 -- of the task. The first phase, of dequeuing calls, only requires
252 -- locking the acceptor's ATCB, but the waking up of the callers
253 -- requires locking the caller's ATCB. We cannot safely do this
254 -- while we are holding other locks. Therefore, the queue-clearing
255 -- operation is done in a separate pass over the activation chain.
257 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
258 Self_ID : constant Task_Id := STPO.Self;
259 P : Task_Id;
260 C : Task_Id;
261 Next_C, Last_C : Task_Id;
262 Activate_Prio : System.Any_Priority;
263 Success : Boolean;
264 All_Elaborated : Boolean := True;
266 begin
267 -- If pragma Detect_Blocking is active, then we must check whether this
268 -- potentially blocking operation is called from a protected action.
270 if System.Tasking.Detect_Blocking
271 and then Self_ID.Common.Protected_Action_Nesting > 0
272 then
273 Ada.Exceptions.Raise_Exception
274 (Program_Error'Identity, "potentially blocking operation");
275 end if;
277 pragma Debug
278 (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
280 Initialization.Defer_Abort_Nestable (Self_ID);
282 pragma Assert (Self_ID.Common.Wait_Count = 0);
284 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
285 -- we finish activating the chain.
287 Lock_RTS;
289 -- Check that all task bodies have been elaborated
291 C := Chain_Access.T_ID;
292 Last_C := null;
293 while C /= null loop
294 if C.Common.Elaborated /= null
295 and then not C.Common.Elaborated.all
296 then
297 All_Elaborated := False;
298 end if;
300 -- Reverse the activation chain so that tasks are
301 -- activated in the same order they're declared.
303 Next_C := C.Common.Activation_Link;
304 C.Common.Activation_Link := Last_C;
305 Last_C := C;
306 C := Next_C;
307 end loop;
309 Chain_Access.T_ID := Last_C;
311 if not All_Elaborated then
312 Unlock_RTS;
313 Initialization.Undefer_Abort_Nestable (Self_ID);
314 Raise_Exception
315 (Program_Error'Identity, "Some tasks have not been elaborated");
316 end if;
318 -- Activate all the tasks in the chain. Creation of the thread of
319 -- control was deferred until activation. So create it now.
321 C := Chain_Access.T_ID;
322 while C /= null loop
323 if C.Common.State /= Terminated then
324 pragma Assert (C.Common.State = Unactivated);
326 P := C.Common.Parent;
327 Write_Lock (P);
328 Write_Lock (C);
330 if C.Common.Base_Priority < Get_Priority (Self_ID) then
331 Activate_Prio := Get_Priority (Self_ID);
332 else
333 Activate_Prio := C.Common.Base_Priority;
334 end if;
336 System.Task_Primitives.Operations.Create_Task
337 (C, Task_Wrapper'Address,
338 Parameters.Size_Type
339 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
340 Activate_Prio, Success);
342 -- There would be a race between the created task and the
343 -- creator to do the following initialization, if we did not
344 -- have a Lock/Unlock_RTS pair in the task wrapper to prevent
345 -- it from racing ahead.
347 if Success then
348 C.Common.State := Runnable;
349 C.Awake_Count := 1;
350 C.Alive_Count := 1;
351 P.Awake_Count := P.Awake_Count + 1;
352 P.Alive_Count := P.Alive_Count + 1;
354 if P.Common.State = Master_Completion_Sleep and then
355 C.Master_of_Task = P.Master_Within
356 then
357 pragma Assert (Self_ID /= P);
358 P.Common.Wait_Count := P.Common.Wait_Count + 1;
359 end if;
361 Unlock (C);
362 Unlock (P);
364 else
365 -- No need to set Awake_Count, State, etc. here since the loop
366 -- below will do that for any Unactivated tasks.
368 Unlock (C);
369 Unlock (P);
370 Self_ID.Common.Activation_Failed := True;
371 end if;
372 end if;
374 C := C.Common.Activation_Link;
375 end loop;
377 if not Single_Lock then
378 Unlock_RTS;
379 end if;
381 -- Close the entries of any tasks that failed thread creation,
382 -- and count those that have not finished activation.
384 Write_Lock (Self_ID);
385 Self_ID.Common.State := Activator_Sleep;
387 C := Chain_Access.T_ID;
388 while C /= null loop
389 Write_Lock (C);
391 if C.Common.State = Unactivated then
392 C.Common.Activator := null;
393 C.Common.State := Terminated;
394 C.Callable := False;
395 Utilities.Cancel_Queued_Entry_Calls (C);
397 elsif C.Common.Activator /= null then
398 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
399 end if;
401 Unlock (C);
402 P := C.Common.Activation_Link;
403 C.Common.Activation_Link := null;
404 C := P;
405 end loop;
407 -- Wait for the activated tasks to complete activation. It is
408 -- unsafe to abort any of these tasks until the count goes to zero.
410 loop
411 Initialization.Poll_Base_Priority_Change (Self_ID);
412 exit when Self_ID.Common.Wait_Count = 0;
413 Sleep (Self_ID, Activator_Sleep);
414 end loop;
416 Self_ID.Common.State := Runnable;
417 Unlock (Self_ID);
419 if Single_Lock then
420 Unlock_RTS;
421 end if;
423 -- Remove the tasks from the chain
425 Chain_Access.T_ID := null;
426 Initialization.Undefer_Abort_Nestable (Self_ID);
428 if Self_ID.Common.Activation_Failed then
429 Self_ID.Common.Activation_Failed := False;
430 Raise_Exception (Tasking_Error'Identity,
431 "Failure during activation");
432 end if;
433 end Activate_Tasks;
435 -------------------------
436 -- Complete_Activation --
437 -------------------------
439 procedure Complete_Activation is
440 Self_ID : constant Task_Id := STPO.Self;
442 begin
443 Initialization.Defer_Abort_Nestable (Self_ID);
445 if Single_Lock then
446 Lock_RTS;
447 end if;
449 Vulnerable_Complete_Activation (Self_ID);
451 if Single_Lock then
452 Unlock_RTS;
453 end if;
455 Initialization.Undefer_Abort_Nestable (Self_ID);
457 -- ???
458 -- Why do we need to allow for nested deferral here?
460 if Runtime_Traces then
461 Send_Trace_Info (T_Activate);
462 end if;
463 end Complete_Activation;
465 ---------------------
466 -- Complete_Master --
467 ---------------------
469 procedure Complete_Master is
470 Self_ID : constant Task_Id := STPO.Self;
471 begin
472 pragma Assert (Self_ID.Deferral_Level > 0);
473 Vulnerable_Complete_Master (Self_ID);
474 end Complete_Master;
476 -------------------
477 -- Complete_Task --
478 -------------------
480 -- See comments on Vulnerable_Complete_Task for details
482 procedure Complete_Task is
483 Self_ID : constant Task_Id := STPO.Self;
485 begin
486 pragma Assert (Self_ID.Deferral_Level > 0);
488 Vulnerable_Complete_Task (Self_ID);
490 -- All of our dependents have terminated. Never undefer abort again!
492 end Complete_Task;
494 -----------------
495 -- Create_Task --
496 -----------------
498 -- Compiler interface only. Do not call from within the RTS.
499 -- This must be called to create a new task.
501 procedure Create_Task
502 (Priority : Integer;
503 Size : System.Parameters.Size_Type;
504 Task_Info : System.Task_Info.Task_Info_Type;
505 Num_Entries : Task_Entry_Index;
506 Master : Master_Level;
507 State : Task_Procedure_Access;
508 Discriminants : System.Address;
509 Elaborated : Access_Boolean;
510 Chain : in out Activation_Chain;
511 Task_Image : String;
512 Created_Task : out Task_Id)
514 T, P : Task_Id;
515 Self_ID : constant Task_Id := STPO.Self;
516 Success : Boolean;
517 Base_Priority : System.Any_Priority;
518 Len : Natural;
520 begin
521 -- If pragma Detect_Blocking is active must be checked whether
522 -- this potentially blocking operation is called from a
523 -- protected action.
525 if System.Tasking.Detect_Blocking
526 and then Self_ID.Common.Protected_Action_Nesting > 0
527 then
528 Ada.Exceptions.Raise_Exception
529 (Program_Error'Identity, "potentially blocking operation");
530 end if;
532 pragma Debug
533 (Debug.Trace (Self_ID, "Create_Task", 'C'));
535 if Priority = Unspecified_Priority then
536 Base_Priority := Self_ID.Common.Base_Priority;
537 else
538 Base_Priority := System.Any_Priority (Priority);
539 end if;
541 -- Find parent P of new Task, via master level number
543 P := Self_ID;
545 if P /= null then
546 while P.Master_of_Task >= Master loop
547 P := P.Common.Parent;
548 exit when P = null;
549 end loop;
550 end if;
552 Initialization.Defer_Abort_Nestable (Self_ID);
554 begin
555 T := New_ATCB (Num_Entries);
556 exception
557 when others =>
558 Initialization.Undefer_Abort_Nestable (Self_ID);
559 Raise_Exception (Storage_Error'Identity, "Cannot allocate task");
560 end;
562 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks.
563 -- Up to this point, it is possible that we may be part of
564 -- a family of tasks that is being aborted.
566 Lock_RTS;
567 Write_Lock (Self_ID);
569 -- Now, we must check that we have not been aborted.
570 -- If so, we should give up on creating this task,
571 -- and simply return.
573 if not Self_ID.Callable then
574 pragma Assert (Self_ID.Pending_ATC_Level = 0);
575 pragma Assert (Self_ID.Pending_Action);
576 pragma Assert
577 (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
579 Unlock (Self_ID);
580 Unlock_RTS;
581 Initialization.Undefer_Abort_Nestable (Self_ID);
583 -- ??? Should never get here
585 pragma Assert (False);
586 raise Standard'Abort_Signal;
587 end if;
589 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
590 Base_Priority, Task_Info, Size, T, Success);
592 if not Success then
593 Free (T);
594 Unlock (Self_ID);
595 Unlock_RTS;
596 Initialization.Undefer_Abort_Nestable (Self_ID);
597 Raise_Exception
598 (Storage_Error'Identity, "Failed to initialize task");
599 end if;
601 T.Master_of_Task := Master;
602 T.Master_Within := T.Master_of_Task + 1;
604 for L in T.Entry_Calls'Range loop
605 T.Entry_Calls (L).Self := T;
606 T.Entry_Calls (L).Level := L;
607 end loop;
609 if Task_Image'Length = 0 then
610 T.Common.Task_Image_Len := 0;
611 else
612 Len := 1;
613 T.Common.Task_Image (1) := Task_Image (Task_Image'First);
615 -- Remove unwanted blank space generated by 'Image
617 for J in Task_Image'First + 1 .. Task_Image'Last loop
618 if Task_Image (J) /= ' '
619 or else Task_Image (J - 1) /= '('
620 then
621 Len := Len + 1;
622 T.Common.Task_Image (Len) := Task_Image (J);
623 exit when Len = T.Common.Task_Image'Last;
624 end if;
625 end loop;
627 T.Common.Task_Image_Len := Len;
628 end if;
630 Unlock (Self_ID);
631 Unlock_RTS;
633 -- Create TSD as early as possible in the creation of a task, since it
634 -- may be used by the operation of Ada code within the task.
636 SSL.Create_TSD (T.Common.Compiler_Data);
637 T.Common.Activation_Link := Chain.T_ID;
638 Chain.T_ID := T;
639 Initialization.Initialize_Attributes_Link.all (T);
640 Created_Task := T;
641 Initialization.Undefer_Abort_Nestable (Self_ID);
643 if Runtime_Traces then
644 Send_Trace_Info (T_Create, T);
645 end if;
646 end Create_Task;
648 --------------------
649 -- Current_Master --
650 --------------------
652 function Current_Master return Master_Level is
653 begin
654 return STPO.Self.Master_Within;
655 end Current_Master;
657 ------------------
658 -- Enter_Master --
659 ------------------
661 procedure Enter_Master is
662 Self_ID : constant Task_Id := STPO.Self;
663 begin
664 Self_ID.Master_Within := Self_ID.Master_Within + 1;
665 end Enter_Master;
667 -------------------------------
668 -- Expunge_Unactivated_Tasks --
669 -------------------------------
671 -- See procedure Close_Entries for the general case
673 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
674 Self_ID : constant Task_Id := STPO.Self;
675 C : Task_Id;
676 Call : Entry_Call_Link;
677 Temp : Task_Id;
679 begin
680 pragma Debug
681 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
683 Initialization.Defer_Abort_Nestable (Self_ID);
685 -- ???
686 -- Experimentation has shown that abort is sometimes (but not
687 -- always) already deferred when this is called.
689 -- That may indicate an error. Find out what is going on
691 C := Chain.T_ID;
692 while C /= null loop
693 pragma Assert (C.Common.State = Unactivated);
695 Temp := C.Common.Activation_Link;
697 if C.Common.State = Unactivated then
698 Lock_RTS;
699 Write_Lock (C);
701 for J in 1 .. C.Entry_Num loop
702 Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
703 pragma Assert (Call = null);
704 end loop;
706 Unlock (C);
708 Initialization.Remove_From_All_Tasks_List (C);
709 Unlock_RTS;
711 Vulnerable_Free_Task (C);
712 C := Temp;
713 end if;
714 end loop;
716 Chain.T_ID := null;
717 Initialization.Undefer_Abort_Nestable (Self_ID);
718 end Expunge_Unactivated_Tasks;
720 ---------------------------
721 -- Finalize_Global_Tasks --
722 ---------------------------
724 -- ???
725 -- We have a potential problem here if finalization of global
726 -- objects does anything with signals or the timer server, since
727 -- by that time those servers have terminated.
729 -- It is hard to see how that would occur
731 -- However, a better solution might be to do all this finalization
732 -- using the global finalization chain.
734 procedure Finalize_Global_Tasks is
735 Self_ID : constant Task_Id := STPO.Self;
736 Ignore : Boolean;
738 begin
739 if Self_ID.Deferral_Level = 0 then
740 -- ???
741 -- In principle, we should be able to predict whether
742 -- abort is already deferred here (and it should not be deferred
743 -- yet but in practice it seems Finalize_Global_Tasks is being
744 -- called sometimes, from RTS code for exceptions, with abort already
745 -- deferred.
747 Initialization.Defer_Abort_Nestable (Self_ID);
749 -- Never undefer again!!!
750 end if;
752 -- This code is only executed by the environment task
754 pragma Assert (Self_ID = Environment_Task);
756 -- Set Environment_Task'Callable to false to notify library-level tasks
757 -- that it is waiting for them (cf 5619-003).
759 Self_ID.Callable := False;
761 -- Exit level 2 master, for normal tasks in library-level packages
763 Complete_Master;
765 -- Force termination of "independent" library-level server tasks
767 Lock_RTS;
769 Abort_Dependents (Self_ID);
771 if not Single_Lock then
772 Unlock_RTS;
773 end if;
775 -- We need to explicitely wait for the task to be terminated here
776 -- because on true concurrent system, we may end this procedure
777 -- before the tasks are really terminated.
779 Write_Lock (Self_ID);
781 loop
782 exit when Utilities.Independent_Task_Count = 0;
784 -- We used to yield here, but this did not take into account
785 -- low priority tasks that would cause dead lock in some cases.
786 -- See 8126-020.
788 Timed_Sleep
789 (Self_ID, 0.01, System.OS_Primitives.Relative,
790 Self_ID.Common.State, Ignore, Ignore);
791 end loop;
793 -- ??? On multi-processor environments, it seems that the above loop
794 -- isn't sufficient, so we need to add an additional delay.
796 Timed_Sleep
797 (Self_ID, 0.01, System.OS_Primitives.Relative,
798 Self_ID.Common.State, Ignore, Ignore);
800 Unlock (Self_ID);
802 if Single_Lock then
803 Unlock_RTS;
804 end if;
806 -- Complete the environment task
808 Vulnerable_Complete_Task (Self_ID);
810 -- Handle normal task termination by the environment task, but only
811 -- for the normal task termination. In the case of Abnormal and
812 -- Unhandled_Exception they must have been handled before, and the
813 -- task termination soft link must have been changed so the task
814 -- termination routine is not executed twice.
816 SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
818 -- Finalize the global list for controlled objects if needed
820 SSL.Finalize_Global_List.all;
822 -- Reset the soft links to non-tasking
824 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
825 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
826 SSL.Lock_Task := SSL.Task_Lock_NT'Access;
827 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access;
828 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
829 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
830 SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access;
831 SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access;
832 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
833 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
835 -- Don't bother trying to finalize Initialization.Global_Task_Lock
836 -- and System.Task_Primitives.RTS_Lock.
838 end Finalize_Global_Tasks;
840 ---------------
841 -- Free_Task --
842 ---------------
844 procedure Free_Task (T : Task_Id) is
845 Self_Id : constant Task_Id := Self;
847 begin
848 if T.Common.State = Terminated then
850 -- It is not safe to call Abort_Defer or Write_Lock at this stage
852 Initialization.Task_Lock (Self_Id);
854 Lock_RTS;
855 Initialization.Remove_From_All_Tasks_List (T);
856 Unlock_RTS;
858 Initialization.Task_Unlock (Self_Id);
860 System.Task_Primitives.Operations.Finalize_TCB (T);
862 -- If the task is not terminated, then we simply ignore the call. This
863 -- happens when a user program attempts an unchecked deallocation on
864 -- a non-terminated task.
866 else
867 null;
868 end if;
869 end Free_Task;
871 ------------------
872 -- Task_Wrapper --
873 ------------------
875 -- The task wrapper is a procedure that is called first for each task
876 -- task body, and which in turn calls the compiler-generated task body
877 -- procedure. The wrapper's main job is to do initialization for the task.
878 -- It also has some locally declared objects that server as per-task local
879 -- data. Task finalization is done by Complete_Task, which is called from
880 -- an at-end handler that the compiler generates.
882 procedure Task_Wrapper (Self_ID : Task_Id) is
883 use type System.Parameters.Size_Type;
884 use type SSE.Storage_Offset;
885 use System.Standard_Library;
886 use System.Stack_Usage;
888 Bottom_Of_Stack : aliased Integer;
890 Secondary_Stack_Size :
891 constant SSE.Storage_Offset :=
892 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
893 SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100;
895 Secondary_Stack :
896 aliased SSE.Storage_Array
897 (1 .. Secondary_Stack_Size);
899 pragma Warnings (Off);
900 Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
902 Small_Overflow_Guard : constant := 4 * 1024;
903 Big_Overflow_Guard : constant := 16 * 1024;
904 Small_Stack_Limit : constant := 64 * 1024;
905 -- ??? These three values are experimental, and seems to work on most
906 -- platforms. They still need to be analyzed further.
908 Size :
909 Natural := Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size);
911 pragma Warnings (On);
912 -- Address of secondary stack. In the fixed secondary stack case, this
913 -- value is not modified, causing a warning, hence the bracketing with
914 -- Warnings (Off/On).
916 SEH_Table : aliased SSE.Storage_Array (1 .. 8);
917 -- Structured Exception Registration table (2 words)
919 procedure Install_SEH_Handler (Addr : System.Address);
920 pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
921 -- Install the SEH (Structured Exception Handling) handler
923 Cause : Cause_Of_Termination := Normal;
924 -- Indicates the reason why this task terminates. Normal corresponds to
925 -- a task terminating due to completing the last statement of its body,
926 -- or as a result of waiting on a terminate alternative. If the task
927 -- terminates because it is being aborted then Cause will be set to
928 -- Abnormal. If the task terminates because of an exception raised by
929 -- the execution of its task body, then Cause is set to
930 -- Unhandled_Exception.
932 EO : Exception_Occurrence;
933 -- If the task terminates because of an exception raised by the
934 -- execution of its task body, then EO will contain the associated
935 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
937 TH : Termination_Handler := null;
938 -- Pointer to the protected procedure to be executed upon task
939 -- termination.
941 procedure Search_Fall_Back_Handler (ID : Task_Id);
942 -- Procedure that searches recursively a fall-back handler through the
943 -- master relationship. If the handler is found, its pointer is stored
944 -- in TH.
946 procedure Search_Fall_Back_Handler (ID : Task_Id) is
947 begin
948 -- If there is a fall back handler, store its pointer for later
949 -- execution.
951 if ID.Common.Fall_Back_Handler /= null then
952 TH := ID.Common.Fall_Back_Handler;
954 -- Otherwise look for a fall back handler in the parent
956 elsif ID.Common.Parent /= null then
957 Search_Fall_Back_Handler (ID.Common.Parent);
959 -- Otherwise, do nothing
961 else
962 return;
963 end if;
964 end Search_Fall_Back_Handler;
966 begin
967 pragma Assert (Self_ID.Deferral_Level = 1);
969 -- Assume a size of the stack taken at this stage
971 if Size < Small_Stack_Limit then
972 Size := Size - Small_Overflow_Guard;
973 else
974 Size := Size - Big_Overflow_Guard;
975 end if;
977 if not Parameters.Sec_Stack_Dynamic then
978 Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
979 Secondary_Stack'Address;
980 SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
981 Size := Size - Natural (Secondary_Stack_Size);
982 end if;
984 if System.Stack_Usage.Is_Enabled then
985 STPO.Lock_RTS;
986 Initialize_Analyzer (Self_ID.Common.Analyzer,
987 Self_ID.Common.Task_Image
988 (1 .. Self_ID.Common.Task_Image_Len),
989 Size,
990 SSE.To_Integer (Bottom_Of_Stack'Address));
991 STPO.Unlock_RTS;
992 Fill_Stack (Self_ID.Common.Analyzer);
993 end if;
995 -- Set the guard page at the bottom of the stack. The call to unprotect
996 -- the page is done in Terminate_Task
998 Stack_Guard (Self_ID, True);
1000 -- Initialize low-level TCB components, that cannot be initialized
1001 -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and
1002 -- also Self_ID.LL.Thread
1004 Enter_Task (Self_ID);
1006 -- We setup the SEH (Structured Exception Handling) handler if supported
1007 -- on the target.
1009 Install_SEH_Handler (SEH_Table'Address);
1011 -- Initialize exception occurrence
1013 Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
1015 -- We lock RTS_Lock to wait for activator to finish activating the rest
1016 -- of the chain, so that everyone in the chain comes out in priority
1017 -- order.
1019 -- This also protects the value of
1020 -- Self_ID.Common.Activator.Common.Wait_Count.
1022 Lock_RTS;
1023 Unlock_RTS;
1025 if not System.Restrictions.Abort_Allowed then
1027 -- If Abort is not allowed, reset the deferral level since it will
1028 -- not get changed by the generated code. Keeping a default value
1029 -- of one would prevent some operations (e.g. select or delay) to
1030 -- proceed successfully.
1032 Self_ID.Deferral_Level := 0;
1033 end if;
1035 begin
1036 -- We are separating the following portion of the code in order to
1037 -- place the exception handlers in a different block. In this way,
1038 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
1039 -- set Self in Enter_Task
1041 -- Call the task body procedure
1043 -- The task body is called with abort still deferred. That
1044 -- eliminates a dangerous window, for which we had to patch-up in
1045 -- Terminate_Task.
1047 -- During the expansion of the task body, we insert an RTS-call
1048 -- to Abort_Undefer, at the first point where abort should be
1049 -- allowed.
1051 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
1052 Initialization.Defer_Abort_Nestable (Self_ID);
1054 exception
1055 -- We can't call Terminate_Task in the exception handlers below,
1056 -- since there may be (e.g. in the case of GCC exception handling)
1057 -- clean ups associated with the exception handler that need to
1058 -- access task specific data.
1060 -- Defer abort so that this task can't be aborted while exiting
1062 when Standard'Abort_Signal =>
1063 Initialization.Defer_Abort_Nestable (Self_ID);
1065 -- Update the cause that motivated the task termination so that
1066 -- the appropriate information is passed to the task termination
1067 -- procedure. Task termination as a result of waiting on a
1068 -- terminate alternative is a normal termination, although it is
1069 -- implemented using the abort mechanisms.
1071 if Self_ID.Terminate_Alternative then
1072 Cause := Normal;
1073 else
1074 Cause := Abnormal;
1075 end if;
1076 when others =>
1077 -- ??? Using an E : others here causes CD2C11A to fail on
1078 -- DEC Unix, see 7925-005.
1080 Initialization.Defer_Abort_Nestable (Self_ID);
1082 -- Perform the task specific exception tracing duty. We handle
1083 -- these outputs here and not in the common notification routine
1084 -- because we need access to tasking related data and we don't
1085 -- want to drag dependencies against tasking related units in the
1086 -- the common notification units. Additionally, no trace is ever
1087 -- triggered from the common routine for the Unhandled_Raise case
1088 -- in tasks, since an exception never appears unhandled in this
1089 -- context because of this handler.
1091 if Exception_Trace = Unhandled_Raise then
1092 Trace_Unhandled_Exception_In_Task (Self_ID);
1093 end if;
1095 -- Update the cause that motivated the task termination so that
1096 -- the appropriate information is passed to the task termination
1097 -- procedure, as well as the associated Exception_Occurrence.
1099 Cause := Unhandled_Exception;
1100 Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
1101 end;
1103 -- Look for a task termination handler. This code is for all tasks but
1104 -- the environment task. The task termination code for the environment
1105 -- task is executed by SSL.Task_Termination_Handler.
1107 if Single_Lock then
1108 Lock_RTS;
1109 end if;
1111 Write_Lock (Self_ID);
1113 if Self_ID.Common.Specific_Handler /= null then
1114 TH := Self_ID.Common.Specific_Handler;
1115 else
1116 -- Look for a fall-back handler following the master relationship
1117 -- for the task.
1119 Search_Fall_Back_Handler (Self_ID);
1120 end if;
1122 Unlock (Self_ID);
1124 if Single_Lock then
1125 Unlock_RTS;
1126 end if;
1128 -- Execute the task termination handler if we found it
1130 if TH /= null then
1131 TH.all (Cause, Self_ID, EO);
1132 end if;
1134 if System.Stack_Usage.Is_Enabled then
1135 Compute_Result (Self_ID.Common.Analyzer);
1136 Report_Result (Self_ID.Common.Analyzer);
1137 end if;
1139 Terminate_Task (Self_ID);
1140 end Task_Wrapper;
1142 --------------------
1143 -- Terminate_Task --
1144 --------------------
1146 -- Before we allow the thread to exit, we must clean up. This is a
1147 -- a delicate job. We must wake up the task's master, who may immediately
1148 -- try to deallocate the ATCB out from under the current task WHILE IT IS
1149 -- STILL EXECUTING.
1151 -- To avoid this, the parent task must be blocked up to the latest
1152 -- statement executed. The trouble is that we have another step that we
1153 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1154 -- We have to postpone that until the end because compiler-generated code
1155 -- is likely to try to access that data at just about any point.
1157 -- We can't call Destroy_TSD while we are holding any other locks, because
1158 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1159 -- that to be the outermost lock. Our first "solution" was to just lock
1160 -- Global_Task_Lock in addition to the other locks, and force the parent to
1161 -- also lock this lock between its wakeup and its freeing of the ATCB. See
1162 -- Complete_Task for the parent-side of the code that has the matching
1163 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1164 -- since the operation Task_Unlock continued to access the ATCB after
1165 -- unlocking, after which the parent was observed to race ahead, deallocate
1166 -- the ATCB, and then reallocate it to another task. The call to
1167 -- Undefer_Abortion in Task_Unlock by the "terminated" task was overwriting
1168 -- the data of the new task that reused the ATCB! To solve this problem, we
1169 -- introduced the new operation Final_Task_Unlock.
1171 procedure Terminate_Task (Self_ID : Task_Id) is
1172 Environment_Task : constant Task_Id := STPO.Environment_Task;
1173 Master_of_Task : Integer;
1175 begin
1176 Debug.Task_Termination_Hook;
1178 if Runtime_Traces then
1179 Send_Trace_Info (T_Terminate);
1180 end if;
1182 -- Since GCC cannot allocate stack chunks efficiently without reordering
1183 -- some of the allocations, we have to handle this unexpected situation
1184 -- here. We should normally never have to call Vulnerable_Complete_Task
1185 -- here. See 6602-003 for more details.
1187 if Self_ID.Common.Activator /= null then
1188 Vulnerable_Complete_Task (Self_ID);
1189 end if;
1191 Initialization.Task_Lock (Self_ID);
1193 if Single_Lock then
1194 Lock_RTS;
1195 end if;
1197 Master_of_Task := Self_ID.Master_of_Task;
1199 -- Check if the current task is an independent task If so, decrement
1200 -- the Independent_Task_Count value.
1202 if Master_of_Task = 2 then
1203 if Single_Lock then
1204 Utilities.Independent_Task_Count :=
1205 Utilities.Independent_Task_Count - 1;
1206 else
1207 Write_Lock (Environment_Task);
1208 Utilities.Independent_Task_Count :=
1209 Utilities.Independent_Task_Count - 1;
1210 Unlock (Environment_Task);
1211 end if;
1212 end if;
1214 -- Unprotect the guard page if needed
1216 Stack_Guard (Self_ID, False);
1218 Utilities.Make_Passive (Self_ID, Task_Completed => True);
1220 if Single_Lock then
1221 Unlock_RTS;
1222 end if;
1224 pragma Assert (Check_Exit (Self_ID));
1226 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
1227 Initialization.Final_Task_Unlock (Self_ID);
1229 -- WARNING: past this point, this thread must assume that the ATCB
1230 -- has been deallocated. It should not be accessed again.
1232 if Master_of_Task > 0 then
1233 STPO.Exit_Task;
1234 end if;
1235 end Terminate_Task;
1237 ----------------
1238 -- Terminated --
1239 ----------------
1241 function Terminated (T : Task_Id) return Boolean is
1242 Self_ID : constant Task_Id := STPO.Self;
1243 Result : Boolean;
1245 begin
1246 Initialization.Defer_Abort_Nestable (Self_ID);
1248 if Single_Lock then
1249 Lock_RTS;
1250 end if;
1252 Write_Lock (T);
1253 Result := T.Common.State = Terminated;
1254 Unlock (T);
1256 if Single_Lock then
1257 Unlock_RTS;
1258 end if;
1260 Initialization.Undefer_Abort_Nestable (Self_ID);
1261 return Result;
1262 end Terminated;
1264 ----------------------------------------
1265 -- Trace_Unhandled_Exception_In_Task --
1266 ----------------------------------------
1268 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
1269 procedure To_Stderr (S : String);
1270 pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
1272 use System.Soft_Links;
1273 use System.Standard_Library;
1275 function To_Address is new
1276 Unchecked_Conversion (Task_Id, System.Address);
1278 function Tailored_Exception_Information
1279 (E : Exception_Occurrence) return String;
1280 pragma Import
1281 (Ada, Tailored_Exception_Information,
1282 "__gnat_tailored_exception_information");
1284 Excep : constant Exception_Occurrence_Access :=
1285 SSL.Get_Current_Excep.all;
1287 begin
1288 -- This procedure is called by the task outermost handler in
1289 -- Task_Wrapper below, so only once the task stack has been fully
1290 -- unwound. The common notification routine has been called at the
1291 -- raise point already.
1293 To_Stderr ("task ");
1295 if Self_Id.Common.Task_Image_Len /= 0 then
1296 To_Stderr
1297 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
1298 To_Stderr ("_");
1299 end if;
1301 To_Stderr (System.Address_Image (To_Address (Self_Id)));
1302 To_Stderr (" terminated by unhandled exception");
1303 To_Stderr ((1 => ASCII.LF));
1304 To_Stderr (Tailored_Exception_Information (Excep.all));
1305 end Trace_Unhandled_Exception_In_Task;
1307 ------------------------------------
1308 -- Vulnerable_Complete_Activation --
1309 ------------------------------------
1311 -- As in several other places, the locks of the activator and activated
1312 -- task are both locked here. This follows our deadlock prevention lock
1313 -- ordering policy, since the activated task must be created after the
1314 -- activator.
1316 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
1317 Activator : constant Task_Id := Self_ID.Common.Activator;
1319 begin
1320 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
1322 Write_Lock (Activator);
1323 Write_Lock (Self_ID);
1325 pragma Assert (Self_ID.Common.Activator /= null);
1327 -- Remove dangling reference to Activator, since a task may
1328 -- outlive its activator.
1330 Self_ID.Common.Activator := null;
1332 -- Wake up the activator, if it is waiting for a chain of tasks to
1333 -- activate, and we are the last in the chain to complete activation.
1335 if Activator.Common.State = Activator_Sleep then
1336 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
1338 if Activator.Common.Wait_Count = 0 then
1339 Wakeup (Activator, Activator_Sleep);
1340 end if;
1341 end if;
1343 -- The activator raises a Tasking_Error if any task it is activating
1344 -- is completed before the activation is done. However, if the reason
1345 -- for the task completion is an abort, we do not raise an exception.
1346 -- See RM 9.2(5).
1348 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
1349 Activator.Common.Activation_Failed := True;
1350 end if;
1352 Unlock (Self_ID);
1353 Unlock (Activator);
1355 -- After the activation, active priority should be the same
1356 -- as base priority. We must unlock the Activator first,
1357 -- though, since it should not wait if we have lower priority.
1359 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
1360 Write_Lock (Self_ID);
1361 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1362 Unlock (Self_ID);
1363 end if;
1364 end Vulnerable_Complete_Activation;
1366 --------------------------------
1367 -- Vulnerable_Complete_Master --
1368 --------------------------------
1370 procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
1371 C : Task_Id;
1372 P : Task_Id;
1373 CM : constant Master_Level := Self_ID.Master_Within;
1374 T : aliased Task_Id;
1376 To_Be_Freed : Task_Id;
1377 -- This is a list of ATCBs to be freed, after we have released
1378 -- all RTS locks. This is necessary because of the locking order
1379 -- rules, since the storage manager uses Global_Task_Lock.
1381 pragma Warnings (Off);
1382 function Check_Unactivated_Tasks return Boolean;
1383 pragma Warnings (On);
1384 -- Temporary error-checking code below. This is part of the checks
1385 -- added in the new run time. Call it only inside a pragma Assert.
1387 -----------------------------
1388 -- Check_Unactivated_Tasks --
1389 -----------------------------
1391 function Check_Unactivated_Tasks return Boolean is
1392 begin
1393 if not Single_Lock then
1394 Lock_RTS;
1395 end if;
1397 Write_Lock (Self_ID);
1399 C := All_Tasks_List;
1400 while C /= null loop
1401 if C.Common.Activator = Self_ID then
1402 return False;
1403 end if;
1405 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1406 Write_Lock (C);
1408 if C.Common.State = Unactivated then
1409 return False;
1410 end if;
1412 Unlock (C);
1413 end if;
1415 C := C.Common.All_Tasks_Link;
1416 end loop;
1418 Unlock (Self_ID);
1420 if not Single_Lock then
1421 Unlock_RTS;
1422 end if;
1424 return True;
1425 end Check_Unactivated_Tasks;
1427 -- Start of processing for Vulnerable_Complete_Master
1429 begin
1430 pragma Debug
1431 (Debug.Trace (Self_ID, "V_Complete_Master", 'C'));
1433 pragma Assert (Self_ID.Common.Wait_Count = 0);
1434 pragma Assert (Self_ID.Deferral_Level > 0);
1436 -- Count how many active dependent tasks this master currently
1437 -- has, and record this in Wait_Count.
1439 -- This count should start at zero, since it is initialized to
1440 -- zero for new tasks, and the task should not exit the
1441 -- sleep-loops that use this count until the count reaches zero.
1443 Lock_RTS;
1444 Write_Lock (Self_ID);
1446 C := All_Tasks_List;
1447 while C /= null loop
1448 if C.Common.Activator = Self_ID then
1449 pragma Assert (C.Common.State = Unactivated);
1451 Write_Lock (C);
1452 C.Common.Activator := null;
1453 C.Common.State := Terminated;
1454 C.Callable := False;
1455 Utilities.Cancel_Queued_Entry_Calls (C);
1456 Unlock (C);
1457 end if;
1459 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1460 Write_Lock (C);
1462 if C.Awake_Count /= 0 then
1463 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1464 end if;
1466 Unlock (C);
1467 end if;
1469 C := C.Common.All_Tasks_Link;
1470 end loop;
1472 Self_ID.Common.State := Master_Completion_Sleep;
1473 Unlock (Self_ID);
1475 if not Single_Lock then
1476 Unlock_RTS;
1477 end if;
1479 -- Wait until dependent tasks are all terminated or ready to terminate.
1480 -- While waiting, the task may be awakened if the task's priority needs
1481 -- changing, or this master is aborted. In the latter case, we want
1482 -- to abort the dependents, and resume waiting until Wait_Count goes
1483 -- to zero.
1485 Write_Lock (Self_ID);
1487 loop
1488 Initialization.Poll_Base_Priority_Change (Self_ID);
1489 exit when Self_ID.Common.Wait_Count = 0;
1491 -- Here is a difference as compared to Complete_Master
1493 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1494 and then not Self_ID.Dependents_Aborted
1495 then
1496 if Single_Lock then
1497 Abort_Dependents (Self_ID);
1498 else
1499 Unlock (Self_ID);
1500 Lock_RTS;
1501 Abort_Dependents (Self_ID);
1502 Unlock_RTS;
1503 Write_Lock (Self_ID);
1504 end if;
1505 else
1506 Sleep (Self_ID, Master_Completion_Sleep);
1507 end if;
1508 end loop;
1510 Self_ID.Common.State := Runnable;
1511 Unlock (Self_ID);
1513 -- Dependents are all terminated or on terminate alternatives.
1514 -- Now, force those on terminate alternatives to terminate, by
1515 -- aborting them.
1517 pragma Assert (Check_Unactivated_Tasks);
1519 if Self_ID.Alive_Count > 1 then
1520 -- ???
1521 -- Consider finding a way to skip the following extra steps if there
1522 -- are no dependents with terminate alternatives. This could be done
1523 -- by adding another count to the ATCB, similar to Awake_Count, but
1524 -- keeping track of tasks that are on terminate alternatives.
1526 pragma Assert (Self_ID.Common.Wait_Count = 0);
1528 -- Force any remaining dependents to terminate by aborting them
1530 if not Single_Lock then
1531 Lock_RTS;
1532 end if;
1534 Abort_Dependents (Self_ID);
1536 -- Above, when we "abort" the dependents we are simply using this
1537 -- operation for convenience. We are not required to support the full
1538 -- abort-statement semantics; in particular, we are not required to
1539 -- immediately cancel any queued or in-service entry calls. That is
1540 -- good, because if we tried to cancel a call we would need to lock
1541 -- the caller, in order to wake the caller up. Our anti-deadlock
1542 -- rules prevent us from doing that without releasing the locks on C
1543 -- and Self_ID. Releasing and retaking those locks would be wasteful
1544 -- at best, and should not be considered further without more
1545 -- detailed analysis of potential concurrent accesses to the
1546 -- ATCBs of C and Self_ID.
1548 -- Count how many "alive" dependent tasks this master currently
1549 -- has, and record this in Wait_Count. This count should start at
1550 -- zero, since it is initialized to zero for new tasks, and the
1551 -- task should not exit the sleep-loops that use this count until
1552 -- the count reaches zero.
1554 pragma Assert (Self_ID.Common.Wait_Count = 0);
1556 Write_Lock (Self_ID);
1558 C := All_Tasks_List;
1559 while C /= null loop
1560 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1561 Write_Lock (C);
1563 pragma Assert (C.Awake_Count = 0);
1565 if C.Alive_Count > 0 then
1566 pragma Assert (C.Terminate_Alternative);
1567 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1568 end if;
1570 Unlock (C);
1571 end if;
1573 C := C.Common.All_Tasks_Link;
1574 end loop;
1576 Self_ID.Common.State := Master_Phase_2_Sleep;
1577 Unlock (Self_ID);
1579 if not Single_Lock then
1580 Unlock_RTS;
1581 end if;
1583 -- Wait for all counted tasks to finish terminating themselves
1585 Write_Lock (Self_ID);
1587 loop
1588 Initialization.Poll_Base_Priority_Change (Self_ID);
1589 exit when Self_ID.Common.Wait_Count = 0;
1590 Sleep (Self_ID, Master_Phase_2_Sleep);
1591 end loop;
1593 Self_ID.Common.State := Runnable;
1594 Unlock (Self_ID);
1595 end if;
1597 -- We don't wake up for abort here. We are already terminating just as
1598 -- fast as we can, so there is no point.
1600 -- Remove terminated tasks from the list of Self_ID's dependents, but
1601 -- don't free their ATCBs yet, because of lock order restrictions,
1602 -- which don't allow us to call "free" or "malloc" while holding any
1603 -- other locks. Instead, we put those ATCBs to be freed onto a
1604 -- temporary list, called To_Be_Freed.
1606 if not Single_Lock then
1607 Lock_RTS;
1608 end if;
1610 C := All_Tasks_List;
1611 P := null;
1612 while C /= null loop
1613 if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then
1614 if P /= null then
1615 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
1616 else
1617 All_Tasks_List := C.Common.All_Tasks_Link;
1618 end if;
1620 T := C.Common.All_Tasks_Link;
1621 C.Common.All_Tasks_Link := To_Be_Freed;
1622 To_Be_Freed := C;
1623 C := T;
1625 else
1626 P := C;
1627 C := C.Common.All_Tasks_Link;
1628 end if;
1629 end loop;
1631 Unlock_RTS;
1633 -- Free all the ATCBs on the list To_Be_Freed
1635 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1636 -- any interrupt entries are detached from them they should no longer
1637 -- be referenced.
1639 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1640 -- avoid a race between a terminating task and its parent. The parent
1641 -- might try to deallocate the ACTB out from underneath the exiting
1642 -- task. Note that Free will also lock Global_Task_Lock, but that is
1643 -- OK, since this is the *one* lock for which we have a mechanism to
1644 -- support nested locking. See Task_Wrapper and its finalizer for more
1645 -- explanation.
1647 -- ???
1648 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1649 -- references to terminated library-level tasks, which could
1650 -- otherwise occur during finalization of library-level objects.
1651 -- A better solution might be to hook task objects into the
1652 -- finalization chain and deallocate the ATCB when the task
1653 -- object is deallocated. However, this change is not likely
1654 -- to gain anything significant, since all this storage should
1655 -- be recovered en-masse when the process exits.
1657 while To_Be_Freed /= null loop
1658 T := To_Be_Freed;
1659 To_Be_Freed := T.Common.All_Tasks_Link;
1661 -- ??? On SGI there is currently no Interrupt_Manager, that's
1662 -- why we need to check if the Interrupt_Manager_ID is null
1664 if T.Interrupt_Entry and Interrupt_Manager_ID /= null then
1665 declare
1666 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
1667 -- Corresponds to the entry index of System.Interrupts.
1668 -- Interrupt_Manager.Detach_Interrupt_Entries.
1669 -- Be sure to update this value when changing
1670 -- Interrupt_Manager specs.
1672 type Param_Type is access all Task_Id;
1674 Param : aliased Param_Type := T'Access;
1676 begin
1677 System.Tasking.Rendezvous.Call_Simple
1678 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
1679 Param'Address);
1680 end;
1681 end if;
1683 if (T.Common.Parent /= null
1684 and then T.Common.Parent.Common.Parent /= null)
1685 or else T.Master_of_Task > 3
1686 then
1687 Initialization.Task_Lock (Self_ID);
1689 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1690 -- has not been called yet (case of an unactivated task).
1692 if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then
1693 SSL.Destroy_TSD (T.Common.Compiler_Data);
1694 end if;
1696 Vulnerable_Free_Task (T);
1697 Initialization.Task_Unlock (Self_ID);
1698 end if;
1699 end loop;
1701 -- It might seem nice to let the terminated task deallocate its own
1702 -- ATCB. That would not cover the case of unactivated tasks. It also
1703 -- would force us to keep the underlying thread around past termination,
1704 -- since references to the ATCB are possible past termination.
1705 -- Currently, we get rid of the thread as soon as the task terminates,
1706 -- and let the parent recover the ATCB later.
1708 -- Some day, if we want to recover the ATCB earlier, at task
1709 -- termination, we could consider using "fat task IDs", that include the
1710 -- serial number with the ATCB pointer, to catch references to tasks
1711 -- that no longer have ATCBs. It is not clear how much this would gain,
1712 -- since the user-level task object would still be occupying storage.
1714 -- Make next master level up active.
1715 -- We don't need to lock the ATCB, since the value is only updated by
1716 -- each task for itself.
1718 Self_ID.Master_Within := CM - 1;
1719 end Vulnerable_Complete_Master;
1721 ------------------------------
1722 -- Vulnerable_Complete_Task --
1723 ------------------------------
1725 -- Complete the calling task
1727 -- This procedure must be called with abort deferred. (That's why the
1728 -- name has "Vulnerable" in it.) It should only be called by Complete_Task
1729 -- and Finalize_Global_Tasks (for the environment task).
1731 -- The effect is similar to that of Complete_Master. Differences include
1732 -- the closing of entries here, and computation of the number of active
1733 -- dependent tasks in Complete_Master.
1735 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1736 -- because that does its own locking, and because we do not need the lock
1737 -- to test Self_ID.Common.Activator. That value should only be read and
1738 -- modified by Self.
1740 procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
1741 begin
1742 pragma Assert (Self_ID.Deferral_Level > 0);
1743 pragma Assert (Self_ID = Self);
1744 pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1
1745 or else
1746 Self_ID.Master_Within = Self_ID.Master_of_Task + 2);
1747 pragma Assert (Self_ID.Common.Wait_Count = 0);
1748 pragma Assert (Self_ID.Open_Accepts = null);
1749 pragma Assert (Self_ID.ATC_Nesting_Level = 1);
1751 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
1753 if Single_Lock then
1754 Lock_RTS;
1755 end if;
1757 Write_Lock (Self_ID);
1758 Self_ID.Callable := False;
1760 -- In theory, Self should have no pending entry calls left on its
1761 -- call-stack. Each async. select statement should clean its own call,
1762 -- and blocking entry calls should defer abort until the calls are
1763 -- cancelled, then clean up.
1765 Utilities.Cancel_Queued_Entry_Calls (Self_ID);
1766 Unlock (Self_ID);
1768 if Self_ID.Common.Activator /= null then
1769 Vulnerable_Complete_Activation (Self_ID);
1770 end if;
1772 if Single_Lock then
1773 Unlock_RTS;
1774 end if;
1776 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
1777 -- we may have dependent tasks for which we need to wait.
1778 -- Otherwise, we can just exit.
1780 if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
1781 Vulnerable_Complete_Master (Self_ID);
1782 end if;
1783 end Vulnerable_Complete_Task;
1785 --------------------------
1786 -- Vulnerable_Free_Task --
1787 --------------------------
1789 -- Recover all runtime system storage associated with the task T.
1790 -- This should only be called after T has terminated and will no
1791 -- longer be referenced.
1793 -- For tasks created by an allocator that fails, due to an exception,
1794 -- it is called from Expunge_Unactivated_Tasks.
1796 -- For tasks created by elaboration of task object declarations it
1797 -- is called from the finalization code of the Task_Wrapper procedure.
1798 -- It is also called from Unchecked_Deallocation, for objects that
1799 -- are or contain tasks.
1801 procedure Vulnerable_Free_Task (T : Task_Id) is
1802 begin
1803 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
1805 if Single_Lock then
1806 Lock_RTS;
1807 end if;
1809 Write_Lock (T);
1810 Initialization.Finalize_Attributes_Link.all (T);
1811 Unlock (T);
1813 if Single_Lock then
1814 Unlock_RTS;
1815 end if;
1817 System.Task_Primitives.Operations.Finalize_TCB (T);
1818 end Vulnerable_Free_Task;
1820 -- Package elaboration code
1822 begin
1823 -- Establish the Adafinal softlink
1825 -- This is not done inside the central RTS initialization routine
1826 -- to avoid with-ing this package from System.Tasking.Initialization.
1828 SSL.Adafinal := Finalize_Global_Tasks'Access;
1830 -- Establish soft links for subprograms that manipulate master_id's.
1831 -- This cannot be done when the RTS is initialized, because of various
1832 -- elaboration constraints.
1834 SSL.Current_Master := Stages.Current_Master'Access;
1835 SSL.Enter_Master := Stages.Enter_Master'Access;
1836 SSL.Complete_Master := Stages.Complete_Master'Access;
1837 end System.Tasking.Stages;