1 ------------------------------------------------------------------------------
3 -- GNU ADA 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 --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
36 -- Turn off polling, we do not want ATC polling to take place during
37 -- tasking operations. It causes infinite loops and other problems.
40 -- used for Raise_Exception
42 with System
.Tasking
.Debug
;
43 pragma Warnings
(Off
, System
.Tasking
.Debug
);
44 -- used for enabling tasking facilities with gdb
46 with System
.Address_Image
;
47 -- used for the function itself.
49 with System
.Parameters
;
54 with System
.Task_Info
;
55 -- used for Task_Info_Type
58 with System
.Task_Primitives
.Operations
;
59 -- used for Finalize_Lock
69 with System
.Soft_Links
;
70 -- These are procedure pointers to non-tasking routines that use
71 -- task specific data. In the absence of tasking, these routines
72 -- refer to global data. In the presense of tasking, they must be
73 -- replaced with pointers to task-specific versions.
74 -- Also used for Create_TSD, Destroy_TSD, Get_Current_Excep
76 with System
.Tasking
.Initialization
;
77 -- Used for Remove_From_All_Tasks_List
80 -- Initialization.Poll_Base_Priority_Change
81 -- Finalize_Attributes_Link
82 -- Initialize_Attributes_Link
84 pragma Elaborate_All
(System
.Tasking
.Initialization
);
85 -- This insures that tasking is initialized if any tasks are created.
87 with System
.Tasking
.Utilities
;
88 -- Used for Make_Passive
91 with System
.Tasking
.Queuing
;
92 -- Used for Dequeue_Head
94 with System
.Tasking
.Rendezvous
;
95 -- Used for Call_Simple
97 with System
.OS_Primitives
;
98 -- Used for Delay_Modes
100 with System
.Finalization_Implementation
;
101 -- Used for System.Finalization_Implementation.Finalize_Global_List
104 -- Used for type Unsigned.
106 with System
.Secondary_Stack
;
109 with System
.Storage_Elements
;
110 -- used for Storage_Array;
112 with System
.Standard_Library
;
113 -- used for Exception_Trace
115 with System
.Traces
.Tasking
;
116 -- used for Send_Trace_Info
118 package body System
.Tasking
.Stages
is
120 package STPO
renames System
.Task_Primitives
.Operations
;
121 package SSL
renames System
.Soft_Links
;
122 package SSE
renames System
.Storage_Elements
;
123 package SST
renames System
.Secondary_Stack
;
129 use Task_Primitives
.Operations
;
133 use System
.Traces
.Tasking
;
135 -----------------------
136 -- Local Subprograms --
137 -----------------------
139 procedure Notify_Exception
141 Excep
: Exception_Occurrence
);
142 -- This procedure will output the task ID and the exception information,
143 -- including traceback if available.
145 procedure Task_Wrapper
(Self_ID
: Task_ID
);
146 -- This is the procedure that is called by the GNULL from the
147 -- new context when a task is created. It waits for activation
148 -- and then calls the task body procedure. When the task body
149 -- procedure completes, it terminates the task.
151 procedure Vulnerable_Complete_Task
(Self_ID
: Task_ID
);
152 -- Complete the calling task.
153 -- This procedure must be called with abort deferred.
154 -- 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.
159 -- This procedure must be called with abort deferred.
160 -- It should only be called by Vulnerable_Complete_Task and
163 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_ID
);
164 -- Signal to Self_ID's activator that Self_ID has
165 -- completed activation.
167 -- Call this procedure with abort deferred.
169 procedure Abort_Dependents
(Self_ID
: Task_ID
);
170 -- Abort all the direct dependents of Self at its current master
171 -- nesting level, plus all of their dependents, transitively.
172 -- RTS_Lock should be locked by the caller.
174 procedure Vulnerable_Free_Task
(T
: Task_ID
);
175 -- Recover all runtime system storage associated with the task T.
176 -- This should only be called after T has terminated and will no
177 -- longer be referenced.
179 -- For tasks created by an allocator that fails, due to an exception,
180 -- it is called from Expunge_Unactivated_Tasks.
182 -- It is also called from Unchecked_Deallocation, for objects that
183 -- are or contain tasks.
185 -- Different code is used at master completion, in Terminate_Dependents,
186 -- due to a need for tighter synchronization with the master.
188 procedure Terminate_Task
(Self_ID
: Task_ID
);
189 -- Terminate the calling task.
190 -- This should only be called by the Task_Wrapper procedure.
192 ----------------------
193 -- Abort_Dependents --
194 ----------------------
196 procedure Abort_Dependents
(Self_ID
: Task_ID
) is
204 P
:= C
.Common
.Parent
;
208 -- ??? C is supposed to take care of its own dependents, so
209 -- there should be no need to worry about them. Need to double
212 if C
.Master_of_Task
= Self_ID
.Master_Within
then
213 Utilities
.Abort_One_Task
(Self_ID
, C
);
214 C
.Dependents_Aborted
:= True;
220 P
:= P
.Common
.Parent
;
223 C
:= C
.Common
.All_Tasks_Link
;
226 Self_ID
.Dependents_Aborted
:= True;
227 end Abort_Dependents
;
233 procedure Abort_Tasks
(Tasks
: Task_List
) is
235 Utilities
.Abort_Tasks
(Tasks
);
242 -- Note that locks of activator and activated task are both locked
243 -- here. This is necessary because C.Common.State and
244 -- Self.Common.Wait_Count have to be synchronized. This is safe from
245 -- deadlock because the activator is always created before the activated
246 -- task. That satisfies our in-order-of-creation ATCB locking policy.
248 -- At one point, we may also lock the parent, if the parent is
249 -- different from the activator. That is also consistent with the
250 -- lock ordering policy, since the activator cannot be created
251 -- before the parent.
253 -- Since we are holding both the activator's lock, and Task_Wrapper
254 -- locks that before it does anything more than initialize the
255 -- low-level ATCB components, it should be safe to wait to update
256 -- the counts until we see that the thread creation is successful.
258 -- If the thread creation fails, we do need to close the entries
259 -- of the task. The first phase, of dequeuing calls, only requires
260 -- locking the acceptor's ATCB, but the waking up of the callers
261 -- requires locking the caller's ATCB. We cannot safely do this
262 -- while we are holding other locks. Therefore, the queue-clearing
263 -- operation is done in a separate pass over the activation chain.
265 procedure Activate_Tasks
(Chain_Access
: Activation_Chain_Access
) is
266 Self_ID
: constant Task_ID
:= STPO
.Self
;
269 Next_C
, Last_C
: Task_ID
;
270 Activate_Prio
: System
.Any_Priority
;
272 All_Elaborated
: Boolean := True;
276 (Debug
.Trace
(Self_ID
, "Activate_Tasks", 'C'));
278 Initialization
.Defer_Abort_Nestable
(Self_ID
);
280 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
282 -- Lock RTS_Lock, to prevent activated tasks
283 -- from racing ahead before we finish activating the chain.
287 -- Check that all task bodies have been elaborated.
289 C
:= Chain_Access
.T_ID
;
293 if C
.Common
.Elaborated
/= null
294 and then not C
.Common
.Elaborated
.all
296 All_Elaborated
:= False;
299 -- Reverse the activation chain so that tasks are
300 -- activated in the same order they're declared.
302 Next_C
:= C
.Common
.Activation_Link
;
303 C
.Common
.Activation_Link
:= Last_C
;
308 Chain_Access
.T_ID
:= Last_C
;
310 if not All_Elaborated
then
312 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
314 (Program_Error
'Identity, "Some tasks have not been elaborated");
317 -- Activate all the tasks in the chain.
318 -- Creation of the thread of control was deferred until
319 -- activation. So create it now.
321 C
:= Chain_Access
.T_ID
;
324 if C
.Common
.State
/= Terminated
then
325 pragma Assert
(C
.Common
.State
= Unactivated
);
327 P
:= C
.Common
.Parent
;
331 if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
) then
332 Activate_Prio
:= Get_Priority
(Self_ID
);
334 Activate_Prio
:= C
.Common
.Base_Priority
;
337 System
.Task_Primitives
.Operations
.Create_Task
338 (C
, Task_Wrapper
'Address,
340 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
341 Activate_Prio
, Success
);
343 -- There would be a race between the created task and
344 -- the creator to do the following initialization,
345 -- if we did not have a Lock/Unlock_RTS pair
346 -- in the task wrapper, to prevent it from racing ahead.
349 C
.Common
.State
:= Runnable
;
352 P
.Awake_Count
:= P
.Awake_Count
+ 1;
353 P
.Alive_Count
:= P
.Alive_Count
+ 1;
355 if P
.Common
.State
= Master_Completion_Sleep
and then
356 C
.Master_of_Task
= P
.Master_Within
358 pragma Assert
(Self_ID
/= P
);
359 P
.Common
.Wait_Count
:= P
.Common
.Wait_Count
+ 1;
366 -- No need to set Awake_Count, State, etc. here since the loop
367 -- below will do that for any Unactivated tasks.
371 Self_ID
.Common
.Activation_Failed
:= True;
375 C
:= C
.Common
.Activation_Link
;
378 if not Single_Lock
then
382 -- Close the entries of any tasks that failed thread creation,
383 -- and count those that have not finished activation.
385 Write_Lock
(Self_ID
);
386 Self_ID
.Common
.State
:= Activator_Sleep
;
388 C
:= Chain_Access
.T_ID
;
392 if C
.Common
.State
= Unactivated
then
393 C
.Common
.Activator
:= null;
394 C
.Common
.State
:= Terminated
;
396 Utilities
.Cancel_Queued_Entry_Calls
(C
);
398 elsif C
.Common
.Activator
/= null then
399 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
403 P
:= C
.Common
.Activation_Link
;
404 C
.Common
.Activation_Link
:= null;
408 -- Wait for the activated tasks to complete activation.
409 -- It is unsafe to abort any of these tasks until the count goes to
413 Initialization
.Poll_Base_Priority_Change
(Self_ID
);
414 exit when Self_ID
.Common
.Wait_Count
= 0;
415 Sleep
(Self_ID
, Activator_Sleep
);
418 Self_ID
.Common
.State
:= Runnable
;
425 -- Remove the tasks from the chain.
427 Chain_Access
.T_ID
:= null;
428 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
430 if Self_ID
.Common
.Activation_Failed
then
431 Self_ID
.Common
.Activation_Failed
:= False;
432 Raise_Exception
(Tasking_Error
'Identity,
433 "Failure during activation");
437 -------------------------
438 -- Complete_Activation --
439 -------------------------
441 procedure Complete_Activation
is
442 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
: Task_ID
:= STPO
.Self
;
474 pragma Assert
(Self_ID
.Deferral_Level
> 0);
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
;
488 pragma Assert
(Self_ID
.Deferral_Level
> 0);
490 Vulnerable_Complete_Task
(Self_ID
);
492 -- All of our dependents have terminated.
493 -- Never undefer abort again!
500 -- Compiler interface only. Do not call from within the RTS.
501 -- This must be called to create a new task.
503 procedure Create_Task
505 Size
: System
.Parameters
.Size_Type
;
506 Task_Info
: System
.Task_Info
.Task_Info_Type
;
507 Num_Entries
: Task_Entry_Index
;
508 Master
: Master_Level
;
509 State
: Task_Procedure_Access
;
510 Discriminants
: System
.Address
;
511 Elaborated
: Access_Boolean
;
512 Chain
: in out Activation_Chain
;
513 Task_Image
: System
.Task_Info
.Task_Image_Type
;
514 Created_Task
: out Task_ID
)
517 Self_ID
: constant Task_ID
:= STPO
.Self
;
519 Base_Priority
: System
.Any_Priority
;
523 (Debug
.Trace
(Self_ID
, "Create_Task", 'C'));
525 if Priority
= Unspecified_Priority
then
526 Base_Priority
:= Self_ID
.Common
.Base_Priority
;
528 Base_Priority
:= System
.Any_Priority
(Priority
);
531 -- Find parent P of new Task, via master level number.
536 while P
.Master_of_Task
>= Master
loop
537 P
:= P
.Common
.Parent
;
542 Initialization
.Defer_Abort_Nestable
(Self_ID
);
545 T
:= New_ATCB
(Num_Entries
);
549 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
550 Raise_Exception
(Storage_Error
'Identity, "Cannot allocate task");
553 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks.
554 -- Up to this point, it is possible that we may be part of
555 -- a family of tasks that is being aborted.
558 Write_Lock
(Self_ID
);
560 -- Now, we must check that we have not been aborted.
561 -- If so, we should give up on creating this task,
562 -- and simply return.
564 if not Self_ID
.Callable
then
565 pragma Assert
(Self_ID
.Pending_ATC_Level
= 0);
566 pragma Assert
(Self_ID
.Pending_Action
);
567 pragma Assert
(Chain
.T_ID
= null
568 or else Chain
.T_ID
.Common
.State
= Unactivated
);
572 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
574 -- ??? Should never get here
576 pragma Assert
(False);
577 raise Standard
'Abort_Signal;
580 Initialize_ATCB
(Self_ID
, State
, Discriminants
, P
, Elaborated
,
581 Base_Priority
, Task_Info
, Size
, T
, Success
);
586 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
588 (Storage_Error
'Identity, "Failed to initialize task");
591 T
.Master_of_Task
:= Master
;
592 T
.Master_Within
:= T
.Master_of_Task
+ 1;
594 for L
in T
.Entry_Calls
'Range loop
595 T
.Entry_Calls
(L
).Self
:= T
;
596 T
.Entry_Calls
(L
).Level
:= L
;
599 T
.Common
.Task_Image
:= Task_Image
;
603 -- Create TSD as early as possible in the creation of a task, since it
604 -- may be used by the operation of Ada code within the task.
606 SSL
.Create_TSD
(T
.Common
.Compiler_Data
);
607 T
.Common
.Activation_Link
:= Chain
.T_ID
;
609 Initialization
.Initialize_Attributes_Link
.all (T
);
611 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
613 if Runtime_Traces
then
614 Send_Trace_Info
(T_Create
, T
);
622 function Current_Master
return Master_Level
is
624 return STPO
.Self
.Master_Within
;
631 procedure Enter_Master
is
632 Self_ID
: constant Task_ID
:= STPO
.Self
;
635 Self_ID
.Master_Within
:= Self_ID
.Master_Within
+ 1;
638 -------------------------------
639 -- Expunge_Unactivated_Tasks --
640 -------------------------------
642 -- See procedure Close_Entries for the general case.
644 procedure Expunge_Unactivated_Tasks
(Chain
: in out Activation_Chain
) is
645 Self_ID
: constant Task_ID
:= STPO
.Self
;
647 Call
: Entry_Call_Link
;
652 (Debug
.Trace
(Self_ID
, "Expunge_Unactivated_Tasks", 'C'));
654 Initialization
.Defer_Abort_Nestable
(Self_ID
);
657 -- Experimentation has shown that abort is sometimes (but not
658 -- always) already deferred when this is called.
659 -- That may indicate an error. Find out what is going on.
664 pragma Assert
(C
.Common
.State
= Unactivated
);
666 Temp
:= C
.Common
.Activation_Link
;
668 if C
.Common
.State
= Unactivated
then
672 for J
in 1 .. C
.Entry_Num
loop
673 Queuing
.Dequeue_Head
(C
.Entry_Queues
(J
), Call
);
674 pragma Assert
(Call
= null);
679 Initialization
.Remove_From_All_Tasks_List
(C
);
682 Vulnerable_Free_Task
(C
);
688 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
689 end Expunge_Unactivated_Tasks
;
691 ---------------------------
692 -- Finalize_Global_Tasks --
693 ---------------------------
696 -- We have a potential problem here if finalization of global
697 -- objects does anything with signals or the timer server, since
698 -- by that time those servers have terminated.
700 -- It is hard to see how that would occur.
702 -- However, a better solution might be to do all this finalization
703 -- using the global finalization chain.
705 procedure Finalize_Global_Tasks
is
706 Self_ID
: constant Task_ID
:= STPO
.Self
;
710 if Self_ID
.Deferral_Level
= 0 then
712 -- In principle, we should be able to predict whether
713 -- abort is already deferred here (and it should not be deferred
714 -- yet but in practice it seems Finalize_Global_Tasks is being
715 -- called sometimes, from RTS code for exceptions, with abort already
718 Initialization
.Defer_Abort_Nestable
(Self_ID
);
720 -- Never undefer again!!!
723 -- This code is only executed by the environment task
725 pragma Assert
(Self_ID
= Environment_Task
);
727 -- Set Environment_Task'Callable to false to notify library-level tasks
728 -- that it is waiting for them (cf 5619-003).
730 Self_ID
.Callable
:= False;
732 -- Exit level 2 master, for normal tasks in library-level packages.
736 -- Force termination of "independent" library-level server tasks.
740 Abort_Dependents
(Self_ID
);
742 if not Single_Lock
then
746 -- We need to explicitly wait for the task to be
747 -- terminated here because on true concurrent system, we
748 -- may end this procedure before the tasks are really
751 Write_Lock
(Self_ID
);
754 exit when Utilities
.Independent_Task_Count
= 0;
756 -- We used to yield here, but this did not take into account
757 -- low priority tasks that would cause dead lock in some cases.
761 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
762 Self_ID
.Common
.State
, Ignore
, Ignore
);
765 -- ??? On multi-processor environments, it seems that the above loop
766 -- isn't sufficient, so we need to add an additional delay.
769 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
770 Self_ID
.Common
.State
, Ignore
, Ignore
);
778 -- Complete the environment task.
780 Vulnerable_Complete_Task
(Self_ID
);
782 System
.Finalization_Implementation
.Finalize_Global_List
;
784 SSL
.Abort_Defer
:= SSL
.Abort_Defer_NT
'Access;
785 SSL
.Abort_Undefer
:= SSL
.Abort_Undefer_NT
'Access;
786 SSL
.Lock_Task
:= SSL
.Task_Lock_NT
'Access;
787 SSL
.Unlock_Task
:= SSL
.Task_Unlock_NT
'Access;
788 SSL
.Get_Jmpbuf_Address
:= SSL
.Get_Jmpbuf_Address_NT
'Access;
789 SSL
.Set_Jmpbuf_Address
:= SSL
.Set_Jmpbuf_Address_NT
'Access;
790 SSL
.Get_Sec_Stack_Addr
:= SSL
.Get_Sec_Stack_Addr_NT
'Access;
791 SSL
.Set_Sec_Stack_Addr
:= SSL
.Set_Sec_Stack_Addr_NT
'Access;
792 SSL
.Get_Exc_Stack_Addr
:= SSL
.Get_Exc_Stack_Addr_NT
'Access;
793 SSL
.Set_Exc_Stack_Addr
:= SSL
.Set_Exc_Stack_Addr_NT
'Access;
794 SSL
.Check_Abort_Status
:= SSL
.Check_Abort_Status_NT
'Access;
795 SSL
.Get_Stack_Info
:= SSL
.Get_Stack_Info_NT
'Access;
797 -- Don't bother trying to finalize Initialization.Global_Task_Lock
798 -- and System.Task_Primitives.RTS_Lock.
800 end Finalize_Global_Tasks
;
806 procedure Free_Task
(T
: Task_ID
) is
807 Self_Id
: constant Task_ID
:= Self
;
810 if T
.Common
.State
= Terminated
then
811 -- It is not safe to call Abort_Defer or Write_Lock at this stage
813 Initialization
.Task_Lock
(Self_Id
);
815 if T
.Common
.Task_Image
/= null then
816 Free_Task_Image
(T
.Common
.Task_Image
);
820 Initialization
.Remove_From_All_Tasks_List
(T
);
823 Initialization
.Task_Unlock
(Self_Id
);
825 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
827 -- If the task is not terminated, then we simply ignore the call. This
828 -- happens when a user program attempts an unchecked deallocation on
829 -- a non-terminated task.
836 ----------------------
837 -- Notify_Exception --
838 ----------------------
840 procedure Notify_Exception
842 Excep
: Exception_Occurrence
)
844 procedure To_Stderr
(S
: String);
845 pragma Import
(Ada
, To_Stderr
, "__gnat_to_stderr");
847 use System
.Task_Info
;
848 use System
.Soft_Links
;
850 function To_Address
is new
851 Unchecked_Conversion
(Task_ID
, System
.Address
);
853 function Tailored_Exception_Information
854 (E
: Exception_Occurrence
) return String;
856 (Ada
, Tailored_Exception_Information
,
857 "__gnat_tailored_exception_information");
862 if Self_Id
.Common
.Task_Image
/= null then
863 To_Stderr
(Self_Id
.Common
.Task_Image
.all);
867 To_Stderr
(System
.Address_Image
(To_Address
(Self_Id
)));
868 To_Stderr
(" terminated by unhandled exception");
869 To_Stderr
((1 => ASCII
.LF
));
870 To_Stderr
(Tailored_Exception_Information
(Excep
));
871 end Notify_Exception
;
877 -- The task wrapper is a procedure that is called first for each task
878 -- task body, and which in turn calls the compiler-generated task body
879 -- procedure. The wrapper's main job is to do initialization for the task.
880 -- It also has some locally declared objects that server as per-task local
881 -- data. Task finalization is done by Complete_Task, which is called from
882 -- an at-end handler that the compiler generates.
884 -- The variable ID in the task wrapper is used to implement the Self
885 -- function on targets where there is a fast way to find the stack base
886 -- of the current thread, since it should be at a fixed offset from the
889 -- The variable Magic_Number is also used in such implementations
890 -- of Self, to check whether the current task is an Ada task, as
891 -- compared to other-language threads.
893 -- Both act as constants, once initialized, but need to be marked as
894 -- volatile or aliased to prevent the compiler from optimizing away the
895 -- storage. See System.Task_Primitives.Operations.Self for more info.
897 procedure Task_Wrapper
(Self_ID
: Task_ID
) is
898 ID
: Task_ID
:= Self_ID
;
899 pragma Volatile
(ID
);
900 -- Do not delete this variable.
901 -- In some targets, we need this variable to implement a fast Self.
903 Magic_Number
: Interfaces
.C
.unsigned
:= 16#ADAADAAD#
;
904 pragma Volatile
(Magic_Number
);
905 -- We use this to verify that we are looking at an Ada task,
906 -- inside of System.Task_Primitives.Operations.Self.
908 use type System
.Parameters
.Size_Type
;
909 use type SSE
.Storage_Offset
;
910 use System
.Standard_Library
;
912 Secondary_Stack
: aliased SSE
.Storage_Array
913 (1 .. ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
*
914 SSE
.Storage_Offset
(Parameters
.Sec_Stack_Ratio
) / 100);
915 Secondary_Stack_Address
: System
.Address
:= Secondary_Stack
'Address;
918 pragma Assert
(Self_ID
.Deferral_Level
= 1);
920 if not Parameters
.Sec_Stack_Dynamic
then
921 ID
.Common
.Compiler_Data
.Sec_Stack_Addr
:= Secondary_Stack
'Address;
922 SST
.SS_Init
(Secondary_Stack_Address
, Integer (Secondary_Stack
'Last));
925 -- Set the guard page at the bottom of the stack.
926 -- The call to unprotect the page is done in Terminate_Task
928 Stack_Guard
(Self_ID
, True);
930 -- Initialize low-level TCB components, that
931 -- cannot be initialized by the creator.
932 -- Enter_Task sets Self_ID.Known_Tasks_Index
933 -- and Self_ID.LL.Thread
935 Enter_Task
(Self_ID
);
937 -- We lock RTS_Lock to wait for activator to finish activating
938 -- the rest of the chain, so that everyone in the chain comes out
939 -- in priority order.
940 -- This also protects the value of
941 -- Self_ID.Common.Activator.Common.Wait_Count.
947 -- We are separating the following portion of the code in order to
948 -- place the exception handlers in a different block.
949 -- In this way we do not call Set_Jmpbuf_Address (which needs
950 -- Self) before we set Self in Enter_Task
952 -- Call the task body procedure.
954 -- The task body is called with abort still deferred. That
955 -- eliminates a dangerous window, for which we had to patch-up in
957 -- During the expansion of the task body, we insert an RTS-call
958 -- to Abort_Undefer, at the first point where abort should be
961 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
962 Terminate_Task
(Self_ID
);
965 when Standard
'Abort_Signal =>
966 Terminate_Task
(Self_ID
);
969 -- ??? Using an E : others here causes CD2C11A to fail on
970 -- DEC Unix, see 7925-005.
972 if Exception_Trace
= Unhandled_Raise
then
973 Notify_Exception
(Self_ID
, SSL
.Get_Current_Excep
.all.all);
976 Terminate_Task
(Self_ID
);
984 -- Before we allow the thread to exit, we must clean up. This is a
985 -- a delicate job. We must wake up the task's master, who may immediately
986 -- try to deallocate the ATCB out from under the current task WHILE IT IS
989 -- To avoid this, the parent task must be blocked up to the last thing
990 -- done before the call to Exit_Task. The trouble is that we have another
991 -- step that we also want to postpone to the very end, i.e., calling
992 -- SSL.Destroy_TSD. We have to postpone that until the end because
993 -- compiler-generated code is likely to try to access that data at just
996 -- We can't call Destroy_TSD while we are holding any other locks, because
997 -- it locks Global_Task_Lock, and our deadlock prevention rules require
998 -- that to be the outermost lock. Our first "solution" was to just lock
999 -- Global_Task_Lock in addition to the other locks, and force the parent
1000 -- to also lock this lock between its wakeup and its freeing of the ATCB.
1001 -- See Complete_Task for the parent-side of the code that has the matching
1002 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1003 -- since the operation Task_Unlock continued to access the ATCB after
1004 -- unlocking, after which the parent was observed to race ahead,
1005 -- deallocate the ATCB, and then reallocate it to another task. The
1006 -- call to Undefer_Abortion in Task_Unlock by the "terminated" task was
1007 -- overwriting the data of the new task that reused the ATCB! To solve
1008 -- this problem, we introduced the new operation Final_Task_Unlock.
1010 procedure Terminate_Task
(Self_ID
: Task_ID
) is
1011 Environment_Task
: constant Task_ID
:= STPO
.Environment_Task
;
1014 if Runtime_Traces
then
1015 Send_Trace_Info
(T_Terminate
);
1018 -- Since GCC cannot allocate stack chunks efficiently without reordering
1019 -- some of the allocations, we have to handle this unexpected situation
1020 -- here. We should normally never have to call Vulnerable_Complete_Task
1021 -- here. See 6602-003 for more details.
1023 if Self_ID
.Common
.Activator
/= null then
1024 Vulnerable_Complete_Task
(Self_ID
);
1027 Initialization
.Task_Lock
(Self_ID
);
1033 -- Check if the current task is an independent task
1034 -- If so, decrement the Independent_Task_Count value.
1036 if Self_ID
.Master_of_Task
= 2 then
1038 Utilities
.Independent_Task_Count
:=
1039 Utilities
.Independent_Task_Count
- 1;
1042 Write_Lock
(Environment_Task
);
1043 Utilities
.Independent_Task_Count
:=
1044 Utilities
.Independent_Task_Count
- 1;
1045 Unlock
(Environment_Task
);
1049 -- Unprotect the guard page if needed.
1051 Stack_Guard
(Self_ID
, False);
1053 Utilities
.Make_Passive
(Self_ID
, Task_Completed
=> True);
1059 pragma Assert
(Check_Exit
(Self_ID
));
1061 SSL
.Destroy_TSD
(Self_ID
.Common
.Compiler_Data
);
1062 Initialization
.Final_Task_Unlock
(Self_ID
);
1065 -- past this point, this thread must assume that the ATCB
1066 -- has been deallocated. It should not be accessed again.
1075 function Terminated
(T
: Task_ID
) return Boolean is
1077 Self_ID
: Task_ID
:= STPO
.Self
;
1080 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1087 Result
:= T
.Common
.State
= Terminated
;
1094 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
1098 ------------------------------------
1099 -- Vulnerable_Complete_Activation --
1100 ------------------------------------
1102 -- As in several other places, the locks of the activator and activated
1103 -- task are both locked here. This follows our deadlock prevention lock
1104 -- ordering policy, since the activated task must be created after the
1107 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_ID
) is
1108 Activator
: constant Task_ID
:= Self_ID
.Common
.Activator
;
1111 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Activation", 'C'));
1113 Write_Lock
(Activator
);
1114 Write_Lock
(Self_ID
);
1116 pragma Assert
(Self_ID
.Common
.Activator
/= null);
1118 -- Remove dangling reference to Activator,
1119 -- since a task may outlive its activator.
1121 Self_ID
.Common
.Activator
:= null;
1123 -- Wake up the activator, if it is waiting for a chain
1124 -- of tasks to activate, and we are the last in the chain
1125 -- to complete activation
1127 if Activator
.Common
.State
= Activator_Sleep
then
1128 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
1130 if Activator
.Common
.Wait_Count
= 0 then
1131 Wakeup
(Activator
, Activator_Sleep
);
1135 -- The activator raises a Tasking_Error if any task
1136 -- it is activating is completed before the activation is
1137 -- done. However, if the reason for the task completion is
1138 -- an abortion, we do not raise an exception. ARM 9.2(5).
1140 if not Self_ID
.Callable
and then Self_ID
.Pending_ATC_Level
/= 0 then
1141 Activator
.Common
.Activation_Failed
:= True;
1147 -- After the activation, active priority should be the same
1148 -- as base priority. We must unlock the Activator first,
1149 -- though, since it should not wait if we have lower priority.
1151 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
1152 Write_Lock
(Self_ID
);
1153 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
1156 end Vulnerable_Complete_Activation
;
1158 --------------------------------
1159 -- Vulnerable_Complete_Master --
1160 --------------------------------
1162 procedure Vulnerable_Complete_Master
(Self_ID
: Task_ID
) is
1165 CM
: Master_Level
:= Self_ID
.Master_Within
;
1166 T
: aliased Task_ID
;
1168 To_Be_Freed
: Task_ID
;
1169 -- This is a list of ATCBs to be freed, after we have released
1170 -- all RTS locks. This is necessary because of the locking order
1171 -- rules, since the storage manager uses Global_Task_Lock.
1173 pragma Warnings
(Off
);
1174 function Check_Unactivated_Tasks
return Boolean;
1175 pragma Warnings
(On
);
1176 -- Temporary error-checking code below. This is part of the checks
1177 -- added in the new run time. Call it only inside a pragma Assert.
1179 -----------------------------
1180 -- Check_Unactivated_Tasks --
1181 -----------------------------
1183 function Check_Unactivated_Tasks
return Boolean is
1185 if not Single_Lock
then
1189 Write_Lock
(Self_ID
);
1190 C
:= All_Tasks_List
;
1192 while C
/= null loop
1193 if C
.Common
.Activator
= Self_ID
then
1197 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1200 if C
.Common
.State
= Unactivated
then
1207 C
:= C
.Common
.All_Tasks_Link
;
1212 if not Single_Lock
then
1217 end Check_Unactivated_Tasks
;
1219 -- Start of processing for Vulnerable_Complete_Master
1223 (Debug
.Trace
(Self_ID
, "V_Complete_Master", 'C'));
1225 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1226 pragma Assert
(Self_ID
.Deferral_Level
> 0);
1228 -- Count how many active dependent tasks this master currently
1229 -- has, and record this in Wait_Count.
1231 -- This count should start at zero, since it is initialized to
1232 -- zero for new tasks, and the task should not exit the
1233 -- sleep-loops that use this count until the count reaches zero.
1236 Write_Lock
(Self_ID
);
1237 C
:= All_Tasks_List
;
1239 while C
/= null loop
1240 if C
.Common
.Activator
= Self_ID
then
1241 pragma Assert
(C
.Common
.State
= Unactivated
);
1244 C
.Common
.Activator
:= null;
1245 C
.Common
.State
:= Terminated
;
1246 C
.Callable
:= False;
1247 Utilities
.Cancel_Queued_Entry_Calls
(C
);
1251 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1254 if C
.Awake_Count
/= 0 then
1255 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1261 C
:= C
.Common
.All_Tasks_Link
;
1264 Self_ID
.Common
.State
:= Master_Completion_Sleep
;
1267 if not Single_Lock
then
1271 -- Wait until dependent tasks are all terminated or ready to terminate.
1272 -- While waiting, the task may be awakened if the task's priority needs
1273 -- changing, or this master is aborted. In the latter case, we want
1274 -- to abort the dependents, and resume waiting until Wait_Count goes
1277 Write_Lock
(Self_ID
);
1280 Initialization
.Poll_Base_Priority_Change
(Self_ID
);
1281 exit when Self_ID
.Common
.Wait_Count
= 0;
1283 -- Here is a difference as compared to Complete_Master
1285 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
1286 and then not Self_ID
.Dependents_Aborted
1289 Abort_Dependents
(Self_ID
);
1293 Abort_Dependents
(Self_ID
);
1295 Write_Lock
(Self_ID
);
1298 Sleep
(Self_ID
, Master_Completion_Sleep
);
1302 Self_ID
.Common
.State
:= Runnable
;
1305 -- Dependents are all terminated or on terminate alternatives.
1306 -- Now, force those on terminate alternatives to terminate, by
1309 pragma Assert
(Check_Unactivated_Tasks
);
1311 if Self_ID
.Alive_Count
> 1 then
1313 -- Consider finding a way to skip the following extra steps if there
1314 -- are no dependents with terminate alternatives. This could be done
1315 -- by adding another count to the ATCB, similar to Awake_Count, but
1316 -- keeping track of tasks that are on terminate alternatives.
1318 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1320 -- Force any remaining dependents to terminate, by aborting them.
1322 if not Single_Lock
then
1326 Abort_Dependents
(Self_ID
);
1328 -- Above, when we "abort" the dependents we are simply using this
1329 -- operation for convenience. We are not required to support the full
1330 -- abort-statement semantics; in particular, we are not required to
1331 -- immediately cancel any queued or in-service entry calls. That is
1332 -- good, because if we tried to cancel a call we would need to lock
1333 -- the caller, in order to wake the caller up. Our anti-deadlock
1334 -- rules prevent us from doing that without releasing the locks on C
1335 -- and Self_ID. Releasing and retaking those locks would be wasteful
1336 -- at best, and should not be considered further without more
1337 -- detailed analysis of potential concurrent accesses to the
1338 -- ATCBs of C and Self_ID.
1340 -- Count how many "alive" dependent tasks this master currently
1341 -- has, and record this in Wait_Count. This count should start at
1342 -- zero, since it is initialized to zero for new tasks, and the
1343 -- task should not exit the sleep-loops that use this count until
1344 -- the count reaches zero.
1346 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1348 Write_Lock
(Self_ID
);
1349 C
:= All_Tasks_List
;
1351 while C
/= null loop
1352 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1355 pragma Assert
(C
.Awake_Count
= 0);
1357 if C
.Alive_Count
> 0 then
1358 pragma Assert
(C
.Terminate_Alternative
);
1359 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1365 C
:= C
.Common
.All_Tasks_Link
;
1368 Self_ID
.Common
.State
:= Master_Phase_2_Sleep
;
1371 if not Single_Lock
then
1375 -- Wait for all counted tasks to finish terminating themselves.
1377 Write_Lock
(Self_ID
);
1380 Initialization
.Poll_Base_Priority_Change
(Self_ID
);
1381 exit when Self_ID
.Common
.Wait_Count
= 0;
1382 Sleep
(Self_ID
, Master_Phase_2_Sleep
);
1385 Self_ID
.Common
.State
:= Runnable
;
1389 -- We don't wake up for abortion here. We are already terminating
1390 -- just as fast as we can, so there is no point.
1392 -- Remove terminated tasks from the list of Self_ID's dependents, but
1393 -- don't free their ATCBs yet, because of lock order restrictions,
1394 -- which don't allow us to call "free" or "malloc" while holding any
1395 -- other locks. Instead, we put those ATCBs to be freed onto a
1396 -- temporary list, called To_Be_Freed.
1398 if not Single_Lock
then
1402 C
:= All_Tasks_List
;
1405 while C
/= null loop
1406 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
>= CM
then
1408 P
.Common
.All_Tasks_Link
:= C
.Common
.All_Tasks_Link
;
1410 All_Tasks_List
:= C
.Common
.All_Tasks_Link
;
1413 T
:= C
.Common
.All_Tasks_Link
;
1414 C
.Common
.All_Tasks_Link
:= To_Be_Freed
;
1420 C
:= C
.Common
.All_Tasks_Link
;
1426 -- Free all the ATCBs on the list To_Be_Freed.
1428 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1429 -- any interrupt entries are detached from them they should no longer
1432 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1433 -- avoid a race between a terminating task and its parent. The parent
1434 -- might try to deallocate the ACTB out from underneath the exiting
1435 -- task. Note that Free will also lock Global_Task_Lock, but that is
1436 -- OK, since this is the *one* lock for which we have a mechanism to
1437 -- support nested locking. See Task_Wrapper and its finalizer for more
1441 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1442 -- references to terminated library-level tasks, which could
1443 -- otherwise occur during finalization of library-level objects.
1444 -- A better solution might be to hook task objects into the
1445 -- finalization chain and deallocate the ATCB when the task
1446 -- object is deallocated. However, this change is not likely
1447 -- to gain anything significant, since all this storage should
1448 -- be recovered en-masse when the process exits.
1450 while To_Be_Freed
/= null loop
1452 To_Be_Freed
:= T
.Common
.All_Tasks_Link
;
1454 -- ??? On SGI there is currently no Interrupt_Manager, that's
1455 -- why we need to check if the Interrupt_Manager_ID is null
1457 if T
.Interrupt_Entry
and Interrupt_Manager_ID
/= null then
1459 Detach_Interrupt_Entries_Index
: Task_Entry_Index
:= 1;
1460 -- Corresponds to the entry index of System.Interrupts.
1461 -- Interrupt_Manager.Detach_Interrupt_Entries.
1462 -- Be sure to update this value when changing
1463 -- Interrupt_Manager specs.
1465 type Param_Type
is access all Task_ID
;
1467 Param
: aliased Param_Type
:= T
'Access;
1470 System
.Tasking
.Rendezvous
.Call_Simple
1471 (Interrupt_Manager_ID
, Detach_Interrupt_Entries_Index
,
1476 if (T
.Common
.Parent
/= null
1477 and then T
.Common
.Parent
.Common
.Parent
/= null)
1478 or else T
.Master_of_Task
> 3
1480 Initialization
.Task_Lock
(Self_ID
);
1482 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1483 -- has not been called yet (case of an unactivated task).
1485 if T
.Common
.Compiler_Data
.Sec_Stack_Addr
/= Null_Address
then
1486 SSL
.Destroy_TSD
(T
.Common
.Compiler_Data
);
1489 Vulnerable_Free_Task
(T
);
1490 Initialization
.Task_Unlock
(Self_ID
);
1494 -- It might seem nice to let the terminated task deallocate its own
1495 -- ATCB. That would not cover the case of unactivated tasks. It also
1496 -- would force us to keep the underlying thread around past termination,
1497 -- since references to the ATCB are possible past termination.
1498 -- Currently, we get rid of the thread as soon as the task terminates,
1499 -- and let the parent recover the ATCB later.
1501 -- Some day, if we want to recover the ATCB earlier, at task
1502 -- termination, we could consider using "fat task IDs", that include the
1503 -- serial number with the ATCB pointer, to catch references to tasks
1504 -- that no longer have ATCBs. It is not clear how much this would gain,
1505 -- since the user-level task object would still be occupying storage.
1507 -- Make next master level up active.
1508 -- We don't need to lock the ATCB, since the value is only updated by
1509 -- each task for itself.
1511 Self_ID
.Master_Within
:= CM
- 1;
1512 end Vulnerable_Complete_Master
;
1514 ------------------------------
1515 -- Vulnerable_Complete_Task --
1516 ------------------------------
1518 -- Complete the calling task
1520 -- This procedure must be called with abort deferred. (That's why the
1521 -- name has "Vulnerable" in it.) It should only be called by Complete_Task
1522 -- and Finalize_Global_Tasks (for the environment task).
1524 -- The effect is similar to that of Complete_Master. Differences include
1525 -- the closing of entries here, and computation of the number of active
1526 -- dependent tasks in Complete_Master.
1528 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1529 -- because that does its own locking, and because we do not need the lock
1530 -- to test Self_ID.Common.Activator. That value should only be read and
1531 -- modified by Self.
1533 procedure Vulnerable_Complete_Task
(Self_ID
: Task_ID
) is
1535 pragma Assert
(Self_ID
.Deferral_Level
> 0);
1536 pragma Assert
(Self_ID
= Self
);
1537 pragma Assert
(Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 1
1539 Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 2);
1540 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1541 pragma Assert
(Self_ID
.Open_Accepts
= null);
1542 pragma Assert
(Self_ID
.ATC_Nesting_Level
= 1);
1544 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Task", 'C'));
1550 Write_Lock
(Self_ID
);
1551 Self_ID
.Callable
:= False;
1553 -- In theory, Self should have no pending entry calls left on its
1554 -- call-stack. Each async. select statement should clean its own call,
1555 -- and blocking entry calls should defer abort until the calls are
1556 -- cancelled, then clean up.
1558 Utilities
.Cancel_Queued_Entry_Calls
(Self_ID
);
1561 if Self_ID
.Common
.Activator
/= null then
1562 Vulnerable_Complete_Activation
(Self_ID
);
1569 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
1570 -- we may have dependent tasks for which we need to wait.
1571 -- Otherwise, we can just exit.
1573 if Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 2 then
1574 Vulnerable_Complete_Master
(Self_ID
);
1576 end Vulnerable_Complete_Task
;
1578 --------------------------
1579 -- Vulnerable_Free_Task --
1580 --------------------------
1582 -- Recover all runtime system storage associated with the task T.
1583 -- This should only be called after T has terminated and will no
1584 -- longer be referenced.
1586 -- For tasks created by an allocator that fails, due to an exception,
1587 -- it is called from Expunge_Unactivated_Tasks.
1589 -- For tasks created by elaboration of task object declarations it
1590 -- is called from the finalization code of the Task_Wrapper procedure.
1591 -- It is also called from Unchecked_Deallocation, for objects that
1592 -- are or contain tasks.
1594 procedure Vulnerable_Free_Task
(T
: Task_ID
) is
1597 (Debug
.Trace
("Vulnerable_Free_Task", T
, 'C'));
1604 Initialization
.Finalize_Attributes_Link
.all (T
);
1611 if T
.Common
.Task_Image
/= null then
1612 Free_Task_Image
(T
.Common
.Task_Image
);
1615 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
1616 end Vulnerable_Free_Task
;
1619 -- Establish the Adafinal softlink.
1620 -- This is not done inside the central RTS initialization routine
1621 -- to avoid with-ing this package from System.Tasking.Initialization.
1623 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
1625 -- Establish soft links for subprograms that manipulate master_id's.
1626 -- This cannot be done when the RTS is initialized, because of various
1627 -- elaboration constraints.
1629 SSL
.Current_Master
:= Stages
.Current_Master
'Access;
1630 SSL
.Enter_Master
:= Stages
.Enter_Master
'Access;
1631 SSL
.Complete_Master
:= Stages
.Complete_Master
'Access;
1632 end System
.Tasking
.Stages
;