1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . S T A G E S --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
35 -- Turn off polling, we do not want ATC polling to take place during
36 -- tasking operations. It causes infinite loops and other problems.
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
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
69 -- Finalize_Attributes_Link
70 -- Initialize_Attributes_Link
72 pragma Elaborate_All
(System
.Tasking
.Initialization
);
73 -- This insures that tasking is initialized if any tasks are created
75 with System
.Tasking
.Utilities
;
76 -- Used for Make_Passive
80 with System
.Tasking
.Queuing
;
81 -- Used for Dequeue_Head
83 with System
.Tasking
.Rendezvous
;
84 -- Used for Call_Simple
86 with System
.OS_Primitives
;
87 -- Used for Delay_Modes
89 with System
.Secondary_Stack
;
92 with System
.Storage_Elements
;
93 -- Used for Storage_Array
95 with System
.Restrictions
;
96 -- Used for Abort_Allowed
98 with System
.Standard_Library
;
99 -- Used for Exception_Trace
101 with System
.Traces
.Tasking
;
102 -- Used for Send_Trace_Info
104 with Ada
.Unchecked_Deallocation
;
105 -- To recover from failure of ATCB initialization
107 with System
.Stack_Usage
;
109 package body System
.Tasking
.Stages
is
111 package STPO
renames System
.Task_Primitives
.Operations
;
112 package SSL
renames System
.Soft_Links
;
113 package SSE
renames System
.Storage_Elements
;
114 package SST
renames System
.Secondary_Stack
;
120 use Task_Primitives
.Operations
;
124 use System
.Traces
.Tasking
;
126 -----------------------
127 -- Local Subprograms --
128 -----------------------
130 procedure Free
is new
131 Ada
.Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
133 procedure Trace_Unhandled_Exception_In_Task
(Self_Id
: Task_Id
);
134 -- This procedure outputs the task specific message for exception
137 procedure Task_Wrapper
(Self_ID
: Task_Id
);
138 pragma Convention
(C
, Task_Wrapper
);
139 -- This is the procedure that is called by the GNULL from the new context
140 -- when a task is created. It waits for activation and then calls the task
141 -- body procedure. When the task body procedure completes, it terminates
144 -- The Task_Wrapper's address will be provided to the underlying threads
145 -- library as the task entry point. Convention C is what makes most sense
146 -- for that purpose (Export C would make the function globally visible,
147 -- and affect the link name on which GDB depends). This will in addition
148 -- trigger an automatic stack alignment suitable for GCC's assumptions if
151 -- "Vulnerable_..." in the procedure names below means they must be called
152 -- with abort deferred.
154 procedure Vulnerable_Complete_Task
(Self_ID
: Task_Id
);
155 -- Complete the calling task. This procedure must be called with
156 -- abort deferred. It should only be called by Complete_Task and
157 -- Finalizate_Global_Tasks (for the environment task).
159 procedure Vulnerable_Complete_Master
(Self_ID
: Task_Id
);
160 -- Complete the current master of the calling task. This procedure
161 -- must be called with abort deferred. It should only be called by
162 -- Vulnerable_Complete_Task and Complete_Master.
164 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_Id
);
165 -- Signal to Self_ID's activator that Self_ID has completed activation.
166 -- This procedure must be called with abort deferred.
168 procedure Abort_Dependents
(Self_ID
: Task_Id
);
169 -- Abort all the direct dependents of Self at its current master
170 -- nesting level, plus all of their dependents, transitively.
171 -- RTS_Lock should be locked by the caller.
173 procedure Vulnerable_Free_Task
(T
: Task_Id
);
174 -- Recover all runtime system storage associated with the task T.
175 -- This should only be called after T has terminated and will no
176 -- longer be referenced.
178 -- For tasks created by an allocator that fails, due to an exception,
179 -- it is called from Expunge_Unactivated_Tasks.
181 -- It is also called from Ada.Unchecked_Deallocation, for objects that
182 -- are or contain tasks.
184 -- Different code is used at master completion, in Terminate_Dependents,
185 -- due to a need for tighter synchronization with the master.
187 ----------------------
188 -- Abort_Dependents --
189 ----------------------
191 procedure Abort_Dependents
(Self_ID
: Task_Id
) is
198 P
:= C
.Common
.Parent
;
202 -- ??? C is supposed to take care of its own dependents, so
203 -- there should be no need to worry about them. Need to double
206 if C
.Master_of_Task
= Self_ID
.Master_Within
then
207 Utilities
.Abort_One_Task
(Self_ID
, C
);
208 C
.Dependents_Aborted
:= True;
214 P
:= P
.Common
.Parent
;
217 C
:= C
.Common
.All_Tasks_Link
;
220 Self_ID
.Dependents_Aborted
:= True;
221 end Abort_Dependents
;
227 procedure Abort_Tasks
(Tasks
: Task_List
) is
229 Utilities
.Abort_Tasks
(Tasks
);
236 -- Note that locks of activator and activated task are both locked
237 -- here. This is necessary because C.Common.State and
238 -- Self.Common.Wait_Count have to be synchronized. This is safe from
239 -- deadlock because the activator is always created before the activated
240 -- task. That satisfies our in-order-of-creation ATCB locking policy.
242 -- At one point, we may also lock the parent, if the parent is
243 -- different from the activator. That is also consistent with the
244 -- lock ordering policy, since the activator cannot be created
245 -- before the parent.
247 -- Since we are holding both the activator's lock, and Task_Wrapper
248 -- locks that before it does anything more than initialize the
249 -- low-level ATCB components, it should be safe to wait to update
250 -- the counts until we see that the thread creation is successful.
252 -- If the thread creation fails, we do need to close the entries
253 -- of the task. The first phase, of dequeuing calls, only requires
254 -- locking the acceptor's ATCB, but the waking up of the callers
255 -- requires locking the caller's ATCB. We cannot safely do this
256 -- while we are holding other locks. Therefore, the queue-clearing
257 -- operation is done in a separate pass over the activation chain.
259 procedure Activate_Tasks
(Chain_Access
: Activation_Chain_Access
) is
260 Self_ID
: constant Task_Id
:= STPO
.Self
;
263 Next_C
, Last_C
: Task_Id
;
264 Activate_Prio
: System
.Any_Priority
;
266 All_Elaborated
: Boolean := True;
269 -- If pragma Detect_Blocking is active, then we must check whether this
270 -- potentially blocking operation is called from a protected action.
272 if System
.Tasking
.Detect_Blocking
273 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
275 Ada
.Exceptions
.Raise_Exception
276 (Program_Error
'Identity, "potentially blocking operation");
280 (Debug
.Trace
(Self_ID
, "Activate_Tasks", 'C'));
282 Initialization
.Defer_Abort_Nestable
(Self_ID
);
284 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
286 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
287 -- we finish activating the chain.
291 -- Check that all task bodies have been elaborated
293 C
:= Chain_Access
.T_ID
;
296 if C
.Common
.Elaborated
/= null
297 and then not C
.Common
.Elaborated
.all
299 All_Elaborated
:= False;
302 -- Reverse the activation chain so that tasks are
303 -- activated in the same order they're declared.
305 Next_C
:= C
.Common
.Activation_Link
;
306 C
.Common
.Activation_Link
:= Last_C
;
311 Chain_Access
.T_ID
:= Last_C
;
313 if not All_Elaborated
then
315 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
317 (Program_Error
'Identity, "Some tasks have not been elaborated");
320 -- Activate all the tasks in the chain. Creation of the thread of
321 -- control was deferred until activation. So create it now.
323 C
:= Chain_Access
.T_ID
;
325 if C
.Common
.State
/= Terminated
then
326 pragma Assert
(C
.Common
.State
= Unactivated
);
328 P
:= C
.Common
.Parent
;
332 if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
) then
333 Activate_Prio
:= Get_Priority
(Self_ID
);
335 Activate_Prio
:= C
.Common
.Base_Priority
;
338 System
.Task_Primitives
.Operations
.Create_Task
339 (C
, Task_Wrapper
'Address,
341 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
342 Activate_Prio
, Success
);
344 -- There would be a race between the created task and the
345 -- creator to do the following initialization, if we did not
346 -- have a Lock/Unlock_RTS pair in the task wrapper to prevent
347 -- it from racing ahead.
350 C
.Common
.State
:= Runnable
;
353 P
.Awake_Count
:= P
.Awake_Count
+ 1;
354 P
.Alive_Count
:= P
.Alive_Count
+ 1;
356 if P
.Common
.State
= Master_Completion_Sleep
and then
357 C
.Master_of_Task
= P
.Master_Within
359 pragma Assert
(Self_ID
/= P
);
360 P
.Common
.Wait_Count
:= P
.Common
.Wait_Count
+ 1;
367 -- No need to set Awake_Count, State, etc. here since the loop
368 -- below will do that for any Unactivated tasks.
372 Self_ID
.Common
.Activation_Failed
:= True;
376 C
:= C
.Common
.Activation_Link
;
379 if not Single_Lock
then
383 -- Close the entries of any tasks that failed thread creation,
384 -- and count those that have not finished activation.
386 Write_Lock
(Self_ID
);
387 Self_ID
.Common
.State
:= Activator_Sleep
;
389 C
:= Chain_Access
.T_ID
;
393 if C
.Common
.State
= Unactivated
then
394 C
.Common
.Activator
:= null;
395 C
.Common
.State
:= Terminated
;
397 Utilities
.Cancel_Queued_Entry_Calls
(C
);
399 elsif C
.Common
.Activator
/= null then
400 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
404 P
:= C
.Common
.Activation_Link
;
405 C
.Common
.Activation_Link
:= null;
409 -- Wait for the activated tasks to complete activation. It is
410 -- unsafe to abort any of these tasks until the count goes to zero.
413 exit when Self_ID
.Common
.Wait_Count
= 0;
414 Sleep
(Self_ID
, Activator_Sleep
);
417 Self_ID
.Common
.State
:= Runnable
;
424 -- Remove the tasks from the chain
426 Chain_Access
.T_ID
:= null;
427 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
429 if Self_ID
.Common
.Activation_Failed
then
430 Self_ID
.Common
.Activation_Failed
:= False;
431 Raise_Exception
(Tasking_Error
'Identity,
432 "Failure during activation");
436 -------------------------
437 -- Complete_Activation --
438 -------------------------
440 procedure Complete_Activation
is
441 Self_ID
: constant Task_Id
:= STPO
.Self
;
444 Initialization
.Defer_Abort_Nestable
(Self_ID
);
450 Vulnerable_Complete_Activation
(Self_ID
);
456 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
459 -- Why do we need to allow for nested deferral here?
461 if Runtime_Traces
then
462 Send_Trace_Info
(T_Activate
);
464 end Complete_Activation
;
466 ---------------------
467 -- Complete_Master --
468 ---------------------
470 procedure Complete_Master
is
471 Self_ID
: constant Task_Id
:= STPO
.Self
;
474 (Self_ID
.Deferral_Level
> 0
475 or else not System
.Restrictions
.Abort_Allowed
);
476 Vulnerable_Complete_Master
(Self_ID
);
483 -- See comments on Vulnerable_Complete_Task for details
485 procedure Complete_Task
is
486 Self_ID
: constant Task_Id
:= STPO
.Self
;
490 (Self_ID
.Deferral_Level
> 0
491 or else not System
.Restrictions
.Abort_Allowed
);
493 Vulnerable_Complete_Task
(Self_ID
);
495 -- All of our dependents have terminated. Never undefer abort again!
503 -- Compiler interface only. Do not call from within the RTS.
504 -- This must be called to create a new task.
506 procedure Create_Task
508 Size
: System
.Parameters
.Size_Type
;
509 Task_Info
: System
.Task_Info
.Task_Info_Type
;
510 Num_Entries
: Task_Entry_Index
;
511 Master
: Master_Level
;
512 State
: Task_Procedure_Access
;
513 Discriminants
: System
.Address
;
514 Elaborated
: Access_Boolean
;
515 Chain
: in out Activation_Chain
;
517 Created_Task
: out Task_Id
)
520 Self_ID
: constant Task_Id
:= STPO
.Self
;
522 Base_Priority
: System
.Any_Priority
;
526 -- If Master is greater than the current master, it means that Master
527 -- has already awaited its dependent tasks. This raises Program_Error,
528 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
530 if Self_ID
.Master_of_Task
/= Foreign_Task_Level
531 and then Master
> Self_ID
.Master_Within
533 raise Program_Error
with
534 "create task after awaiting termination";
537 -- If pragma Detect_Blocking is active must be checked whether
538 -- this potentially blocking operation is called from a
541 if System
.Tasking
.Detect_Blocking
542 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
544 Ada
.Exceptions
.Raise_Exception
545 (Program_Error
'Identity, "potentially blocking operation");
549 (Debug
.Trace
(Self_ID
, "Create_Task", 'C'));
551 if Priority
= Unspecified_Priority
then
552 Base_Priority
:= Self_ID
.Common
.Base_Priority
;
554 Base_Priority
:= System
.Any_Priority
(Priority
);
557 -- Find parent P of new Task, via master level number
562 while P
.Master_of_Task
>= Master
loop
563 P
:= P
.Common
.Parent
;
568 Initialization
.Defer_Abort_Nestable
(Self_ID
);
571 T
:= New_ATCB
(Num_Entries
);
574 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
575 Raise_Exception
(Storage_Error
'Identity, "Cannot allocate task");
578 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks.
579 -- Up to this point, it is possible that we may be part of
580 -- a family of tasks that is being aborted.
583 Write_Lock
(Self_ID
);
585 -- Now, we must check that we have not been aborted.
586 -- If so, we should give up on creating this task,
587 -- and simply return.
589 if not Self_ID
.Callable
then
590 pragma Assert
(Self_ID
.Pending_ATC_Level
= 0);
591 pragma Assert
(Self_ID
.Pending_Action
);
593 (Chain
.T_ID
= null or else Chain
.T_ID
.Common
.State
= Unactivated
);
597 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
599 -- ??? Should never get here
601 pragma Assert
(False);
602 raise Standard
'Abort_Signal;
605 Initialize_ATCB
(Self_ID
, State
, Discriminants
, P
, Elaborated
,
606 Base_Priority
, Task_Info
, Size
, T
, Success
);
612 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
614 (Storage_Error
'Identity, "Failed to initialize task");
617 if Master
= Foreign_Task_Level
+ 2 then
619 -- This should not happen, except when a foreign task creates non
620 -- library-level Ada tasks. In this case, we pretend the master is
621 -- a regular library level task, otherwise the run-time will get
622 -- confused when waiting for these tasks to terminate.
624 T
.Master_of_Task
:= Library_Task_Level
;
626 T
.Master_of_Task
:= Master
;
629 T
.Master_Within
:= T
.Master_of_Task
+ 1;
631 for L
in T
.Entry_Calls
'Range loop
632 T
.Entry_Calls
(L
).Self
:= T
;
633 T
.Entry_Calls
(L
).Level
:= L
;
636 if Task_Image
'Length = 0 then
637 T
.Common
.Task_Image_Len
:= 0;
640 T
.Common
.Task_Image
(1) := Task_Image
(Task_Image
'First);
642 -- Remove unwanted blank space generated by 'Image
644 for J
in Task_Image
'First + 1 .. Task_Image
'Last loop
645 if Task_Image
(J
) /= ' '
646 or else Task_Image
(J
- 1) /= '('
649 T
.Common
.Task_Image
(Len
) := Task_Image
(J
);
650 exit when Len
= T
.Common
.Task_Image
'Last;
654 T
.Common
.Task_Image_Len
:= Len
;
660 -- Create TSD as early as possible in the creation of a task, since it
661 -- may be used by the operation of Ada code within the task.
663 SSL
.Create_TSD
(T
.Common
.Compiler_Data
);
664 T
.Common
.Activation_Link
:= Chain
.T_ID
;
666 Initialization
.Initialize_Attributes_Link
.all (T
);
668 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
670 if Runtime_Traces
then
671 Send_Trace_Info
(T_Create
, T
);
679 function Current_Master
return Master_Level
is
681 return STPO
.Self
.Master_Within
;
688 procedure Enter_Master
is
689 Self_ID
: constant Task_Id
:= STPO
.Self
;
691 Self_ID
.Master_Within
:= Self_ID
.Master_Within
+ 1;
694 -------------------------------
695 -- Expunge_Unactivated_Tasks --
696 -------------------------------
698 -- See procedure Close_Entries for the general case
700 procedure Expunge_Unactivated_Tasks
(Chain
: in out Activation_Chain
) is
701 Self_ID
: constant Task_Id
:= STPO
.Self
;
703 Call
: Entry_Call_Link
;
708 (Debug
.Trace
(Self_ID
, "Expunge_Unactivated_Tasks", 'C'));
710 Initialization
.Defer_Abort_Nestable
(Self_ID
);
713 -- Experimentation has shown that abort is sometimes (but not
714 -- always) already deferred when this is called.
716 -- That may indicate an error. Find out what is going on
720 pragma Assert
(C
.Common
.State
= Unactivated
);
722 Temp
:= C
.Common
.Activation_Link
;
724 if C
.Common
.State
= Unactivated
then
728 for J
in 1 .. C
.Entry_Num
loop
729 Queuing
.Dequeue_Head
(C
.Entry_Queues
(J
), Call
);
730 pragma Assert
(Call
= null);
735 Initialization
.Remove_From_All_Tasks_List
(C
);
738 Vulnerable_Free_Task
(C
);
744 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
745 end Expunge_Unactivated_Tasks
;
747 ---------------------------
748 -- Finalize_Global_Tasks --
749 ---------------------------
752 -- We have a potential problem here if finalization of global
753 -- objects does anything with signals or the timer server, since
754 -- by that time those servers have terminated.
756 -- It is hard to see how that would occur
758 -- However, a better solution might be to do all this finalization
759 -- using the global finalization chain.
761 procedure Finalize_Global_Tasks
is
762 Self_ID
: constant Task_Id
:= STPO
.Self
;
765 pragma Unreferenced
(Ignore
);
768 if Self_ID
.Deferral_Level
= 0 then
770 -- In principle, we should be able to predict whether
771 -- abort is already deferred here (and it should not be deferred
772 -- yet but in practice it seems Finalize_Global_Tasks is being
773 -- called sometimes, from RTS code for exceptions, with abort already
776 Initialization
.Defer_Abort_Nestable
(Self_ID
);
778 -- Never undefer again!!!
781 -- This code is only executed by the environment task
783 pragma Assert
(Self_ID
= Environment_Task
);
785 -- Set Environment_Task'Callable to false to notify library-level tasks
786 -- that it is waiting for them.
788 Self_ID
.Callable
:= False;
790 -- Exit level 2 master, for normal tasks in library-level packages
794 -- Force termination of "independent" library-level server tasks
798 Abort_Dependents
(Self_ID
);
800 if not Single_Lock
then
804 -- We need to explicitely wait for the task to be terminated here
805 -- because on true concurrent system, we may end this procedure
806 -- before the tasks are really terminated.
808 Write_Lock
(Self_ID
);
811 exit when Utilities
.Independent_Task_Count
= 0;
813 -- We used to yield here, but this did not take into account
814 -- low priority tasks that would cause dead lock in some cases
815 -- (true FIFO scheduling).
818 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
819 Self_ID
.Common
.State
, Ignore
, Ignore
);
822 -- ??? On multi-processor environments, it seems that the above loop
823 -- isn't sufficient, so we need to add an additional delay.
826 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
827 Self_ID
.Common
.State
, Ignore
, Ignore
);
835 -- Complete the environment task
837 Vulnerable_Complete_Task
(Self_ID
);
839 -- Handle normal task termination by the environment task, but only
840 -- for the normal task termination. In the case of Abnormal and
841 -- Unhandled_Exception they must have been handled before, and the
842 -- task termination soft link must have been changed so the task
843 -- termination routine is not executed twice.
845 SSL
.Task_Termination_Handler
.all (Ada
.Exceptions
.Null_Occurrence
);
847 -- Finalize the global list for controlled objects if needed
849 SSL
.Finalize_Global_List
.all;
851 -- Reset the soft links to non-tasking
853 SSL
.Abort_Defer
:= SSL
.Abort_Defer_NT
'Access;
854 SSL
.Abort_Undefer
:= SSL
.Abort_Undefer_NT
'Access;
855 SSL
.Lock_Task
:= SSL
.Task_Lock_NT
'Access;
856 SSL
.Unlock_Task
:= SSL
.Task_Unlock_NT
'Access;
857 SSL
.Get_Jmpbuf_Address
:= SSL
.Get_Jmpbuf_Address_NT
'Access;
858 SSL
.Set_Jmpbuf_Address
:= SSL
.Set_Jmpbuf_Address_NT
'Access;
859 SSL
.Get_Sec_Stack_Addr
:= SSL
.Get_Sec_Stack_Addr_NT
'Access;
860 SSL
.Set_Sec_Stack_Addr
:= SSL
.Set_Sec_Stack_Addr_NT
'Access;
861 SSL
.Check_Abort_Status
:= SSL
.Check_Abort_Status_NT
'Access;
862 SSL
.Get_Stack_Info
:= SSL
.Get_Stack_Info_NT
'Access;
864 -- Don't bother trying to finalize Initialization.Global_Task_Lock
865 -- and System.Task_Primitives.RTS_Lock.
867 end Finalize_Global_Tasks
;
873 procedure Free_Task
(T
: Task_Id
) is
874 Self_Id
: constant Task_Id
:= Self
;
877 if T
.Common
.State
= Terminated
then
879 -- It is not safe to call Abort_Defer or Write_Lock at this stage
881 Initialization
.Task_Lock
(Self_Id
);
884 Initialization
.Remove_From_All_Tasks_List
(T
);
887 Initialization
.Task_Unlock
(Self_Id
);
889 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
891 -- If the task is not terminated, then we simply ignore the call. This
892 -- happens when a user program attempts an unchecked deallocation on
893 -- a non-terminated task.
900 ---------------------------
901 -- Move_Activation_Chain --
902 ---------------------------
904 procedure Move_Activation_Chain
905 (From
, To
: Activation_Chain_Access
;
906 New_Master
: Master_ID
)
908 Self_ID
: constant Task_Id
:= STPO
.Self
;
913 (Debug
.Trace
(Self_ID
, "Move_Activation_Chain", 'C'));
915 -- Nothing to do if From is empty, and we can check that without
924 Initialization
.Defer_Abort
(Self_ID
);
926 -- Loop through the From chain, changing their Master_of_Task
927 -- fields, and to find the end of the chain.
930 C
.Master_of_Task
:= New_Master
;
931 exit when C
.Common
.Activation_Link
= null;
932 C
:= C
.Common
.Activation_Link
;
935 -- Hook From in at the start of To
937 C
.Common
.Activation_Link
:= To
.all.T_ID
;
938 To
.all.T_ID
:= From
.all.T_ID
;
942 From
.all.T_ID
:= null;
944 Initialization
.Undefer_Abort
(Self_ID
);
945 end Move_Activation_Chain
;
951 -- The task wrapper is a procedure that is called first for each task
952 -- task body, and which in turn calls the compiler-generated task body
953 -- procedure. The wrapper's main job is to do initialization for the task.
954 -- It also has some locally declared objects that server as per-task local
955 -- data. Task finalization is done by Complete_Task, which is called from
956 -- an at-end handler that the compiler generates.
958 procedure Task_Wrapper
(Self_ID
: Task_Id
) is
959 use type SSE
.Storage_Offset
;
960 use System
.Standard_Library
;
961 use System
.Stack_Usage
;
963 Bottom_Of_Stack
: aliased Integer;
965 Secondary_Stack_Size
:
966 constant SSE
.Storage_Offset
:=
967 Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
*
968 SSE
.Storage_Offset
(Parameters
.Sec_Stack_Ratio
) / 100;
970 Secondary_Stack
: aliased SSE
.Storage_Array
(1 .. Secondary_Stack_Size
);
972 pragma Warnings
(Off
);
973 -- Why are warnings being turned off here???
975 Secondary_Stack_Address
: System
.Address
:= Secondary_Stack
'Address;
977 Small_Overflow_Guard
: constant := 12 * 1024;
978 -- Note: this used to be 4K, but was changed to 12K, since smaller
979 -- values resulted in segmentation faults from dynamic stack analysis.
981 Big_Overflow_Guard
: constant := 16 * 1024;
982 Small_Stack_Limit
: constant := 64 * 1024;
983 -- ??? These three values are experimental, and seems to work on most
984 -- platforms. They still need to be analyzed further. They also need
985 -- documentation, what are they???
988 Natural (Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
);
990 Overflow_Guard
: Natural;
991 -- Size of the overflow guard, used by dynamic stack usage analysis
993 pragma Warnings
(On
);
994 -- Address of secondary stack. In the fixed secondary stack case, this
995 -- value is not modified, causing a warning, hence the bracketing with
996 -- Warnings (Off/On). But why is so much *more* bracketed ???
998 SEH_Table
: aliased SSE
.Storage_Array
(1 .. 8);
999 -- Structured Exception Registration table (2 words)
1001 procedure Install_SEH_Handler
(Addr
: System
.Address
);
1002 pragma Import
(C
, Install_SEH_Handler
, "__gnat_install_SEH_handler");
1003 -- Install the SEH (Structured Exception Handling) handler
1005 Cause
: Cause_Of_Termination
:= Normal
;
1006 -- Indicates the reason why this task terminates. Normal corresponds to
1007 -- a task terminating due to completing the last statement of its body,
1008 -- or as a result of waiting on a terminate alternative. If the task
1009 -- terminates because it is being aborted then Cause will be set to
1010 -- Abnormal. If the task terminates because of an exception raised by
1011 -- the execution of its task body, then Cause is set to
1012 -- Unhandled_Exception.
1014 EO
: Exception_Occurrence
;
1015 -- If the task terminates because of an exception raised by the
1016 -- execution of its task body, then EO will contain the associated
1017 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
1019 TH
: Termination_Handler
:= null;
1020 -- Pointer to the protected procedure to be executed upon task
1023 procedure Search_Fall_Back_Handler
(ID
: Task_Id
);
1024 -- Procedure that searches recursively a fall-back handler through the
1025 -- master relationship. If the handler is found, its pointer is stored
1028 ------------------------------
1029 -- Search_Fall_Back_Handler --
1030 ------------------------------
1032 procedure Search_Fall_Back_Handler
(ID
: Task_Id
) is
1034 -- If there is a fall back handler, store its pointer for later
1037 if ID
.Common
.Fall_Back_Handler
/= null then
1038 TH
:= ID
.Common
.Fall_Back_Handler
;
1040 -- Otherwise look for a fall back handler in the parent
1042 elsif ID
.Common
.Parent
/= null then
1043 Search_Fall_Back_Handler
(ID
.Common
.Parent
);
1045 -- Otherwise, do nothing
1050 end Search_Fall_Back_Handler
;
1053 pragma Assert
(Self_ID
.Deferral_Level
= 1);
1055 -- Assume a size of the stack taken at this stage
1057 if Size
< Small_Stack_Limit
then
1058 Overflow_Guard
:= Small_Overflow_Guard
;
1060 Overflow_Guard
:= Big_Overflow_Guard
;
1063 Size
:= Size
- Overflow_Guard
;
1065 if not Parameters
.Sec_Stack_Dynamic
then
1066 Self_ID
.Common
.Compiler_Data
.Sec_Stack_Addr
:=
1067 Secondary_Stack
'Address;
1068 SST
.SS_Init
(Secondary_Stack_Address
, Integer (Secondary_Stack
'Last));
1069 Size
:= Size
- Natural (Secondary_Stack_Size
);
1072 if System
.Stack_Usage
.Is_Enabled
then
1074 Initialize_Analyzer
(Self_ID
.Common
.Analyzer
,
1075 Self_ID
.Common
.Task_Image
1076 (1 .. Self_ID
.Common
.Task_Image_Len
),
1079 SSE
.To_Integer
(Bottom_Of_Stack
'Address));
1081 Fill_Stack
(Self_ID
.Common
.Analyzer
);
1084 -- Set the guard page at the bottom of the stack. The call to unprotect
1085 -- the page is done in Terminate_Task
1087 Stack_Guard
(Self_ID
, True);
1089 -- Initialize low-level TCB components, that cannot be initialized
1090 -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and
1091 -- also Self_ID.LL.Thread
1093 Enter_Task
(Self_ID
);
1095 -- We setup the SEH (Structured Exception Handling) handler if supported
1098 Install_SEH_Handler
(SEH_Table
'Address);
1100 -- Initialize exception occurrence
1102 Save_Occurrence
(EO
, Ada
.Exceptions
.Null_Occurrence
);
1104 -- We lock RTS_Lock to wait for activator to finish activating the rest
1105 -- of the chain, so that everyone in the chain comes out in priority
1108 -- This also protects the value of
1109 -- Self_ID.Common.Activator.Common.Wait_Count.
1114 if not System
.Restrictions
.Abort_Allowed
then
1116 -- If Abort is not allowed, reset the deferral level since it will
1117 -- not get changed by the generated code. Keeping a default value
1118 -- of one would prevent some operations (e.g. select or delay) to
1119 -- proceed successfully.
1121 Self_ID
.Deferral_Level
:= 0;
1125 -- We are separating the following portion of the code in order to
1126 -- place the exception handlers in a different block. In this way,
1127 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
1128 -- set Self in Enter_Task
1130 -- Call the task body procedure
1132 -- The task body is called with abort still deferred. That
1133 -- eliminates a dangerous window, for which we had to patch-up in
1136 -- During the expansion of the task body, we insert an RTS-call
1137 -- to Abort_Undefer, at the first point where abort should be
1140 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
1141 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1144 -- We can't call Terminate_Task in the exception handlers below,
1145 -- since there may be (e.g. in the case of GCC exception handling)
1146 -- clean ups associated with the exception handler that need to
1147 -- access task specific data.
1149 -- Defer abort so that this task can't be aborted while exiting
1151 when Standard
'Abort_Signal =>
1152 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1154 -- Update the cause that motivated the task termination so that
1155 -- the appropriate information is passed to the task termination
1156 -- procedure. Task termination as a result of waiting on a
1157 -- terminate alternative is a normal termination, although it is
1158 -- implemented using the abort mechanisms.
1160 if Self_ID
.Terminate_Alternative
then
1166 -- ??? Using an E : others here causes CD2C11A to fail on Tru64.
1168 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1170 -- Perform the task specific exception tracing duty. We handle
1171 -- these outputs here and not in the common notification routine
1172 -- because we need access to tasking related data and we don't
1173 -- want to drag dependencies against tasking related units in the
1174 -- the common notification units. Additionally, no trace is ever
1175 -- triggered from the common routine for the Unhandled_Raise case
1176 -- in tasks, since an exception never appears unhandled in this
1177 -- context because of this handler.
1179 if Exception_Trace
= Unhandled_Raise
then
1180 Trace_Unhandled_Exception_In_Task
(Self_ID
);
1183 -- Update the cause that motivated the task termination so that
1184 -- the appropriate information is passed to the task termination
1185 -- procedure, as well as the associated Exception_Occurrence.
1187 Cause
:= Unhandled_Exception
;
1188 Save_Occurrence
(EO
, SSL
.Get_Current_Excep
.all.all);
1191 -- Look for a task termination handler. This code is for all tasks but
1192 -- the environment task. The task termination code for the environment
1193 -- task is executed by SSL.Task_Termination_Handler.
1199 Write_Lock
(Self_ID
);
1201 if Self_ID
.Common
.Specific_Handler
/= null then
1202 TH
:= Self_ID
.Common
.Specific_Handler
;
1204 -- Look for a fall-back handler following the master relationship
1207 Search_Fall_Back_Handler
(Self_ID
);
1216 -- Execute the task termination handler if we found it
1219 TH
.all (Cause
, Self_ID
, EO
);
1222 if System
.Stack_Usage
.Is_Enabled
then
1223 Compute_Result
(Self_ID
.Common
.Analyzer
);
1224 Report_Result
(Self_ID
.Common
.Analyzer
);
1227 Terminate_Task
(Self_ID
);
1230 --------------------
1231 -- Terminate_Task --
1232 --------------------
1234 -- Before we allow the thread to exit, we must clean up. This is a
1235 -- a delicate job. We must wake up the task's master, who may immediately
1236 -- try to deallocate the ATCB out from under the current task WHILE IT IS
1239 -- To avoid this, the parent task must be blocked up to the latest
1240 -- statement executed. The trouble is that we have another step that we
1241 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1242 -- We have to postpone that until the end because compiler-generated code
1243 -- is likely to try to access that data at just about any point.
1245 -- We can't call Destroy_TSD while we are holding any other locks, because
1246 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1247 -- that to be the outermost lock. Our first "solution" was to just lock
1248 -- Global_Task_Lock in addition to the other locks, and force the parent to
1249 -- also lock this lock between its wakeup and its freeing of the ATCB. See
1250 -- Complete_Task for the parent-side of the code that has the matching
1251 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1252 -- since the operation Task_Unlock continued to access the ATCB after
1253 -- unlocking, after which the parent was observed to race ahead, deallocate
1254 -- the ATCB, and then reallocate it to another task. The call to
1255 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
1256 -- the data of the new task that reused the ATCB! To solve this problem, we
1257 -- introduced the new operation Final_Task_Unlock.
1259 procedure Terminate_Task
(Self_ID
: Task_Id
) is
1260 Environment_Task
: constant Task_Id
:= STPO
.Environment_Task
;
1261 Master_of_Task
: Integer;
1264 Debug
.Task_Termination_Hook
;
1266 if Runtime_Traces
then
1267 Send_Trace_Info
(T_Terminate
);
1270 -- Since GCC cannot allocate stack chunks efficiently without reordering
1271 -- some of the allocations, we have to handle this unexpected situation
1272 -- here. We should normally never have to call Vulnerable_Complete_Task
1275 if Self_ID
.Common
.Activator
/= null then
1276 Vulnerable_Complete_Task
(Self_ID
);
1279 Initialization
.Task_Lock
(Self_ID
);
1285 Master_of_Task
:= Self_ID
.Master_of_Task
;
1287 -- Check if the current task is an independent task If so, decrement
1288 -- the Independent_Task_Count value.
1290 if Master_of_Task
= Independent_Task_Level
then
1292 Utilities
.Independent_Task_Count
:=
1293 Utilities
.Independent_Task_Count
- 1;
1295 Write_Lock
(Environment_Task
);
1296 Utilities
.Independent_Task_Count
:=
1297 Utilities
.Independent_Task_Count
- 1;
1298 Unlock
(Environment_Task
);
1302 -- Unprotect the guard page if needed
1304 Stack_Guard
(Self_ID
, False);
1306 Utilities
.Make_Passive
(Self_ID
, Task_Completed
=> True);
1312 pragma Assert
(Check_Exit
(Self_ID
));
1314 SSL
.Destroy_TSD
(Self_ID
.Common
.Compiler_Data
);
1315 Initialization
.Final_Task_Unlock
(Self_ID
);
1317 -- WARNING: past this point, this thread must assume that the ATCB
1318 -- has been deallocated. It should not be accessed again.
1320 if Master_of_Task
> 0 then
1329 function Terminated
(T
: Task_Id
) return Boolean is
1330 Self_ID
: constant Task_Id
:= STPO
.Self
;
1334 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1341 Result
:= T
.Common
.State
= Terminated
;
1348 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
1352 ----------------------------------------
1353 -- Trace_Unhandled_Exception_In_Task --
1354 ----------------------------------------
1356 procedure Trace_Unhandled_Exception_In_Task
(Self_Id
: Task_Id
) is
1357 procedure To_Stderr
(S
: String);
1358 pragma Import
(Ada
, To_Stderr
, "__gnat_to_stderr");
1360 use System
.Soft_Links
;
1361 use System
.Standard_Library
;
1363 function To_Address
is new
1364 Ada
.Unchecked_Conversion
(Task_Id
, System
.Address
);
1366 function Tailored_Exception_Information
1367 (E
: Exception_Occurrence
) return String;
1369 (Ada
, Tailored_Exception_Information
,
1370 "__gnat_tailored_exception_information");
1372 Excep
: constant Exception_Occurrence_Access
:=
1373 SSL
.Get_Current_Excep
.all;
1376 -- This procedure is called by the task outermost handler in
1377 -- Task_Wrapper below, so only once the task stack has been fully
1378 -- unwound. The common notification routine has been called at the
1379 -- raise point already.
1381 To_Stderr
("task ");
1383 if Self_Id
.Common
.Task_Image_Len
/= 0 then
1385 (Self_Id
.Common
.Task_Image
(1 .. Self_Id
.Common
.Task_Image_Len
));
1389 To_Stderr
(System
.Address_Image
(To_Address
(Self_Id
)));
1390 To_Stderr
(" terminated by unhandled exception");
1391 To_Stderr
((1 => ASCII
.LF
));
1392 To_Stderr
(Tailored_Exception_Information
(Excep
.all));
1393 end Trace_Unhandled_Exception_In_Task
;
1395 ------------------------------------
1396 -- Vulnerable_Complete_Activation --
1397 ------------------------------------
1399 -- As in several other places, the locks of the activator and activated
1400 -- task are both locked here. This follows our deadlock prevention lock
1401 -- ordering policy, since the activated task must be created after the
1404 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_Id
) is
1405 Activator
: constant Task_Id
:= Self_ID
.Common
.Activator
;
1408 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Activation", 'C'));
1410 Write_Lock
(Activator
);
1411 Write_Lock
(Self_ID
);
1413 pragma Assert
(Self_ID
.Common
.Activator
/= null);
1415 -- Remove dangling reference to Activator, since a task may
1416 -- outlive its activator.
1418 Self_ID
.Common
.Activator
:= null;
1420 -- Wake up the activator, if it is waiting for a chain of tasks to
1421 -- activate, and we are the last in the chain to complete activation.
1423 if Activator
.Common
.State
= Activator_Sleep
then
1424 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
1426 if Activator
.Common
.Wait_Count
= 0 then
1427 Wakeup
(Activator
, Activator_Sleep
);
1431 -- The activator raises a Tasking_Error if any task it is activating
1432 -- is completed before the activation is done. However, if the reason
1433 -- for the task completion is an abort, we do not raise an exception.
1436 if not Self_ID
.Callable
and then Self_ID
.Pending_ATC_Level
/= 0 then
1437 Activator
.Common
.Activation_Failed
:= True;
1443 -- After the activation, active priority should be the same
1444 -- as base priority. We must unlock the Activator first,
1445 -- though, since it should not wait if we have lower priority.
1447 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
1448 Write_Lock
(Self_ID
);
1449 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
1452 end Vulnerable_Complete_Activation
;
1454 --------------------------------
1455 -- Vulnerable_Complete_Master --
1456 --------------------------------
1458 procedure Vulnerable_Complete_Master
(Self_ID
: Task_Id
) is
1461 CM
: constant Master_Level
:= Self_ID
.Master_Within
;
1462 T
: aliased Task_Id
;
1464 To_Be_Freed
: Task_Id
;
1465 -- This is a list of ATCBs to be freed, after we have released
1466 -- all RTS locks. This is necessary because of the locking order
1467 -- rules, since the storage manager uses Global_Task_Lock.
1469 pragma Warnings
(Off
);
1470 function Check_Unactivated_Tasks
return Boolean;
1471 pragma Warnings
(On
);
1472 -- Temporary error-checking code below. This is part of the checks
1473 -- added in the new run time. Call it only inside a pragma Assert.
1475 -----------------------------
1476 -- Check_Unactivated_Tasks --
1477 -----------------------------
1479 function Check_Unactivated_Tasks
return Boolean is
1481 if not Single_Lock
then
1485 Write_Lock
(Self_ID
);
1487 C
:= All_Tasks_List
;
1488 while C
/= null loop
1489 if C
.Common
.Activator
= Self_ID
and then C
.Master_of_Task
= CM
then
1493 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1496 if C
.Common
.State
= Unactivated
then
1503 C
:= C
.Common
.All_Tasks_Link
;
1508 if not Single_Lock
then
1513 end Check_Unactivated_Tasks
;
1515 -- Start of processing for Vulnerable_Complete_Master
1519 (Debug
.Trace
(Self_ID
, "V_Complete_Master", 'C'));
1521 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1523 (Self_ID
.Deferral_Level
> 0
1524 or else not System
.Restrictions
.Abort_Allowed
);
1526 -- Count how many active dependent tasks this master currently
1527 -- has, and record this in Wait_Count.
1529 -- This count should start at zero, since it is initialized to
1530 -- zero for new tasks, and the task should not exit the
1531 -- sleep-loops that use this count until the count reaches zero.
1533 -- While we're counting, if we run across any unactivated tasks that
1534 -- belong to this master, we summarily terminate them as required by
1538 Write_Lock
(Self_ID
);
1540 C
:= All_Tasks_List
;
1541 while C
/= null loop
1543 -- Terminate unactivated (never-to-be activated) tasks
1545 if C
.Common
.Activator
= Self_ID
and then C
.Master_of_Task
= CM
then
1546 pragma Assert
(C
.Common
.State
= Unactivated
);
1547 -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
1548 -- = CM. The only case where C is pending activation by this
1549 -- task, but the master of C is not CM is in Ada 2005, when C is
1550 -- part of a return object of a build-in-place function.
1553 C
.Common
.Activator
:= null;
1554 C
.Common
.State
:= Terminated
;
1555 C
.Callable
:= False;
1556 Utilities
.Cancel_Queued_Entry_Calls
(C
);
1560 -- Count it if dependent on this master
1562 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1565 if C
.Awake_Count
/= 0 then
1566 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1572 C
:= C
.Common
.All_Tasks_Link
;
1575 Self_ID
.Common
.State
:= Master_Completion_Sleep
;
1578 if not Single_Lock
then
1582 -- Wait until dependent tasks are all terminated or ready to terminate.
1583 -- While waiting, the task may be awakened if the task's priority needs
1584 -- changing, or this master is aborted. In the latter case, we want
1585 -- to abort the dependents, and resume waiting until Wait_Count goes
1588 Write_Lock
(Self_ID
);
1591 exit when Self_ID
.Common
.Wait_Count
= 0;
1593 -- Here is a difference as compared to Complete_Master
1595 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
1596 and then not Self_ID
.Dependents_Aborted
1599 Abort_Dependents
(Self_ID
);
1603 Abort_Dependents
(Self_ID
);
1605 Write_Lock
(Self_ID
);
1608 Sleep
(Self_ID
, Master_Completion_Sleep
);
1612 Self_ID
.Common
.State
:= Runnable
;
1615 -- Dependents are all terminated or on terminate alternatives.
1616 -- Now, force those on terminate alternatives to terminate, by
1619 pragma Assert
(Check_Unactivated_Tasks
);
1621 if Self_ID
.Alive_Count
> 1 then
1623 -- Consider finding a way to skip the following extra steps if there
1624 -- are no dependents with terminate alternatives. This could be done
1625 -- by adding another count to the ATCB, similar to Awake_Count, but
1626 -- keeping track of tasks that are on terminate alternatives.
1628 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1630 -- Force any remaining dependents to terminate by aborting them
1632 if not Single_Lock
then
1636 Abort_Dependents
(Self_ID
);
1638 -- Above, when we "abort" the dependents we are simply using this
1639 -- operation for convenience. We are not required to support the full
1640 -- abort-statement semantics; in particular, we are not required to
1641 -- immediately cancel any queued or in-service entry calls. That is
1642 -- good, because if we tried to cancel a call we would need to lock
1643 -- the caller, in order to wake the caller up. Our anti-deadlock
1644 -- rules prevent us from doing that without releasing the locks on C
1645 -- and Self_ID. Releasing and retaking those locks would be wasteful
1646 -- at best, and should not be considered further without more
1647 -- detailed analysis of potential concurrent accesses to the
1648 -- ATCBs of C and Self_ID.
1650 -- Count how many "alive" dependent tasks this master currently
1651 -- has, and record this in Wait_Count. This count should start at
1652 -- zero, since it is initialized to zero for new tasks, and the
1653 -- task should not exit the sleep-loops that use this count until
1654 -- the count reaches zero.
1656 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1658 Write_Lock
(Self_ID
);
1660 C
:= All_Tasks_List
;
1661 while C
/= null loop
1662 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1665 pragma Assert
(C
.Awake_Count
= 0);
1667 if C
.Alive_Count
> 0 then
1668 pragma Assert
(C
.Terminate_Alternative
);
1669 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1675 C
:= C
.Common
.All_Tasks_Link
;
1678 Self_ID
.Common
.State
:= Master_Phase_2_Sleep
;
1681 if not Single_Lock
then
1685 -- Wait for all counted tasks to finish terminating themselves
1687 Write_Lock
(Self_ID
);
1690 exit when Self_ID
.Common
.Wait_Count
= 0;
1691 Sleep
(Self_ID
, Master_Phase_2_Sleep
);
1694 Self_ID
.Common
.State
:= Runnable
;
1698 -- We don't wake up for abort here. We are already terminating just as
1699 -- fast as we can, so there is no point.
1701 -- Remove terminated tasks from the list of Self_ID's dependents, but
1702 -- don't free their ATCBs yet, because of lock order restrictions,
1703 -- which don't allow us to call "free" or "malloc" while holding any
1704 -- other locks. Instead, we put those ATCBs to be freed onto a
1705 -- temporary list, called To_Be_Freed.
1707 if not Single_Lock
then
1711 C
:= All_Tasks_List
;
1713 while C
/= null loop
1714 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
>= CM
then
1716 P
.Common
.All_Tasks_Link
:= C
.Common
.All_Tasks_Link
;
1718 All_Tasks_List
:= C
.Common
.All_Tasks_Link
;
1721 T
:= C
.Common
.All_Tasks_Link
;
1722 C
.Common
.All_Tasks_Link
:= To_Be_Freed
;
1728 C
:= C
.Common
.All_Tasks_Link
;
1734 -- Free all the ATCBs on the list To_Be_Freed
1736 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1737 -- any interrupt entries are detached from them they should no longer
1740 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1741 -- avoid a race between a terminating task and its parent. The parent
1742 -- might try to deallocate the ACTB out from underneath the exiting
1743 -- task. Note that Free will also lock Global_Task_Lock, but that is
1744 -- OK, since this is the *one* lock for which we have a mechanism to
1745 -- support nested locking. See Task_Wrapper and its finalizer for more
1749 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1750 -- references to terminated library-level tasks, which could
1751 -- otherwise occur during finalization of library-level objects.
1752 -- A better solution might be to hook task objects into the
1753 -- finalization chain and deallocate the ATCB when the task
1754 -- object is deallocated. However, this change is not likely
1755 -- to gain anything significant, since all this storage should
1756 -- be recovered en-masse when the process exits.
1758 while To_Be_Freed
/= null loop
1760 To_Be_Freed
:= T
.Common
.All_Tasks_Link
;
1762 -- ??? On SGI there is currently no Interrupt_Manager, that's
1763 -- why we need to check if the Interrupt_Manager_ID is null
1765 if T
.Interrupt_Entry
and Interrupt_Manager_ID
/= null then
1767 Detach_Interrupt_Entries_Index
: constant Task_Entry_Index
:= 1;
1768 -- Corresponds to the entry index of System.Interrupts.
1769 -- Interrupt_Manager.Detach_Interrupt_Entries.
1770 -- Be sure to update this value when changing
1771 -- Interrupt_Manager specs.
1773 type Param_Type
is access all Task_Id
;
1775 Param
: aliased Param_Type
:= T
'Access;
1778 System
.Tasking
.Rendezvous
.Call_Simple
1779 (Interrupt_Manager_ID
, Detach_Interrupt_Entries_Index
,
1784 if (T
.Common
.Parent
/= null
1785 and then T
.Common
.Parent
.Common
.Parent
/= null)
1786 or else T
.Master_of_Task
> Library_Task_Level
1788 Initialization
.Task_Lock
(Self_ID
);
1790 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1791 -- has not been called yet (case of an unactivated task).
1793 if T
.Common
.Compiler_Data
.Sec_Stack_Addr
/= Null_Address
then
1794 SSL
.Destroy_TSD
(T
.Common
.Compiler_Data
);
1797 Vulnerable_Free_Task
(T
);
1798 Initialization
.Task_Unlock
(Self_ID
);
1802 -- It might seem nice to let the terminated task deallocate its own
1803 -- ATCB. That would not cover the case of unactivated tasks. It also
1804 -- would force us to keep the underlying thread around past termination,
1805 -- since references to the ATCB are possible past termination.
1806 -- Currently, we get rid of the thread as soon as the task terminates,
1807 -- and let the parent recover the ATCB later.
1809 -- Some day, if we want to recover the ATCB earlier, at task
1810 -- termination, we could consider using "fat task IDs", that include the
1811 -- serial number with the ATCB pointer, to catch references to tasks
1812 -- that no longer have ATCBs. It is not clear how much this would gain,
1813 -- since the user-level task object would still be occupying storage.
1815 -- Make next master level up active.
1816 -- We don't need to lock the ATCB, since the value is only updated by
1817 -- each task for itself.
1819 Self_ID
.Master_Within
:= CM
- 1;
1820 end Vulnerable_Complete_Master
;
1822 ------------------------------
1823 -- Vulnerable_Complete_Task --
1824 ------------------------------
1826 -- Complete the calling task
1828 -- This procedure must be called with abort deferred. It should only be
1829 -- called by Complete_Task and Finalize_Global_Tasks (for the environment
1832 -- The effect is similar to that of Complete_Master. Differences include
1833 -- the closing of entries here, and computation of the number of active
1834 -- dependent tasks in Complete_Master.
1836 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1837 -- because that does its own locking, and because we do not need the lock
1838 -- to test Self_ID.Common.Activator. That value should only be read and
1839 -- modified by Self.
1841 procedure Vulnerable_Complete_Task
(Self_ID
: Task_Id
) is
1844 (Self_ID
.Deferral_Level
> 0
1845 or else not System
.Restrictions
.Abort_Allowed
);
1846 pragma Assert
(Self_ID
= Self
);
1847 pragma Assert
(Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 1
1849 Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 2);
1850 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1851 pragma Assert
(Self_ID
.Open_Accepts
= null);
1852 pragma Assert
(Self_ID
.ATC_Nesting_Level
= 1);
1854 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Task", 'C'));
1860 Write_Lock
(Self_ID
);
1861 Self_ID
.Callable
:= False;
1863 -- In theory, Self should have no pending entry calls left on its
1864 -- call-stack. Each async. select statement should clean its own call,
1865 -- and blocking entry calls should defer abort until the calls are
1866 -- cancelled, then clean up.
1868 Utilities
.Cancel_Queued_Entry_Calls
(Self_ID
);
1871 if Self_ID
.Common
.Activator
/= null then
1872 Vulnerable_Complete_Activation
(Self_ID
);
1879 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
1880 -- we may have dependent tasks for which we need to wait.
1881 -- Otherwise, we can just exit.
1883 if Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 2 then
1884 Vulnerable_Complete_Master
(Self_ID
);
1886 end Vulnerable_Complete_Task
;
1888 --------------------------
1889 -- Vulnerable_Free_Task --
1890 --------------------------
1892 -- Recover all runtime system storage associated with the task T.
1893 -- This should only be called after T has terminated and will no
1894 -- longer be referenced.
1896 -- For tasks created by an allocator that fails, due to an exception,
1897 -- it is called from Expunge_Unactivated_Tasks.
1899 -- For tasks created by elaboration of task object declarations it
1900 -- is called from the finalization code of the Task_Wrapper procedure.
1901 -- It is also called from Ada.Unchecked_Deallocation, for objects that
1902 -- are or contain tasks.
1904 procedure Vulnerable_Free_Task
(T
: Task_Id
) is
1906 pragma Debug
(Debug
.Trace
(Self
, "Vulnerable_Free_Task", 'C', T
));
1913 Initialization
.Finalize_Attributes_Link
.all (T
);
1920 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
1921 end Vulnerable_Free_Task
;
1923 -- Package elaboration code
1926 -- Establish the Adafinal softlink
1928 -- This is not done inside the central RTS initialization routine
1929 -- to avoid with-ing this package from System.Tasking.Initialization.
1931 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
1933 -- Establish soft links for subprograms that manipulate master_id's.
1934 -- This cannot be done when the RTS is initialized, because of various
1935 -- elaboration constraints.
1937 SSL
.Current_Master
:= Stages
.Current_Master
'Access;
1938 SSL
.Enter_Master
:= Stages
.Enter_Master
'Access;
1939 SSL
.Complete_Master
:= Stages
.Complete_Master
'Access;
1940 end System
.Tasking
.Stages
;