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-2009, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
33 -- Turn off polling, we do not want ATC polling to take place during tasking
34 -- operations. It causes infinite loops and other problems.
37 with Ada
.Unchecked_Deallocation
;
39 with System
.Tasking
.Debug
;
40 with System
.Address_Image
;
41 with System
.Task_Primitives
;
42 with System
.Task_Primitives
.Operations
;
43 with System
.Tasking
.Utilities
;
44 with System
.Tasking
.Queuing
;
45 with System
.Tasking
.Rendezvous
;
46 with System
.OS_Primitives
;
47 with System
.Secondary_Stack
;
48 with System
.Storage_Elements
;
49 with System
.Restrictions
;
50 with System
.Standard_Library
;
51 with System
.Traces
.Tasking
;
52 with System
.Stack_Usage
;
54 with System
.Soft_Links
;
55 -- These are procedure pointers to non-tasking routines that use task
56 -- specific data. In the absence of tasking, these routines refer to global
57 -- data. In the presence of tasking, they must be replaced with pointers to
58 -- task-specific versions. Also used for Create_TSD, Destroy_TSD,
59 -- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler.
61 with System
.Tasking
.Initialization
;
62 pragma Elaborate_All
(System
.Tasking
.Initialization
);
63 -- This insures that tasking is initialized if any tasks are created
65 package body System
.Tasking
.Stages
is
67 package STPO
renames System
.Task_Primitives
.Operations
;
68 package SSL
renames System
.Soft_Links
;
69 package SSE
renames System
.Storage_Elements
;
70 package SST
renames System
.Secondary_Stack
;
76 use Task_Primitives
.Operations
;
80 use System
.Traces
.Tasking
;
82 -----------------------
83 -- Local Subprograms --
84 -----------------------
87 Ada
.Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
89 procedure Free_Entry_Names
(T
: Task_Id
);
90 -- Deallocate all string names associated with task entries
92 procedure Trace_Unhandled_Exception_In_Task
(Self_Id
: Task_Id
);
93 -- This procedure outputs the task specific message for exception
96 procedure Task_Wrapper
(Self_ID
: Task_Id
);
97 pragma Convention
(C
, Task_Wrapper
);
98 -- This is the procedure that is called by the GNULL from the new context
99 -- when a task is created. It waits for activation and then calls the task
100 -- body procedure. When the task body procedure completes, it terminates
103 -- The Task_Wrapper's address will be provided to the underlying threads
104 -- library as the task entry point. Convention C is what makes most sense
105 -- for that purpose (Export C would make the function globally visible,
106 -- and affect the link name on which GDB depends). This will in addition
107 -- trigger an automatic stack alignment suitable for GCC's assumptions if
110 -- "Vulnerable_..." in the procedure names below means they must be called
111 -- with abort deferred.
113 procedure Vulnerable_Complete_Task
(Self_ID
: Task_Id
);
114 -- Complete the calling task. This procedure must be called with
115 -- abort deferred. It should only be called by Complete_Task and
116 -- Finalize_Global_Tasks (for the environment task).
118 procedure Vulnerable_Complete_Master
(Self_ID
: Task_Id
);
119 -- Complete the current master of the calling task. This procedure
120 -- must be called with abort deferred. It should only be called by
121 -- Vulnerable_Complete_Task and Complete_Master.
123 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_Id
);
124 -- Signal to Self_ID's activator that Self_ID has completed activation.
125 -- This procedure must be called with abort deferred.
127 procedure Abort_Dependents
(Self_ID
: Task_Id
);
128 -- Abort all the direct dependents of Self at its current master nesting
129 -- level, plus all of their dependents, transitively. RTS_Lock should be
130 -- locked by the caller.
132 procedure Vulnerable_Free_Task
(T
: Task_Id
);
133 -- Recover all runtime system storage associated with the task T. This
134 -- should only be called after T has terminated and will no longer be
137 -- For tasks created by an allocator that fails, due to an exception, it is
138 -- called from Expunge_Unactivated_Tasks.
140 -- Different code is used at master completion, in Terminate_Dependents,
141 -- due to a need for tighter synchronization with the master.
143 ----------------------
144 -- Abort_Dependents --
145 ----------------------
147 procedure Abort_Dependents
(Self_ID
: Task_Id
) is
154 P
:= C
.Common
.Parent
;
158 -- ??? C is supposed to take care of its own dependents, so
159 -- there should be no need to worry about them. Need to double
162 if C
.Master_of_Task
= Self_ID
.Master_Within
then
163 Utilities
.Abort_One_Task
(Self_ID
, C
);
164 C
.Dependents_Aborted
:= True;
170 P
:= P
.Common
.Parent
;
173 C
:= C
.Common
.All_Tasks_Link
;
176 Self_ID
.Dependents_Aborted
:= True;
177 end Abort_Dependents
;
183 procedure Abort_Tasks
(Tasks
: Task_List
) is
185 Utilities
.Abort_Tasks
(Tasks
);
192 -- Note that locks of activator and activated task are both locked here.
193 -- This is necessary because C.Common.State and Self.Common.Wait_Count have
194 -- to be synchronized. This is safe from deadlock because the activator is
195 -- always created before the activated task. That satisfies our
196 -- in-order-of-creation ATCB locking policy.
198 -- At one point, we may also lock the parent, if the parent is different
199 -- from the activator. That is also consistent with the lock ordering
200 -- policy, since the activator cannot be created before the parent.
202 -- Since we are holding both the activator's lock, and Task_Wrapper locks
203 -- that before it does anything more than initialize the low-level ATCB
204 -- components, it should be safe to wait to update the counts until we see
205 -- that the thread creation is successful.
207 -- If the thread creation fails, we do need to close the entries of the
208 -- task. The first phase, of dequeuing calls, only requires locking the
209 -- acceptor's ATCB, but the waking up of the callers requires locking the
210 -- caller's ATCB. We cannot safely do this while we are holding other
211 -- locks. Therefore, the queue-clearing operation is done in a separate
212 -- pass over the activation chain.
214 procedure Activate_Tasks
(Chain_Access
: Activation_Chain_Access
) is
215 Self_ID
: constant Task_Id
:= STPO
.Self
;
218 Next_C
, Last_C
: Task_Id
;
219 Activate_Prio
: System
.Any_Priority
;
221 All_Elaborated
: Boolean := True;
224 -- If pragma Detect_Blocking is active, then we must check whether this
225 -- potentially blocking operation is called from a protected action.
227 if System
.Tasking
.Detect_Blocking
228 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
230 raise Program_Error
with "potentially blocking operation";
234 (Debug
.Trace
(Self_ID
, "Activate_Tasks", 'C'));
236 Initialization
.Defer_Abort_Nestable
(Self_ID
);
238 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
240 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
241 -- we finish activating the chain.
245 -- Check that all task bodies have been elaborated
247 C
:= Chain_Access
.T_ID
;
250 if C
.Common
.Elaborated
/= null
251 and then not C
.Common
.Elaborated
.all
253 All_Elaborated
:= False;
256 -- Reverse the activation chain so that tasks are activated in the
257 -- same order they're declared.
259 Next_C
:= C
.Common
.Activation_Link
;
260 C
.Common
.Activation_Link
:= Last_C
;
265 Chain_Access
.T_ID
:= Last_C
;
267 if not All_Elaborated
then
269 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
270 raise Program_Error
with "Some tasks have not been elaborated";
273 -- Activate all the tasks in the chain. Creation of the thread of
274 -- control was deferred until activation. So create it now.
276 C
:= Chain_Access
.T_ID
;
278 if C
.Common
.State
/= Terminated
then
279 pragma Assert
(C
.Common
.State
= Unactivated
);
281 P
:= C
.Common
.Parent
;
285 if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
) then
286 Activate_Prio
:= Get_Priority
(Self_ID
);
288 Activate_Prio
:= C
.Common
.Base_Priority
;
291 System
.Task_Primitives
.Operations
.Create_Task
292 (C
, Task_Wrapper
'Address,
294 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
295 Activate_Prio
, Success
);
297 -- There would be a race between the created task and the creator
298 -- to do the following initialization, if we did not have a
299 -- Lock/Unlock_RTS pair in the task wrapper to prevent it from
303 C
.Common
.State
:= Activating
;
306 P
.Awake_Count
:= P
.Awake_Count
+ 1;
307 P
.Alive_Count
:= P
.Alive_Count
+ 1;
309 if P
.Common
.State
= Master_Completion_Sleep
and then
310 C
.Master_of_Task
= P
.Master_Within
312 pragma Assert
(Self_ID
/= P
);
313 P
.Common
.Wait_Count
:= P
.Common
.Wait_Count
+ 1;
316 for J
in System
.Tasking
.Debug
.Known_Tasks
'Range loop
317 if System
.Tasking
.Debug
.Known_Tasks
(J
) = null then
318 System
.Tasking
.Debug
.Known_Tasks
(J
) := C
;
319 C
.Known_Tasks_Index
:= J
;
324 if Global_Task_Debug_Event_Set
then
325 Debug
.Signal_Debug_Event
326 (Debug
.Debug_Event_Activating
, C
);
329 C
.Common
.State
:= Runnable
;
335 -- No need to set Awake_Count, State, etc. here since the loop
336 -- below will do that for any Unactivated tasks.
340 Self_ID
.Common
.Activation_Failed
:= True;
344 C
:= C
.Common
.Activation_Link
;
347 if not Single_Lock
then
351 -- Close the entries of any tasks that failed thread creation, and count
352 -- those that have not finished activation.
354 Write_Lock
(Self_ID
);
355 Self_ID
.Common
.State
:= Activator_Sleep
;
357 C
:= Chain_Access
.T_ID
;
361 if C
.Common
.State
= Unactivated
then
362 C
.Common
.Activator
:= null;
363 C
.Common
.State
:= Terminated
;
365 Utilities
.Cancel_Queued_Entry_Calls
(C
);
367 elsif C
.Common
.Activator
/= null then
368 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
372 P
:= C
.Common
.Activation_Link
;
373 C
.Common
.Activation_Link
:= null;
377 -- Wait for the activated tasks to complete activation. It is
378 -- unsafe to abort any of these tasks until the count goes to zero.
381 exit when Self_ID
.Common
.Wait_Count
= 0;
382 Sleep
(Self_ID
, Activator_Sleep
);
385 Self_ID
.Common
.State
:= Runnable
;
392 -- Remove the tasks from the chain
394 Chain_Access
.T_ID
:= null;
395 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
397 if Self_ID
.Common
.Activation_Failed
then
398 Self_ID
.Common
.Activation_Failed
:= False;
399 raise Tasking_Error
with "Failure during activation";
403 -------------------------
404 -- Complete_Activation --
405 -------------------------
407 procedure Complete_Activation
is
408 Self_ID
: constant Task_Id
:= STPO
.Self
;
411 Initialization
.Defer_Abort_Nestable
(Self_ID
);
417 Vulnerable_Complete_Activation
(Self_ID
);
423 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
425 -- ??? Why do we need to allow for nested deferral here?
427 if Runtime_Traces
then
428 Send_Trace_Info
(T_Activate
);
430 end Complete_Activation
;
432 ---------------------
433 -- Complete_Master --
434 ---------------------
436 procedure Complete_Master
is
437 Self_ID
: constant Task_Id
:= STPO
.Self
;
440 (Self_ID
.Deferral_Level
> 0
441 or else not System
.Restrictions
.Abort_Allowed
);
442 Vulnerable_Complete_Master
(Self_ID
);
449 -- See comments on Vulnerable_Complete_Task for details
451 procedure Complete_Task
is
452 Self_ID
: constant Task_Id
:= STPO
.Self
;
456 (Self_ID
.Deferral_Level
> 0
457 or else not System
.Restrictions
.Abort_Allowed
);
459 Vulnerable_Complete_Task
(Self_ID
);
461 -- All of our dependents have terminated. Never undefer abort again!
469 -- Compiler interface only. Do not call from within the RTS. This must be
470 -- called to create a new task.
472 procedure Create_Task
474 Size
: System
.Parameters
.Size_Type
;
475 Task_Info
: System
.Task_Info
.Task_Info_Type
;
476 Relative_Deadline
: Ada
.Real_Time
.Time_Span
;
477 Num_Entries
: Task_Entry_Index
;
478 Master
: Master_Level
;
479 State
: Task_Procedure_Access
;
480 Discriminants
: System
.Address
;
481 Elaborated
: Access_Boolean
;
482 Chain
: in out Activation_Chain
;
484 Created_Task
: out Task_Id
;
485 Build_Entry_Names
: Boolean)
488 Self_ID
: constant Task_Id
:= STPO
.Self
;
490 Base_Priority
: System
.Any_Priority
;
493 pragma Unreferenced
(Relative_Deadline
);
494 -- EDF scheduling is not supported by any of the target platforms so
495 -- this parameter is not passed any further.
498 -- If Master is greater than the current master, it means that Master
499 -- has already awaited its dependent tasks. This raises Program_Error,
500 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
502 if Self_ID
.Master_of_Task
/= Foreign_Task_Level
503 and then Master
> Self_ID
.Master_Within
505 raise Program_Error
with
506 "create task after awaiting termination";
509 -- If pragma Detect_Blocking is active must be checked whether this
510 -- potentially blocking operation is called from a protected action.
512 if System
.Tasking
.Detect_Blocking
513 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
515 raise Program_Error
with "potentially blocking operation";
518 pragma Debug
(Debug
.Trace
(Self_ID
, "Create_Task", 'C'));
520 if Priority
= Unspecified_Priority
then
521 Base_Priority
:= Self_ID
.Common
.Base_Priority
;
523 Base_Priority
:= System
.Any_Priority
(Priority
);
526 -- Find parent P of new Task, via master level number
531 while P
.Master_of_Task
>= Master
loop
532 P
:= P
.Common
.Parent
;
537 Initialization
.Defer_Abort_Nestable
(Self_ID
);
540 T
:= New_ATCB
(Num_Entries
);
543 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
544 raise Storage_Error
with "Cannot allocate task";
547 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this
548 -- point, it is possible that we may be part of a family of tasks that
552 Write_Lock
(Self_ID
);
554 -- Now, we must check that we have not been aborted. If so, we should
555 -- give up on creating this task, and simply return.
557 if not Self_ID
.Callable
then
558 pragma Assert
(Self_ID
.Pending_ATC_Level
= 0);
559 pragma Assert
(Self_ID
.Pending_Action
);
561 (Chain
.T_ID
= null or else Chain
.T_ID
.Common
.State
= Unactivated
);
565 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
567 -- ??? Should never get here
569 pragma Assert
(False);
570 raise Standard
'Abort_Signal;
573 Initialize_ATCB
(Self_ID
, State
, Discriminants
, P
, Elaborated
,
574 Base_Priority
, Task_Info
, Size
, T
, Success
);
580 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
581 raise Storage_Error
with "Failed to initialize task";
584 if Master
= Foreign_Task_Level
+ 2 then
586 -- This should not happen, except when a foreign task creates non
587 -- library-level Ada tasks. In this case, we pretend the master is
588 -- a regular library level task, otherwise the run-time will get
589 -- confused when waiting for these tasks to terminate.
591 T
.Master_of_Task
:= Library_Task_Level
;
593 T
.Master_of_Task
:= Master
;
596 T
.Master_Within
:= T
.Master_of_Task
+ 1;
598 for L
in T
.Entry_Calls
'Range loop
599 T
.Entry_Calls
(L
).Self
:= T
;
600 T
.Entry_Calls
(L
).Level
:= L
;
603 if Task_Image
'Length = 0 then
604 T
.Common
.Task_Image_Len
:= 0;
607 T
.Common
.Task_Image
(1) := Task_Image
(Task_Image
'First);
609 -- Remove unwanted blank space generated by 'Image
611 for J
in Task_Image
'First + 1 .. Task_Image
'Last loop
612 if Task_Image
(J
) /= ' '
613 or else Task_Image
(J
- 1) /= '('
616 T
.Common
.Task_Image
(Len
) := Task_Image
(J
);
617 exit when Len
= T
.Common
.Task_Image
'Last;
621 T
.Common
.Task_Image_Len
:= Len
;
627 -- Note: we should not call 'new' while holding locks since new
628 -- may use locks (e.g. RTS_Lock under Windows) itself and cause a
631 if Build_Entry_Names
then
633 new Entry_Names_Array
(1 .. Entry_Index
(Num_Entries
));
636 -- Create TSD as early as possible in the creation of a task, since it
637 -- may be used by the operation of Ada code within the task.
639 SSL
.Create_TSD
(T
.Common
.Compiler_Data
);
640 T
.Common
.Activation_Link
:= Chain
.T_ID
;
642 Initialization
.Initialize_Attributes_Link
.all (T
);
644 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
646 if Runtime_Traces
then
647 Send_Trace_Info
(T_Create
, T
);
655 function Current_Master
return Master_Level
is
657 return STPO
.Self
.Master_Within
;
664 procedure Enter_Master
is
665 Self_ID
: constant Task_Id
:= STPO
.Self
;
667 Self_ID
.Master_Within
:= Self_ID
.Master_Within
+ 1;
670 -------------------------------
671 -- Expunge_Unactivated_Tasks --
672 -------------------------------
674 -- See procedure Close_Entries for the general case
676 procedure Expunge_Unactivated_Tasks
(Chain
: in out Activation_Chain
) is
677 Self_ID
: constant Task_Id
:= STPO
.Self
;
679 Call
: Entry_Call_Link
;
684 (Debug
.Trace
(Self_ID
, "Expunge_Unactivated_Tasks", 'C'));
686 Initialization
.Defer_Abort_Nestable
(Self_ID
);
689 -- Experimentation has shown that abort is sometimes (but not always)
690 -- already deferred when this is called.
692 -- That may indicate an error. Find out what is going on
696 pragma Assert
(C
.Common
.State
= Unactivated
);
698 Temp
:= C
.Common
.Activation_Link
;
700 if C
.Common
.State
= Unactivated
then
704 for J
in 1 .. C
.Entry_Num
loop
705 Queuing
.Dequeue_Head
(C
.Entry_Queues
(J
), Call
);
706 pragma Assert
(Call
= null);
711 Initialization
.Remove_From_All_Tasks_List
(C
);
714 Vulnerable_Free_Task
(C
);
720 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
721 end Expunge_Unactivated_Tasks
;
723 ---------------------------
724 -- Finalize_Global_Tasks --
725 ---------------------------
728 -- We have a potential problem here if finalization of global objects does
729 -- anything with signals or the timer server, since by that time those
730 -- servers have terminated.
732 -- It is hard to see how that would occur
734 -- However, a better solution might be to do all this finalization
735 -- using the global finalization chain.
737 procedure Finalize_Global_Tasks
is
738 Self_ID
: constant Task_Id
:= STPO
.Self
;
741 pragma Unreferenced
(Ignore
);
744 if Self_ID
.Deferral_Level
= 0 then
746 -- In principle, we should be able to predict whether abort is
747 -- already deferred here (and it should not be deferred yet but in
748 -- practice it seems Finalize_Global_Tasks is being called sometimes,
749 -- from RTS code for exceptions, with abort already deferred.
751 Initialization
.Defer_Abort_Nestable
(Self_ID
);
753 -- Never undefer again!!!
756 -- This code is only executed by the environment task
758 pragma Assert
(Self_ID
= Environment_Task
);
760 -- Set Environment_Task'Callable to false to notify library-level tasks
761 -- that it is waiting for them.
763 Self_ID
.Callable
:= False;
765 -- Exit level 2 master, for normal tasks in library-level packages
769 -- Force termination of "independent" library-level server tasks
773 Abort_Dependents
(Self_ID
);
775 if not Single_Lock
then
779 -- We need to explicitly wait for the task to be terminated here
780 -- because on true concurrent system, we may end this procedure before
781 -- the tasks are really terminated.
783 Write_Lock
(Self_ID
);
786 exit when Utilities
.Independent_Task_Count
= 0;
788 -- We used to yield here, but this did not take into account low
789 -- priority tasks that would cause dead lock in some cases (true
793 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
794 Self_ID
.Common
.State
, Ignore
, Ignore
);
797 -- ??? On multi-processor environments, it seems that the above loop
798 -- isn't sufficient, so we need to add an additional delay.
801 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
802 Self_ID
.Common
.State
, Ignore
, Ignore
);
810 -- Complete the environment task
812 Vulnerable_Complete_Task
(Self_ID
);
814 -- Handle normal task termination by the environment task, but only
815 -- for the normal task termination. In the case of Abnormal and
816 -- Unhandled_Exception they must have been handled before, and the
817 -- task termination soft link must have been changed so the task
818 -- termination routine is not executed twice.
820 SSL
.Task_Termination_Handler
.all (Ada
.Exceptions
.Null_Occurrence
);
822 -- Finalize the global list for controlled objects if needed
824 SSL
.Finalize_Global_List
.all;
826 -- Reset the soft links to non-tasking
828 SSL
.Abort_Defer
:= SSL
.Abort_Defer_NT
'Access;
829 SSL
.Abort_Undefer
:= SSL
.Abort_Undefer_NT
'Access;
830 SSL
.Lock_Task
:= SSL
.Task_Lock_NT
'Access;
831 SSL
.Unlock_Task
:= SSL
.Task_Unlock_NT
'Access;
832 SSL
.Get_Jmpbuf_Address
:= SSL
.Get_Jmpbuf_Address_NT
'Access;
833 SSL
.Set_Jmpbuf_Address
:= SSL
.Set_Jmpbuf_Address_NT
'Access;
834 SSL
.Get_Sec_Stack_Addr
:= SSL
.Get_Sec_Stack_Addr_NT
'Access;
835 SSL
.Set_Sec_Stack_Addr
:= SSL
.Set_Sec_Stack_Addr_NT
'Access;
836 SSL
.Check_Abort_Status
:= SSL
.Check_Abort_Status_NT
'Access;
837 SSL
.Get_Stack_Info
:= SSL
.Get_Stack_Info_NT
'Access;
839 -- Don't bother trying to finalize Initialization.Global_Task_Lock
840 -- and System.Task_Primitives.RTS_Lock.
842 end Finalize_Global_Tasks
;
844 ----------------------
845 -- Free_Entry_Names --
846 ----------------------
848 procedure Free_Entry_Names
(T
: Task_Id
) is
849 Names
: Entry_Names_Array_Access
:= T
.Entry_Names
;
851 procedure Free_Entry_Names_Array_Access
is new
852 Ada
.Unchecked_Deallocation
853 (Entry_Names_Array
, Entry_Names_Array_Access
);
860 Free_Entry_Names_Array
(Names
.all);
861 Free_Entry_Names_Array_Access
(Names
);
862 end Free_Entry_Names
;
868 procedure Free_Task
(T
: Task_Id
) is
869 Self_Id
: constant Task_Id
:= Self
;
872 if T
.Common
.State
= Terminated
then
874 -- It is not safe to call Abort_Defer or Write_Lock at this stage
876 Initialization
.Task_Lock
(Self_Id
);
879 Initialization
.Finalize_Attributes_Link
.all (T
);
880 Initialization
.Remove_From_All_Tasks_List
(T
);
883 Initialization
.Task_Unlock
(Self_Id
);
885 Free_Entry_Names
(T
);
886 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
888 -- If the task is not terminated, then we simply ignore the call. This
889 -- happens when a user program attempts an unchecked deallocation on
890 -- a non-terminated task.
897 ---------------------------
898 -- Move_Activation_Chain --
899 ---------------------------
901 procedure Move_Activation_Chain
902 (From
, To
: Activation_Chain_Access
;
903 New_Master
: Master_ID
)
905 Self_ID
: constant Task_Id
:= STPO
.Self
;
910 (Debug
.Trace
(Self_ID
, "Move_Activation_Chain", 'C'));
912 -- Nothing to do if From is empty, and we can check that without
921 Initialization
.Defer_Abort
(Self_ID
);
923 -- Loop through the From chain, changing their Master_of_Task
924 -- fields, and to find the end of the chain.
927 C
.Master_of_Task
:= New_Master
;
928 exit when C
.Common
.Activation_Link
= null;
929 C
:= C
.Common
.Activation_Link
;
932 -- Hook From in at the start of To
934 C
.Common
.Activation_Link
:= To
.all.T_ID
;
935 To
.all.T_ID
:= From
.all.T_ID
;
939 From
.all.T_ID
:= null;
941 Initialization
.Undefer_Abort
(Self_ID
);
942 end Move_Activation_Chain
;
944 -- Compiler interface only. Do not call from within the RTS
950 procedure Set_Entry_Name
952 Pos
: Task_Entry_Index
;
956 pragma Assert
(T
.Entry_Names
/= null);
958 T
.Entry_Names
(Entry_Index
(Pos
)) := Val
;
965 -- The task wrapper is a procedure that is called first for each task body
966 -- and which in turn calls the compiler-generated task body procedure.
967 -- The wrapper's main job is to do initialization for the task. It also
968 -- has some locally declared objects that serve as per-task local data.
969 -- Task finalization is done by Complete_Task, which is called from an
970 -- at-end handler that the compiler generates.
972 procedure Task_Wrapper
(Self_ID
: Task_Id
) is
973 use type SSE
.Storage_Offset
;
974 use System
.Standard_Library
;
975 use System
.Stack_Usage
;
977 Bottom_Of_Stack
: aliased Integer;
979 Task_Alternate_Stack
:
980 aliased SSE
.Storage_Array
(1 .. Alternate_Stack_Size
);
981 -- The alternate signal stack for this task, if any
983 Use_Alternate_Stack
: constant Boolean := Alternate_Stack_Size
/= 0;
984 -- Whether to use above alternate signal stack for stack overflows
986 Secondary_Stack_Size
:
987 constant SSE
.Storage_Offset
:=
988 Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
*
989 SSE
.Storage_Offset
(Parameters
.Sec_Stack_Ratio
) / 100;
991 Secondary_Stack
: aliased SSE
.Storage_Array
(1 .. Secondary_Stack_Size
);
993 pragma Warnings
(Off
);
994 -- Why are warnings being turned off here???
996 Secondary_Stack_Address
: System
.Address
:= Secondary_Stack
'Address;
997 -- Address of secondary stack. In the fixed secondary stack case, this
998 -- value is not modified, causing a warning, hence the bracketing with
999 -- Warnings (Off/On). But why is so much *more* bracketed???
1001 Small_Overflow_Guard
: constant := 12 * 1024;
1002 -- Note: this used to be 4K, but was changed to 12K, since smaller
1003 -- values resulted in segmentation faults from dynamic stack analysis.
1005 Big_Overflow_Guard
: constant := 16 * 1024;
1006 Small_Stack_Limit
: constant := 64 * 1024;
1007 -- ??? These three values are experimental, and seems to work on most
1008 -- platforms. They still need to be analyzed further. They also need
1009 -- documentation, what are they???
1012 Natural (Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
);
1014 Overflow_Guard
: Natural;
1015 -- Size of the overflow guard, used by dynamic stack usage analysis
1017 pragma Warnings
(On
);
1019 SEH_Table
: aliased SSE
.Storage_Array
(1 .. 8);
1020 -- Structured Exception Registration table (2 words)
1022 procedure Install_SEH_Handler
(Addr
: System
.Address
);
1023 pragma Import
(C
, Install_SEH_Handler
, "__gnat_install_SEH_handler");
1024 -- Install the SEH (Structured Exception Handling) handler
1026 Cause
: Cause_Of_Termination
:= Normal
;
1027 -- Indicates the reason why this task terminates. Normal corresponds to
1028 -- a task terminating due to completing the last statement of its body,
1029 -- or as a result of waiting on a terminate alternative. If the task
1030 -- terminates because it is being aborted then Cause will be set to
1031 -- Abnormal. If the task terminates because of an exception raised by
1032 -- the execution of its task body, then Cause is set to
1033 -- Unhandled_Exception.
1035 EO
: Exception_Occurrence
;
1036 -- If the task terminates because of an exception raised by the
1037 -- execution of its task body, then EO will contain the associated
1038 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
1040 TH
: Termination_Handler
:= null;
1041 -- Pointer to the protected procedure to be executed upon task
1044 procedure Search_Fall_Back_Handler
(ID
: Task_Id
);
1045 -- Procedure that searches recursively a fall-back handler through the
1046 -- master relationship. If the handler is found, its pointer is stored
1049 ------------------------------
1050 -- Search_Fall_Back_Handler --
1051 ------------------------------
1053 procedure Search_Fall_Back_Handler
(ID
: Task_Id
) is
1055 -- If there is a fall back handler, store its pointer for later
1058 if ID
.Common
.Fall_Back_Handler
/= null then
1059 TH
:= ID
.Common
.Fall_Back_Handler
;
1061 -- Otherwise look for a fall back handler in the parent
1063 elsif ID
.Common
.Parent
/= null then
1064 Search_Fall_Back_Handler
(ID
.Common
.Parent
);
1066 -- Otherwise, do nothing
1071 end Search_Fall_Back_Handler
;
1074 pragma Assert
(Self_ID
.Deferral_Level
= 1);
1076 -- Assume a size of the stack taken at this stage
1078 if Size
< Small_Stack_Limit
then
1079 Overflow_Guard
:= Small_Overflow_Guard
;
1081 Overflow_Guard
:= Big_Overflow_Guard
;
1084 if not Parameters
.Sec_Stack_Dynamic
then
1085 Self_ID
.Common
.Compiler_Data
.Sec_Stack_Addr
:=
1086 Secondary_Stack
'Address;
1087 SST
.SS_Init
(Secondary_Stack_Address
, Integer (Secondary_Stack
'Last));
1088 Size
:= Size
- Natural (Secondary_Stack_Size
);
1091 if Use_Alternate_Stack
then
1092 Self_ID
.Common
.Task_Alternate_Stack
:= Task_Alternate_Stack
'Address;
1095 Size
:= Size
- Overflow_Guard
;
1097 if System
.Stack_Usage
.Is_Enabled
then
1100 (Self_ID
.Common
.Analyzer
,
1101 Self_ID
.Common
.Task_Image
1102 (1 .. Self_ID
.Common
.Task_Image_Len
),
1104 (Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
1106 SSE
.To_Integer
(Bottom_Of_Stack
'Address));
1108 Fill_Stack
(Self_ID
.Common
.Analyzer
);
1111 -- Set the guard page at the bottom of the stack. The call to unprotect
1112 -- the page is done in Terminate_Task
1114 Stack_Guard
(Self_ID
, True);
1116 -- Initialize low-level TCB components, that cannot be initialized by
1117 -- the creator. Enter_Task sets Self_ID.LL.Thread
1119 Enter_Task
(Self_ID
);
1121 -- We setup the SEH (Structured Exception Handling) handler if supported
1124 Install_SEH_Handler
(SEH_Table
'Address);
1126 -- Initialize exception occurrence
1128 Save_Occurrence
(EO
, Ada
.Exceptions
.Null_Occurrence
);
1130 -- We lock RTS_Lock to wait for activator to finish activating the rest
1131 -- of the chain, so that everyone in the chain comes out in priority
1134 -- This also protects the value of
1135 -- Self_ID.Common.Activator.Common.Wait_Count.
1140 if not System
.Restrictions
.Abort_Allowed
then
1142 -- If Abort is not allowed, reset the deferral level since it will
1143 -- not get changed by the generated code. Keeping a default value
1144 -- of one would prevent some operations (e.g. select or delay) to
1145 -- proceed successfully.
1147 Self_ID
.Deferral_Level
:= 0;
1150 if Global_Task_Debug_Event_Set
then
1151 Debug
.Signal_Debug_Event
1152 (Debug
.Debug_Event_Run
, Self_ID
);
1156 -- We are separating the following portion of the code in order to
1157 -- place the exception handlers in a different block. In this way,
1158 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
1159 -- set Self in Enter_Task
1161 -- Call the task body procedure
1163 -- The task body is called with abort still deferred. That
1164 -- eliminates a dangerous window, for which we had to patch-up in
1167 -- During the expansion of the task body, we insert an RTS-call
1168 -- to Abort_Undefer, at the first point where abort should be
1171 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
1172 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1175 -- We can't call Terminate_Task in the exception handlers below,
1176 -- since there may be (e.g. in the case of GCC exception handling)
1177 -- clean ups associated with the exception handler that need to
1178 -- access task specific data.
1180 -- Defer abort so that this task can't be aborted while exiting
1182 when Standard
'Abort_Signal =>
1183 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1185 -- Update the cause that motivated the task termination so that
1186 -- the appropriate information is passed to the task termination
1187 -- procedure. Task termination as a result of waiting on a
1188 -- terminate alternative is a normal termination, although it is
1189 -- implemented using the abort mechanisms.
1191 if Self_ID
.Terminate_Alternative
then
1194 if Global_Task_Debug_Event_Set
then
1195 Debug
.Signal_Debug_Event
1196 (Debug
.Debug_Event_Terminated
, Self_ID
);
1201 if Global_Task_Debug_Event_Set
then
1202 Debug
.Signal_Debug_Event
1203 (Debug
.Debug_Event_Abort_Terminated
, Self_ID
);
1207 -- ??? Using an E : others here causes CD2C11A to fail on Tru64
1209 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1211 -- Perform the task specific exception tracing duty. We handle
1212 -- these outputs here and not in the common notification routine
1213 -- because we need access to tasking related data and we don't
1214 -- want to drag dependencies against tasking related units in the
1215 -- the common notification units. Additionally, no trace is ever
1216 -- triggered from the common routine for the Unhandled_Raise case
1217 -- in tasks, since an exception never appears unhandled in this
1218 -- context because of this handler.
1220 if Exception_Trace
= Unhandled_Raise
then
1221 Trace_Unhandled_Exception_In_Task
(Self_ID
);
1224 -- Update the cause that motivated the task termination so that
1225 -- the appropriate information is passed to the task termination
1226 -- procedure, as well as the associated Exception_Occurrence.
1228 Cause
:= Unhandled_Exception
;
1230 Save_Occurrence
(EO
, SSL
.Get_Current_Excep
.all.all);
1232 if Global_Task_Debug_Event_Set
then
1233 Debug
.Signal_Debug_Event
1234 (Debug
.Debug_Event_Exception_Terminated
, Self_ID
);
1238 -- Look for a task termination handler. This code is for all tasks but
1239 -- the environment task. The task termination code for the environment
1240 -- task is executed by SSL.Task_Termination_Handler.
1246 Write_Lock
(Self_ID
);
1248 if Self_ID
.Common
.Specific_Handler
/= null then
1249 TH
:= Self_ID
.Common
.Specific_Handler
;
1251 -- Look for a fall-back handler following the master relationship
1254 Search_Fall_Back_Handler
(Self_ID
);
1263 -- Execute the task termination handler if we found it
1266 TH
.all (Cause
, Self_ID
, EO
);
1269 if System
.Stack_Usage
.Is_Enabled
then
1270 Compute_Result
(Self_ID
.Common
.Analyzer
);
1271 Report_Result
(Self_ID
.Common
.Analyzer
);
1274 Terminate_Task
(Self_ID
);
1277 --------------------
1278 -- Terminate_Task --
1279 --------------------
1281 -- Before we allow the thread to exit, we must clean up. This is a
1282 -- delicate job. We must wake up the task's master, who may immediately try
1283 -- to deallocate the ATCB out from under the current task WHILE IT IS STILL
1286 -- To avoid this, the parent task must be blocked up to the latest
1287 -- statement executed. The trouble is that we have another step that we
1288 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1289 -- We have to postpone that until the end because compiler-generated code
1290 -- is likely to try to access that data at just about any point.
1292 -- We can't call Destroy_TSD while we are holding any other locks, because
1293 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1294 -- that to be the outermost lock. Our first "solution" was to just lock
1295 -- Global_Task_Lock in addition to the other locks, and force the parent to
1296 -- also lock this lock between its wakeup and its freeing of the ATCB. See
1297 -- Complete_Task for the parent-side of the code that has the matching
1298 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1299 -- since the operation Task_Unlock continued to access the ATCB after
1300 -- unlocking, after which the parent was observed to race ahead, deallocate
1301 -- the ATCB, and then reallocate it to another task. The call to
1302 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
1303 -- the data of the new task that reused the ATCB! To solve this problem, we
1304 -- introduced the new operation Final_Task_Unlock.
1306 procedure Terminate_Task
(Self_ID
: Task_Id
) is
1307 Environment_Task
: constant Task_Id
:= STPO
.Environment_Task
;
1308 Master_of_Task
: Integer;
1311 Debug
.Task_Termination_Hook
;
1313 if Runtime_Traces
then
1314 Send_Trace_Info
(T_Terminate
);
1317 -- Since GCC cannot allocate stack chunks efficiently without reordering
1318 -- some of the allocations, we have to handle this unexpected situation
1319 -- here. We should normally never have to call Vulnerable_Complete_Task
1322 if Self_ID
.Common
.Activator
/= null then
1323 Vulnerable_Complete_Task
(Self_ID
);
1326 Initialization
.Task_Lock
(Self_ID
);
1332 Master_of_Task
:= Self_ID
.Master_of_Task
;
1334 -- Check if the current task is an independent task If so, decrement
1335 -- the Independent_Task_Count value.
1337 if Master_of_Task
= Independent_Task_Level
then
1339 Utilities
.Independent_Task_Count
:=
1340 Utilities
.Independent_Task_Count
- 1;
1342 Write_Lock
(Environment_Task
);
1343 Utilities
.Independent_Task_Count
:=
1344 Utilities
.Independent_Task_Count
- 1;
1345 Unlock
(Environment_Task
);
1349 -- Unprotect the guard page if needed
1351 Stack_Guard
(Self_ID
, False);
1353 Utilities
.Make_Passive
(Self_ID
, Task_Completed
=> True);
1359 pragma Assert
(Check_Exit
(Self_ID
));
1361 SSL
.Destroy_TSD
(Self_ID
.Common
.Compiler_Data
);
1362 Initialization
.Final_Task_Unlock
(Self_ID
);
1364 -- WARNING: past this point, this thread must assume that the ATCB has
1365 -- been deallocated. It should not be accessed again.
1367 if Master_of_Task
> 0 then
1376 function Terminated
(T
: Task_Id
) return Boolean is
1377 Self_ID
: constant Task_Id
:= STPO
.Self
;
1381 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1388 Result
:= T
.Common
.State
= Terminated
;
1395 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
1399 ----------------------------------------
1400 -- Trace_Unhandled_Exception_In_Task --
1401 ----------------------------------------
1403 procedure Trace_Unhandled_Exception_In_Task
(Self_Id
: Task_Id
) is
1404 procedure To_Stderr
(S
: String);
1405 pragma Import
(Ada
, To_Stderr
, "__gnat_to_stderr");
1407 use System
.Soft_Links
;
1408 use System
.Standard_Library
;
1410 function To_Address
is new
1411 Ada
.Unchecked_Conversion
1412 (Task_Id
, System
.Task_Primitives
.Task_Address
);
1414 function Tailored_Exception_Information
1415 (E
: Exception_Occurrence
) return String;
1417 (Ada
, Tailored_Exception_Information
,
1418 "__gnat_tailored_exception_information");
1420 Excep
: constant Exception_Occurrence_Access
:=
1421 SSL
.Get_Current_Excep
.all;
1424 -- This procedure is called by the task outermost handler in
1425 -- Task_Wrapper below, so only once the task stack has been fully
1426 -- unwound. The common notification routine has been called at the
1427 -- raise point already.
1429 -- Lock to prevent unsynchronized output
1431 Initialization
.Task_Lock
(Self_Id
);
1432 To_Stderr
("task ");
1434 if Self_Id
.Common
.Task_Image_Len
/= 0 then
1436 (Self_Id
.Common
.Task_Image
(1 .. Self_Id
.Common
.Task_Image_Len
));
1440 To_Stderr
(System
.Address_Image
(To_Address
(Self_Id
)));
1441 To_Stderr
(" terminated by unhandled exception");
1442 To_Stderr
((1 => ASCII
.LF
));
1443 To_Stderr
(Tailored_Exception_Information
(Excep
.all));
1444 Initialization
.Task_Unlock
(Self_Id
);
1445 end Trace_Unhandled_Exception_In_Task
;
1447 ------------------------------------
1448 -- Vulnerable_Complete_Activation --
1449 ------------------------------------
1451 -- As in several other places, the locks of the activator and activated
1452 -- task are both locked here. This follows our deadlock prevention lock
1453 -- ordering policy, since the activated task must be created after the
1456 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_Id
) is
1457 Activator
: constant Task_Id
:= Self_ID
.Common
.Activator
;
1460 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Activation", 'C'));
1462 Write_Lock
(Activator
);
1463 Write_Lock
(Self_ID
);
1465 pragma Assert
(Self_ID
.Common
.Activator
/= null);
1467 -- Remove dangling reference to Activator, since a task may
1468 -- outlive its activator.
1470 Self_ID
.Common
.Activator
:= null;
1472 -- Wake up the activator, if it is waiting for a chain of tasks to
1473 -- activate, and we are the last in the chain to complete activation.
1475 if Activator
.Common
.State
= Activator_Sleep
then
1476 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
1478 if Activator
.Common
.Wait_Count
= 0 then
1479 Wakeup
(Activator
, Activator_Sleep
);
1483 -- The activator raises a Tasking_Error if any task it is activating
1484 -- is completed before the activation is done. However, if the reason
1485 -- for the task completion is an abort, we do not raise an exception.
1488 if not Self_ID
.Callable
and then Self_ID
.Pending_ATC_Level
/= 0 then
1489 Activator
.Common
.Activation_Failed
:= True;
1495 -- After the activation, active priority should be the same as base
1496 -- priority. We must unlock the Activator first, though, since it
1497 -- should not wait if we have lower priority.
1499 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
1500 Write_Lock
(Self_ID
);
1501 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
1504 end Vulnerable_Complete_Activation
;
1506 --------------------------------
1507 -- Vulnerable_Complete_Master --
1508 --------------------------------
1510 procedure Vulnerable_Complete_Master
(Self_ID
: Task_Id
) is
1513 CM
: constant Master_Level
:= Self_ID
.Master_Within
;
1514 T
: aliased Task_Id
;
1516 To_Be_Freed
: Task_Id
;
1517 -- This is a list of ATCBs to be freed, after we have released all RTS
1518 -- locks. This is necessary because of the locking order rules, since
1519 -- the storage manager uses Global_Task_Lock.
1521 pragma Warnings
(Off
);
1522 function Check_Unactivated_Tasks
return Boolean;
1523 pragma Warnings
(On
);
1524 -- Temporary error-checking code below. This is part of the checks
1525 -- added in the new run time. Call it only inside a pragma Assert.
1527 -----------------------------
1528 -- Check_Unactivated_Tasks --
1529 -----------------------------
1531 function Check_Unactivated_Tasks
return Boolean is
1533 if not Single_Lock
then
1537 Write_Lock
(Self_ID
);
1539 C
:= All_Tasks_List
;
1540 while C
/= null loop
1541 if C
.Common
.Activator
= Self_ID
and then C
.Master_of_Task
= CM
then
1545 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1548 if C
.Common
.State
= Unactivated
then
1555 C
:= C
.Common
.All_Tasks_Link
;
1560 if not Single_Lock
then
1565 end Check_Unactivated_Tasks
;
1567 -- Start of processing for Vulnerable_Complete_Master
1571 (Debug
.Trace
(Self_ID
, "V_Complete_Master", 'C'));
1573 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1575 (Self_ID
.Deferral_Level
> 0
1576 or else not System
.Restrictions
.Abort_Allowed
);
1578 -- Count how many active dependent tasks this master currently has, and
1579 -- record this in Wait_Count.
1581 -- This count should start at zero, since it is initialized to zero for
1582 -- new tasks, and the task should not exit the sleep-loops that use this
1583 -- count until the count reaches zero.
1585 -- While we're counting, if we run across any unactivated tasks that
1586 -- belong to this master, we summarily terminate them as required by
1590 Write_Lock
(Self_ID
);
1592 C
:= All_Tasks_List
;
1593 while C
/= null loop
1595 -- Terminate unactivated (never-to-be activated) tasks
1597 if C
.Common
.Activator
= Self_ID
and then C
.Master_of_Task
= CM
then
1599 pragma Assert
(C
.Common
.State
= Unactivated
);
1600 -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
1601 -- = CM. The only case where C is pending activation by this
1602 -- task, but the master of C is not CM is in Ada 2005, when C is
1603 -- part of a return object of a build-in-place function.
1606 C
.Common
.Activator
:= null;
1607 C
.Common
.State
:= Terminated
;
1608 C
.Callable
:= False;
1609 Utilities
.Cancel_Queued_Entry_Calls
(C
);
1613 -- Count it if dependent on this master
1615 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1618 if C
.Awake_Count
/= 0 then
1619 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1625 C
:= C
.Common
.All_Tasks_Link
;
1628 Self_ID
.Common
.State
:= Master_Completion_Sleep
;
1631 if not Single_Lock
then
1635 -- Wait until dependent tasks are all terminated or ready to terminate.
1636 -- While waiting, the task may be awakened if the task's priority needs
1637 -- changing, or this master is aborted. In the latter case, we abort the
1638 -- dependents, and resume waiting until Wait_Count goes to zero.
1640 Write_Lock
(Self_ID
);
1643 exit when Self_ID
.Common
.Wait_Count
= 0;
1645 -- Here is a difference as compared to Complete_Master
1647 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
1648 and then not Self_ID
.Dependents_Aborted
1651 Abort_Dependents
(Self_ID
);
1655 Abort_Dependents
(Self_ID
);
1657 Write_Lock
(Self_ID
);
1660 Sleep
(Self_ID
, Master_Completion_Sleep
);
1664 Self_ID
.Common
.State
:= Runnable
;
1667 -- Dependents are all terminated or on terminate alternatives. Now,
1668 -- force those on terminate alternatives to terminate, by aborting them.
1670 pragma Assert
(Check_Unactivated_Tasks
);
1672 if Self_ID
.Alive_Count
> 1 then
1674 -- Consider finding a way to skip the following extra steps if there
1675 -- are no dependents with terminate alternatives. This could be done
1676 -- by adding another count to the ATCB, similar to Awake_Count, but
1677 -- keeping track of tasks that are on terminate alternatives.
1679 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1681 -- Force any remaining dependents to terminate by aborting them
1683 if not Single_Lock
then
1687 Abort_Dependents
(Self_ID
);
1689 -- Above, when we "abort" the dependents we are simply using this
1690 -- operation for convenience. We are not required to support the full
1691 -- abort-statement semantics; in particular, we are not required to
1692 -- immediately cancel any queued or in-service entry calls. That is
1693 -- good, because if we tried to cancel a call we would need to lock
1694 -- the caller, in order to wake the caller up. Our anti-deadlock
1695 -- rules prevent us from doing that without releasing the locks on C
1696 -- and Self_ID. Releasing and retaking those locks would be wasteful
1697 -- at best, and should not be considered further without more
1698 -- detailed analysis of potential concurrent accesses to the ATCBs
1699 -- of C and Self_ID.
1701 -- Count how many "alive" dependent tasks this master currently has,
1702 -- and record this in Wait_Count. This count should start at zero,
1703 -- since it is initialized to zero for new tasks, and the task should
1704 -- not exit the sleep-loops that use this count until the count
1707 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1709 Write_Lock
(Self_ID
);
1711 C
:= All_Tasks_List
;
1712 while C
/= null loop
1713 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1716 pragma Assert
(C
.Awake_Count
= 0);
1718 if C
.Alive_Count
> 0 then
1719 pragma Assert
(C
.Terminate_Alternative
);
1720 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1726 C
:= C
.Common
.All_Tasks_Link
;
1729 Self_ID
.Common
.State
:= Master_Phase_2_Sleep
;
1732 if not Single_Lock
then
1736 -- Wait for all counted tasks to finish terminating themselves
1738 Write_Lock
(Self_ID
);
1741 exit when Self_ID
.Common
.Wait_Count
= 0;
1742 Sleep
(Self_ID
, Master_Phase_2_Sleep
);
1745 Self_ID
.Common
.State
:= Runnable
;
1749 -- We don't wake up for abort here. We are already terminating just as
1750 -- fast as we can, so there is no point.
1752 -- Remove terminated tasks from the list of Self_ID's dependents, but
1753 -- don't free their ATCBs yet, because of lock order restrictions, which
1754 -- don't allow us to call "free" or "malloc" while holding any other
1755 -- locks. Instead, we put those ATCBs to be freed onto a temporary list,
1756 -- called To_Be_Freed.
1758 if not Single_Lock
then
1762 C
:= All_Tasks_List
;
1764 while C
/= null loop
1765 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
>= CM
then
1767 P
.Common
.All_Tasks_Link
:= C
.Common
.All_Tasks_Link
;
1769 All_Tasks_List
:= C
.Common
.All_Tasks_Link
;
1772 T
:= C
.Common
.All_Tasks_Link
;
1773 C
.Common
.All_Tasks_Link
:= To_Be_Freed
;
1779 C
:= C
.Common
.All_Tasks_Link
;
1785 -- Free all the ATCBs on the list To_Be_Freed
1787 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1788 -- any interrupt entries are detached from them they should no longer
1791 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1792 -- avoid a race between a terminating task and its parent. The parent
1793 -- might try to deallocate the ACTB out from underneath the exiting
1794 -- task. Note that Free will also lock Global_Task_Lock, but that is
1795 -- OK, since this is the *one* lock for which we have a mechanism to
1796 -- support nested locking. See Task_Wrapper and its finalizer for more
1800 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1801 -- references to terminated library-level tasks, which could otherwise
1802 -- occur during finalization of library-level objects. A better solution
1803 -- might be to hook task objects into the finalization chain and
1804 -- deallocate the ATCB when the task object is deallocated. However,
1805 -- this change is not likely to gain anything significant, since all
1806 -- this storage should be recovered en-masse when the process exits.
1808 while To_Be_Freed
/= null loop
1810 To_Be_Freed
:= T
.Common
.All_Tasks_Link
;
1812 -- ??? On SGI there is currently no Interrupt_Manager, that's
1813 -- why we need to check if the Interrupt_Manager_ID is null
1815 if T
.Interrupt_Entry
and Interrupt_Manager_ID
/= null then
1817 Detach_Interrupt_Entries_Index
: constant Task_Entry_Index
:= 1;
1818 -- Corresponds to the entry index of System.Interrupts.
1819 -- Interrupt_Manager.Detach_Interrupt_Entries.
1820 -- Be sure to update this value when changing
1821 -- Interrupt_Manager specs.
1823 type Param_Type
is access all Task_Id
;
1825 Param
: aliased Param_Type
:= T
'Access;
1828 System
.Tasking
.Rendezvous
.Call_Simple
1829 (Interrupt_Manager_ID
, Detach_Interrupt_Entries_Index
,
1834 if (T
.Common
.Parent
/= null
1835 and then T
.Common
.Parent
.Common
.Parent
/= null)
1836 or else T
.Master_of_Task
> Library_Task_Level
1838 Initialization
.Task_Lock
(Self_ID
);
1840 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1841 -- has not been called yet (case of an unactivated task).
1843 if T
.Common
.Compiler_Data
.Sec_Stack_Addr
/= Null_Address
then
1844 SSL
.Destroy_TSD
(T
.Common
.Compiler_Data
);
1847 Vulnerable_Free_Task
(T
);
1848 Initialization
.Task_Unlock
(Self_ID
);
1852 -- It might seem nice to let the terminated task deallocate its own
1853 -- ATCB. That would not cover the case of unactivated tasks. It also
1854 -- would force us to keep the underlying thread around past termination,
1855 -- since references to the ATCB are possible past termination.
1857 -- Currently, we get rid of the thread as soon as the task terminates,
1858 -- and let the parent recover the ATCB later.
1860 -- Some day, if we want to recover the ATCB earlier, at task
1861 -- termination, we could consider using "fat task IDs", that include the
1862 -- serial number with the ATCB pointer, to catch references to tasks
1863 -- that no longer have ATCBs. It is not clear how much this would gain,
1864 -- since the user-level task object would still be occupying storage.
1866 -- Make next master level up active. We don't need to lock the ATCB,
1867 -- since the value is only updated by each task for itself.
1869 Self_ID
.Master_Within
:= CM
- 1;
1870 end Vulnerable_Complete_Master
;
1872 ------------------------------
1873 -- Vulnerable_Complete_Task --
1874 ------------------------------
1876 -- Complete the calling task
1878 -- This procedure must be called with abort deferred. It should only be
1879 -- called by Complete_Task and Finalize_Global_Tasks (for the environment
1882 -- The effect is similar to that of Complete_Master. Differences include
1883 -- the closing of entries here, and computation of the number of active
1884 -- dependent tasks in Complete_Master.
1886 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1887 -- because that does its own locking, and because we do not need the lock
1888 -- to test Self_ID.Common.Activator. That value should only be read and
1889 -- modified by Self.
1891 procedure Vulnerable_Complete_Task
(Self_ID
: Task_Id
) is
1894 (Self_ID
.Deferral_Level
> 0
1895 or else not System
.Restrictions
.Abort_Allowed
);
1896 pragma Assert
(Self_ID
= Self
);
1897 pragma Assert
(Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 1
1899 Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 2);
1900 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1901 pragma Assert
(Self_ID
.Open_Accepts
= null);
1902 pragma Assert
(Self_ID
.ATC_Nesting_Level
= 1);
1904 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Task", 'C'));
1910 Write_Lock
(Self_ID
);
1911 Self_ID
.Callable
:= False;
1913 -- In theory, Self should have no pending entry calls left on its
1914 -- call-stack. Each async. select statement should clean its own call,
1915 -- and blocking entry calls should defer abort until the calls are
1916 -- cancelled, then clean up.
1918 Utilities
.Cancel_Queued_Entry_Calls
(Self_ID
);
1921 if Self_ID
.Common
.Activator
/= null then
1922 Vulnerable_Complete_Activation
(Self_ID
);
1929 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have
1930 -- dependent tasks for which we need to wait. Otherwise we just exit.
1932 if Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 2 then
1933 Vulnerable_Complete_Master
(Self_ID
);
1935 end Vulnerable_Complete_Task
;
1937 --------------------------
1938 -- Vulnerable_Free_Task --
1939 --------------------------
1941 -- Recover all runtime system storage associated with the task T. This
1942 -- should only be called after T has terminated and will no longer be
1945 -- For tasks created by an allocator that fails, due to an exception, it
1946 -- is called from Expunge_Unactivated_Tasks.
1948 -- For tasks created by elaboration of task object declarations it is
1949 -- called from the finalization code of the Task_Wrapper procedure. It is
1950 -- also called from Ada.Unchecked_Deallocation, for objects that are or
1953 procedure Vulnerable_Free_Task
(T
: Task_Id
) is
1955 pragma Debug
(Debug
.Trace
(Self
, "Vulnerable_Free_Task", 'C', T
));
1962 Initialization
.Finalize_Attributes_Link
.all (T
);
1969 Free_Entry_Names
(T
);
1970 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
1971 end Vulnerable_Free_Task
;
1973 -- Package elaboration code
1976 -- Establish the Adafinal oftlink
1978 -- This is not done inside the central RTS initialization routine
1979 -- to avoid with-ing this package from System.Tasking.Initialization.
1981 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
1983 -- Establish soft links for subprograms that manipulate master_id's.
1984 -- This cannot be done when the RTS is initialized, because of various
1985 -- elaboration constraints.
1987 SSL
.Current_Master
:= Stages
.Current_Master
'Access;
1988 SSL
.Enter_Master
:= Stages
.Enter_Master
'Access;
1989 SSL
.Complete_Master
:= Stages
.Complete_Master
'Access;
1990 end System
.Tasking
.Stages
;