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-2005, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
35 -- Turn off polling, we do not want ATC polling to take place during
36 -- tasking operations. It causes infinite loops and other problems.
39 -- Used for Raise_Exception
41 with System.Tasking.Debug;
42 -- Used for enabling tasking facilities with gdb
44 with System.Address_Image;
45 -- Used for the function itself
47 with System.Parameters;
52 with System.Task_Info;
53 -- Used for Task_Info_Type
55 with System.Task_Primitives.Operations;
56 -- Used for Finalize_Lock
66 with System.Soft_Links;
67 -- These are procedure pointers to non-tasking routines that use task
68 -- specific data. In the absence of tasking, these routines refer to global
69 -- data. In the presense of tasking, they must be replaced with pointers to
70 -- task-specific versions. Also used for Create_TSD, Destroy_TSD,
73 with System.Tasking.Initialization;
74 -- Used for Remove_From_All_Tasks_List
77 -- Initialization.Poll_Base_Priority_Change
78 -- Finalize_Attributes_Link
79 -- Initialize_Attributes_Link
81 pragma Elaborate_All (System.Tasking.Initialization);
82 -- This insures that tasking is initialized if any tasks are created
84 with System.Tasking.Utilities;
85 -- Used for Make_Passive
88 with System.Tasking.Queuing;
89 -- Used for Dequeue_Head
91 with System.Tasking.Rendezvous;
92 -- Used for Call_Simple
94 with System.OS_Primitives;
95 -- Used for Delay_Modes
97 with System.Finalization_Implementation;
98 -- Used for System.Finalization_Implementation.Finalize_Global_List
100 with System.Secondary_Stack;
103 with System.Storage_Elements;
104 -- Used for Storage_Array
106 with System.Restrictions;
107 -- Used for Abort_Allowed
109 with System.Standard_Library;
110 -- Used for Exception_Trace
112 with System.Traces.Tasking;
113 -- Used for Send_Trace_Info
115 with Unchecked_Deallocation;
116 -- To recover from failure of ATCB initialization
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 Free is new
140 Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
142 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
143 -- This procedure outputs the task specific message for exception
146 procedure Task_Wrapper (Self_ID : Task_Id);
147 pragma Convention (C, Task_Wrapper);
148 -- This is the procedure that is called by the GNULL from the new context
149 -- when a task is created. It waits for activation and then calls the task
150 -- body procedure. When the task body procedure completes, it terminates
153 -- The Task_Wrapper's address will be provided to the underlying threads
154 -- library as the task entry point. Convention C is what makes most sense
155 -- for that purpose (Export C would make the function globally visible,
156 -- and affect the link name on which GDB depends). This will in addition
157 -- trigger an automatic stack alignment suitable for GCC's assumptions if
160 procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
161 -- Complete the calling task. This procedure must be called with
162 -- abort deferred. It should only be called by Complete_Task and
163 -- Finalizate_Global_Tasks (for the environment task).
165 procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
166 -- Complete the current master of the calling task. This procedure
167 -- must be called with abort deferred. It should only be called by
168 -- Vulnerable_Complete_Task and Complete_Master.
170 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
171 -- Signal to Self_ID's activator that Self_ID has completed activation.
172 -- This procedure must be called with abort deferred.
174 procedure Abort_Dependents (Self_ID : Task_Id);
175 -- Abort all the direct dependents of Self at its current master
176 -- nesting level, plus all of their dependents, transitively.
177 -- RTS_Lock should be locked by the caller.
179 procedure Vulnerable_Free_Task (T : Task_Id);
180 -- Recover all runtime system storage associated with the task T.
181 -- This should only be called after T has terminated and will no
182 -- longer be referenced.
184 -- For tasks created by an allocator that fails, due to an exception,
185 -- it is called from Expunge_Unactivated_Tasks.
187 -- It is also called from Unchecked_Deallocation, for objects that
188 -- are or contain tasks.
190 -- Different code is used at master completion, in Terminate_Dependents,
191 -- due to a need for tighter synchronization with the master.
193 ----------------------
194 -- Abort_Dependents --
195 ----------------------
197 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 -- If pragma Detect_Blocking is active then Program_Error must be
236 -- raised if this potentially blocking operation is called from a
239 if System.Tasking.Detect_Blocking
240 and then STPO.Self.Common.Protected_Action_Nesting > 0
242 Ada.Exceptions.Raise_Exception
243 (Program_Error'Identity, "potentially blocking operation");
246 Utilities.Abort_Tasks (Tasks);
253 -- Note that locks of activator and activated task are both locked
254 -- here. This is necessary because C.Common.State and
255 -- Self.Common.Wait_Count have to be synchronized. This is safe from
256 -- deadlock because the activator is always created before the activated
257 -- task. That satisfies our in-order-of-creation ATCB locking policy.
259 -- At one point, we may also lock the parent, if the parent is
260 -- different from the activator. That is also consistent with the
261 -- lock ordering policy, since the activator cannot be created
262 -- before the parent.
264 -- Since we are holding both the activator's lock, and Task_Wrapper
265 -- locks that before it does anything more than initialize the
266 -- low-level ATCB components, it should be safe to wait to update
267 -- the counts until we see that the thread creation is successful.
269 -- If the thread creation fails, we do need to close the entries
270 -- of the task. The first phase, of dequeuing calls, only requires
271 -- locking the acceptor's ATCB, but the waking up of the callers
272 -- requires locking the caller's ATCB. We cannot safely do this
273 -- while we are holding other locks. Therefore, the queue-clearing
274 -- operation is done in a separate pass over the activation chain.
276 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
277 Self_ID : constant Task_Id := STPO.Self;
280 Next_C, Last_C : Task_Id;
281 Activate_Prio : System.Any_Priority;
283 All_Elaborated : Boolean := True;
286 -- If pragma Detect_Blocking is active, then we must check whether this
287 -- potentially blocking operation is called from a protected action.
289 if System.Tasking.Detect_Blocking
290 and then Self_ID.Common.Protected_Action_Nesting > 0
292 Ada.Exceptions.Raise_Exception
293 (Program_Error'Identity, "potentially blocking operation");
297 (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
299 Initialization.Defer_Abort_Nestable (Self_ID);
301 pragma Assert (Self_ID.Common.Wait_Count = 0);
303 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
304 -- we finish activating the chain.
308 -- Check that all task bodies have been elaborated
310 C := Chain_Access.T_ID;
313 if C.Common.Elaborated /= null
314 and then not C.Common.Elaborated.all
316 All_Elaborated := False;
319 -- Reverse the activation chain so that tasks are
320 -- activated in the same order they're declared.
322 Next_C := C.Common.Activation_Link;
323 C.Common.Activation_Link := Last_C;
328 Chain_Access.T_ID := Last_C;
330 if not All_Elaborated then
332 Initialization.Undefer_Abort_Nestable (Self_ID);
334 (Program_Error'Identity, "Some tasks have not been elaborated");
337 -- Activate all the tasks in the chain. Creation of the thread of
338 -- control was deferred until activation. So create it now.
340 C := Chain_Access.T_ID;
342 if C.Common.State /= Terminated then
343 pragma Assert (C.Common.State = Unactivated);
345 P := C.Common.Parent;
349 if C.Common.Base_Priority < Get_Priority (Self_ID) then
350 Activate_Prio := Get_Priority (Self_ID);
352 Activate_Prio := C.Common.Base_Priority;
355 System.Task_Primitives.Operations.Create_Task
356 (C, Task_Wrapper'Address,
358 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
359 Activate_Prio, Success);
361 -- There would be a race between the created task and the
362 -- creator to do the following initialization, if we did not
363 -- have a Lock/Unlock_RTS pair in the task wrapper to prevent
364 -- it from racing ahead.
367 C.Common.State := Runnable;
370 P.Awake_Count := P.Awake_Count + 1;
371 P.Alive_Count := P.Alive_Count + 1;
373 if P.Common.State = Master_Completion_Sleep and then
374 C.Master_of_Task = P.Master_Within
376 pragma Assert (Self_ID /= P);
377 P.Common.Wait_Count := P.Common.Wait_Count + 1;
384 -- No need to set Awake_Count, State, etc. here since the loop
385 -- below will do that for any Unactivated tasks.
389 Self_ID.Common.Activation_Failed := True;
393 C := C.Common.Activation_Link;
396 if not Single_Lock then
400 -- Close the entries of any tasks that failed thread creation,
401 -- and count those that have not finished activation.
403 Write_Lock (Self_ID);
404 Self_ID.Common.State := Activator_Sleep;
406 C := Chain_Access.T_ID;
410 if C.Common.State = Unactivated then
411 C.Common.Activator := null;
412 C.Common.State := Terminated;
414 Utilities.Cancel_Queued_Entry_Calls (C);
416 elsif C.Common.Activator /= null then
417 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
421 P := C.Common.Activation_Link;
422 C.Common.Activation_Link := null;
426 -- Wait for the activated tasks to complete activation. It is
427 -- unsafe to abort any of these tasks until the count goes to zero.
430 Initialization.Poll_Base_Priority_Change (Self_ID);
431 exit when Self_ID.Common.Wait_Count = 0;
432 Sleep (Self_ID, Activator_Sleep);
435 Self_ID.Common.State := Runnable;
442 -- Remove the tasks from the chain
444 Chain_Access.T_ID := null;
445 Initialization.Undefer_Abort_Nestable (Self_ID);
447 if Self_ID.Common.Activation_Failed then
448 Self_ID.Common.Activation_Failed := False;
449 Raise_Exception (Tasking_Error'Identity,
450 "Failure during activation");
454 -------------------------
455 -- Complete_Activation --
456 -------------------------
458 procedure Complete_Activation is
459 Self_ID : constant Task_Id := STPO.Self;
462 Initialization.Defer_Abort_Nestable (Self_ID);
468 Vulnerable_Complete_Activation (Self_ID);
474 Initialization.Undefer_Abort_Nestable (Self_ID);
477 -- Why do we need to allow for nested deferral here?
479 if Runtime_Traces then
480 Send_Trace_Info (T_Activate);
482 end Complete_Activation;
484 ---------------------
485 -- Complete_Master --
486 ---------------------
488 procedure Complete_Master is
489 Self_ID : constant Task_Id := STPO.Self;
491 pragma Assert (Self_ID.Deferral_Level > 0);
492 Vulnerable_Complete_Master (Self_ID);
499 -- See comments on Vulnerable_Complete_Task for details
501 procedure Complete_Task is
502 Self_ID : constant Task_Id := STPO.Self;
505 pragma Assert (Self_ID.Deferral_Level > 0);
507 Vulnerable_Complete_Task (Self_ID);
509 -- All of our dependents have terminated. Never undefer abort again!
517 -- Compiler interface only. Do not call from within the RTS.
518 -- This must be called to create a new task.
520 procedure Create_Task
522 Size : System.Parameters.Size_Type;
523 Task_Info : System.Task_Info.Task_Info_Type;
524 Num_Entries : Task_Entry_Index;
525 Master : Master_Level;
526 State : Task_Procedure_Access;
527 Discriminants : System.Address;
528 Elaborated : Access_Boolean;
529 Chain : in out Activation_Chain;
531 Created_Task : out Task_Id)
534 Self_ID : constant Task_Id := STPO.Self;
536 Base_Priority : System.Any_Priority;
540 -- If pragma Detect_Blocking is active must be checked whether
541 -- this potentially blocking operation is called from a
544 if System.Tasking.Detect_Blocking
545 and then Self_ID.Common.Protected_Action_Nesting > 0
547 Ada.Exceptions.Raise_Exception
548 (Program_Error'Identity, "potentially blocking operation");
552 (Debug.Trace (Self_ID, "Create_Task", 'C'));
554 if Priority = Unspecified_Priority then
555 Base_Priority := Self_ID.Common.Base_Priority;
557 Base_Priority := System.Any_Priority (Priority);
560 -- Find parent P of new Task, via master level number
565 while P.Master_of_Task >= Master loop
566 P := P.Common.Parent;
571 Initialization.Defer_Abort_Nestable (Self_ID);
574 T := New_ATCB (Num_Entries);
577 Initialization.Undefer_Abort_Nestable (Self_ID);
578 Raise_Exception (Storage_Error'Identity, "Cannot allocate task");
581 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks.
582 -- Up to this point, it is possible that we may be part of
583 -- a family of tasks that is being aborted.
586 Write_Lock (Self_ID);
588 -- Now, we must check that we have not been aborted.
589 -- If so, we should give up on creating this task,
590 -- and simply return.
592 if not Self_ID.Callable then
593 pragma Assert (Self_ID.Pending_ATC_Level = 0);
594 pragma Assert (Self_ID.Pending_Action);
596 (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
600 Initialization.Undefer_Abort_Nestable (Self_ID);
602 -- ??? Should never get here
604 pragma Assert (False);
605 raise Standard'Abort_Signal;
608 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
609 Base_Priority, Task_Info, Size, T, Success);
615 Initialization.Undefer_Abort_Nestable (Self_ID);
617 (Storage_Error'Identity, "Failed to initialize task");
620 if not System.Restrictions.Abort_Allowed then
622 -- If Abort is not allowed, reset the deferral level since it will
623 -- not get changed by the generated code. Keeping a default value
624 -- of one would prevent some operations (e.g. select or delay) to
625 -- proceed successfully.
627 T.Deferral_Level := 0;
630 T.Master_of_Task := Master;
631 T.Master_Within := T.Master_of_Task + 1;
633 for L in T.Entry_Calls'Range loop
634 T.Entry_Calls (L).Self := T;
635 T.Entry_Calls (L).Level := L;
638 if Task_Image'Length = 0 then
639 T.Common.Task_Image_Len := 0;
642 T.Common.Task_Image (1) := Task_Image (Task_Image'First);
644 -- Remove unwanted blank space generated by 'Image
646 for J in Task_Image'First + 1 .. Task_Image'Last loop
647 if Task_Image (J) /= ' '
648 or else Task_Image (J - 1) /= '('
651 T.Common.Task_Image (Len) := Task_Image (J);
652 exit when Len = T.Common.Task_Image'Last;
656 T.Common.Task_Image_Len := Len;
662 -- Create TSD as early as possible in the creation of a task, since it
663 -- may be used by the operation of Ada code within the task.
665 SSL.Create_TSD (T.Common.Compiler_Data);
666 T.Common.Activation_Link := Chain.T_ID;
668 Initialization.Initialize_Attributes_Link.all (T);
670 Initialization.Undefer_Abort_Nestable (Self_ID);
672 if Runtime_Traces then
673 Send_Trace_Info (T_Create, T);
681 function Current_Master return Master_Level is
683 return STPO.Self.Master_Within;
690 procedure Enter_Master is
691 Self_ID : constant Task_Id := STPO.Self;
693 Self_ID.Master_Within := Self_ID.Master_Within + 1;
696 -------------------------------
697 -- Expunge_Unactivated_Tasks --
698 -------------------------------
700 -- See procedure Close_Entries for the general case
702 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
703 Self_ID : constant Task_Id := STPO.Self;
705 Call : Entry_Call_Link;
710 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
712 Initialization.Defer_Abort_Nestable (Self_ID);
715 -- Experimentation has shown that abort is sometimes (but not
716 -- always) already deferred when this is called.
718 -- That may indicate an error. Find out what is going on
722 pragma Assert (C.Common.State = Unactivated);
724 Temp := C.Common.Activation_Link;
726 if C.Common.State = Unactivated then
730 for J in 1 .. C.Entry_Num loop
731 Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
732 pragma Assert (Call = null);
737 Initialization.Remove_From_All_Tasks_List (C);
740 Vulnerable_Free_Task (C);
746 Initialization.Undefer_Abort_Nestable (Self_ID);
747 end Expunge_Unactivated_Tasks;
749 ---------------------------
750 -- Finalize_Global_Tasks --
751 ---------------------------
754 -- We have a potential problem here if finalization of global
755 -- objects does anything with signals or the timer server, since
756 -- by that time those servers have terminated.
758 -- It is hard to see how that would occur
760 -- However, a better solution might be to do all this finalization
761 -- using the global finalization chain.
763 procedure Finalize_Global_Tasks is
764 Self_ID : constant Task_Id := STPO.Self;
768 if Self_ID.Deferral_Level = 0 then
770 -- In principle, we should be able to predict whether
771 -- abort is already deferred here (and it should not be deferred
772 -- yet but in practice it seems Finalize_Global_Tasks is being
773 -- called sometimes, from RTS code for exceptions, with abort already
776 Initialization.Defer_Abort_Nestable (Self_ID);
778 -- Never undefer again!!!
781 -- This code is only executed by the environment task
783 pragma Assert (Self_ID = Environment_Task);
785 -- Set Environment_Task'Callable to false to notify library-level tasks
786 -- that it is waiting for them (cf 5619-003).
788 Self_ID.Callable := False;
790 -- Exit level 2 master, for normal tasks in library-level packages
794 -- Force termination of "independent" library-level server tasks
798 Abort_Dependents (Self_ID);
800 if not Single_Lock then
804 -- We need to explicitely wait for the task to be terminated here
805 -- because on true concurrent system, we may end this procedure
806 -- before the tasks are really terminated.
808 Write_Lock (Self_ID);
811 exit when Utilities.Independent_Task_Count = 0;
813 -- We used to yield here, but this did not take into account
814 -- low priority tasks that would cause dead lock in some cases.
818 (Self_ID, 0.01, System.OS_Primitives.Relative,
819 Self_ID.Common.State, Ignore, Ignore);
822 -- ??? On multi-processor environments, it seems that the above loop
823 -- isn't sufficient, so we need to add an additional delay.
826 (Self_ID, 0.01, System.OS_Primitives.Relative,
827 Self_ID.Common.State, Ignore, Ignore);
835 -- Complete the environment task
837 Vulnerable_Complete_Task (Self_ID);
839 System.Finalization_Implementation.Finalize_Global_List;
841 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
842 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
843 SSL.Lock_Task := SSL.Task_Lock_NT'Access;
844 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access;
845 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
846 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
847 SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access;
848 SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access;
849 SSL.Get_Exc_Stack_Addr := SSL.Get_Exc_Stack_Addr_NT'Access;
850 SSL.Set_Exc_Stack_Addr := SSL.Set_Exc_Stack_Addr_NT'Access;
851 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
852 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
854 -- Don't bother trying to finalize Initialization.Global_Task_Lock
855 -- and System.Task_Primitives.RTS_Lock.
857 end Finalize_Global_Tasks;
863 procedure Free_Task (T : Task_Id) is
864 Self_Id : constant Task_Id := Self;
867 if T.Common.State = Terminated then
869 -- It is not safe to call Abort_Defer or Write_Lock at this stage
871 Initialization.Task_Lock (Self_Id);
874 Initialization.Remove_From_All_Tasks_List (T);
877 Initialization.Task_Unlock (Self_Id);
879 System.Task_Primitives.Operations.Finalize_TCB (T);
881 -- If the task is not terminated, then we simply ignore the call. This
882 -- happens when a user program attempts an unchecked deallocation on
883 -- a non-terminated task.
894 -- The task wrapper is a procedure that is called first for each task
895 -- task body, and which in turn calls the compiler-generated task body
896 -- procedure. The wrapper's main job is to do initialization for the task.
897 -- It also has some locally declared objects that server as per-task local
898 -- data. Task finalization is done by Complete_Task, which is called from
899 -- an at-end handler that the compiler generates.
901 procedure Task_Wrapper (Self_ID : Task_Id) is
902 use type System.Parameters.Size_Type;
903 use type SSE.Storage_Offset;
904 use System.Standard_Library;
907 aliased SSE.Storage_Array
908 (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
909 SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
911 Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
913 SEH_Table : aliased SSE.Storage_Array (1 .. 8);
914 -- Structured Exception Registration table (2 words)
916 procedure Install_SEH_Handler (Addr : System.Address);
917 pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
918 -- Install the SEH (Structured Exception Handling) handler
921 pragma Assert (Self_ID.Deferral_Level = 1);
923 if not Parameters.Sec_Stack_Dynamic then
924 Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
925 Secondary_Stack'Address;
926 SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
929 -- Set the guard page at the bottom of the stack. The call to
930 -- unprotect the page is done in Terminate_Task
932 Stack_Guard (Self_ID, True);
934 -- Initialize low-level TCB components, that cannot be initialized
935 -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and
936 -- also Self_ID.LL.Thread
938 Enter_Task (Self_ID);
940 -- We setup the SEH (Structured Exception Handling) handler if supported
943 Install_SEH_Handler (SEH_Table'Address);
945 -- We lock RTS_Lock to wait for activator to finish activating
946 -- the rest of the chain, so that everyone in the chain comes out
947 -- in priority order.
949 -- This also protects the value of
950 -- Self_ID.Common.Activator.Common.Wait_Count.
956 -- We are separating the following portion of the code in order to
957 -- place the exception handlers in a different block. In this way,
958 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
959 -- set Self in Enter_Task
961 -- Call the task body procedure
963 -- The task body is called with abort still deferred. That
964 -- eliminates a dangerous window, for which we had to patch-up in
967 -- During the expansion of the task body, we insert an RTS-call
968 -- to Abort_Undefer, at the first point where abort should be
971 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
972 Initialization.Defer_Abort_Nestable (Self_ID);
975 -- We can't call Terminate_Task in the exception handlers below,
976 -- since there may be (e.g. in the case of GCC exception handling)
977 -- clean ups associated with the exception handler that need to
978 -- access task specific data.
980 -- Defer abort so that this task can't be aborted while exiting
982 when Standard'Abort_Signal =>
983 Initialization.Defer_Abort_Nestable (Self_ID);
986 -- ??? Using an E : others here causes CD2C11A to fail on
987 -- DEC Unix, see 7925-005.
989 Initialization.Defer_Abort_Nestable (Self_ID);
991 -- Perform the task specific exception tracing duty. We handle
992 -- these outputs here and not in the common notification routine
993 -- because we need access to tasking related data and we don't
994 -- want to drag dependencies against tasking related units in the
995 -- the common notification units. Additionally, no trace is ever
996 -- triggered from the common routine for the Unhandled_Raise case
997 -- in tasks, since an exception never appears unhandled in this
998 -- context because of this handler.
1000 if Exception_Trace = Unhandled_Raise then
1001 Trace_Unhandled_Exception_In_Task (Self_ID);
1005 Terminate_Task (Self_ID);
1008 --------------------
1009 -- Terminate_Task --
1010 --------------------
1012 -- Before we allow the thread to exit, we must clean up. This is a
1013 -- a delicate job. We must wake up the task's master, who may immediately
1014 -- try to deallocate the ATCB out from under the current task WHILE IT IS
1017 -- To avoid this, the parent task must be blocked up to the latest
1018 -- statement executed. The trouble is that we have another step that we
1019 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1020 -- We have to postpone that until the end because compiler-generated code
1021 -- is likely to try to access that data at just about any point.
1023 -- We can't call Destroy_TSD while we are holding any other locks, because
1024 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1025 -- that to be the outermost lock. Our first "solution" was to just lock
1026 -- Global_Task_Lock in addition to the other locks, and force the parent
1027 -- to also lock this lock between its wakeup and its freeing of the ATCB.
1028 -- See Complete_Task for the parent-side of the code that has the matching
1029 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1030 -- since the operation Task_Unlock continued to access the ATCB after
1031 -- unlocking, after which the parent was observed to race ahead,
1032 -- deallocate the ATCB, and then reallocate it to another task. The
1033 -- call to Undefer_Abortion in Task_Unlock by the "terminated" task was
1034 -- overwriting the data of the new task that reused the ATCB! To solve
1035 -- this problem, we introduced the new operation Final_Task_Unlock.
1037 procedure Terminate_Task (Self_ID : Task_Id) is
1038 Environment_Task : constant Task_Id := STPO.Environment_Task;
1039 Master_of_Task : Integer;
1042 Debug.Task_Termination_Hook;
1044 if Runtime_Traces then
1045 Send_Trace_Info (T_Terminate);
1048 -- Since GCC cannot allocate stack chunks efficiently without reordering
1049 -- some of the allocations, we have to handle this unexpected situation
1050 -- here. We should normally never have to call Vulnerable_Complete_Task
1051 -- here. See 6602-003 for more details.
1053 if Self_ID.Common.Activator /= null then
1054 Vulnerable_Complete_Task (Self_ID);
1057 Initialization.Task_Lock (Self_ID);
1063 Master_of_Task := Self_ID.Master_of_Task;
1065 -- Check if the current task is an independent task If so, decrement
1066 -- the Independent_Task_Count value.
1068 if Master_of_Task = 2 then
1070 Utilities.Independent_Task_Count :=
1071 Utilities.Independent_Task_Count - 1;
1073 Write_Lock (Environment_Task);
1074 Utilities.Independent_Task_Count :=
1075 Utilities.Independent_Task_Count - 1;
1076 Unlock (Environment_Task);
1080 -- Unprotect the guard page if needed
1082 Stack_Guard (Self_ID, False);
1084 Utilities.Make_Passive (Self_ID, Task_Completed => True);
1090 pragma Assert (Check_Exit (Self_ID));
1092 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
1093 Initialization.Final_Task_Unlock (Self_ID);
1095 -- WARNING: past this point, this thread must assume that the ATCB
1096 -- has been deallocated. It should not be accessed again.
1098 if Master_of_Task > 0 then
1107 function Terminated (T : Task_Id) return Boolean is
1108 Self_ID : constant Task_Id := STPO.Self;
1112 Initialization.Defer_Abort_Nestable (Self_ID);
1119 Result := T.Common.State = Terminated;
1126 Initialization.Undefer_Abort_Nestable (Self_ID);
1130 ----------------------------------------
1131 -- Trace_Unhandled_Exception_In_Task --
1132 ----------------------------------------
1134 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
1135 procedure To_Stderr (S : String);
1136 pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
1138 use System.Task_Info;
1139 use System.Soft_Links;
1140 use System.Standard_Library;
1142 function To_Address is new
1143 Unchecked_Conversion (Task_Id, System.Address);
1145 function Tailored_Exception_Information
1146 (E : Exception_Occurrence) return String;
1148 (Ada, Tailored_Exception_Information,
1149 "__gnat_tailored_exception_information");
1151 Excep : constant Exception_Occurrence_Access :=
1152 SSL.Get_Current_Excep.all;
1155 -- This procedure is called by the task outermost handler in
1156 -- Task_Wrapper below, so only once the task stack has been fully
1157 -- unwound. The common notification routine has been called at the
1158 -- raise point already.
1160 To_Stderr ("task ");
1162 if Self_Id.Common.Task_Image_Len /= 0 then
1164 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
1168 To_Stderr (System.Address_Image (To_Address (Self_Id)));
1169 To_Stderr (" terminated by unhandled exception");
1170 To_Stderr ((1 => ASCII.LF));
1171 To_Stderr (Tailored_Exception_Information (Excep.all));
1172 end Trace_Unhandled_Exception_In_Task;
1174 ------------------------------------
1175 -- Vulnerable_Complete_Activation --
1176 ------------------------------------
1178 -- As in several other places, the locks of the activator and activated
1179 -- task are both locked here. This follows our deadlock prevention lock
1180 -- ordering policy, since the activated task must be created after the
1183 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
1184 Activator : constant Task_Id := Self_ID.Common.Activator;
1187 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
1189 Write_Lock (Activator);
1190 Write_Lock (Self_ID);
1192 pragma Assert (Self_ID.Common.Activator /= null);
1194 -- Remove dangling reference to Activator, since a task may
1195 -- outlive its activator.
1197 Self_ID.Common.Activator := null;
1199 -- Wake up the activator, if it is waiting for a chain of tasks to
1200 -- activate, and we are the last in the chain to complete activation.
1202 if Activator.Common.State = Activator_Sleep then
1203 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
1205 if Activator.Common.Wait_Count = 0 then
1206 Wakeup (Activator, Activator_Sleep);
1210 -- The activator raises a Tasking_Error if any task it is activating
1211 -- is completed before the activation is done. However, if the reason
1212 -- for the task completion is an abort, we do not raise an exception.
1215 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
1216 Activator.Common.Activation_Failed := True;
1222 -- After the activation, active priority should be the same
1223 -- as base priority. We must unlock the Activator first,
1224 -- though, since it should not wait if we have lower priority.
1226 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
1227 Write_Lock (Self_ID);
1228 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1231 end Vulnerable_Complete_Activation;
1233 --------------------------------
1234 -- Vulnerable_Complete_Master --
1235 --------------------------------
1237 procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
1240 CM : constant Master_Level := Self_ID.Master_Within;
1241 T : aliased Task_Id;
1243 To_Be_Freed : Task_Id;
1244 -- This is a list of ATCBs to be freed, after we have released
1245 -- all RTS locks. This is necessary because of the locking order
1246 -- rules, since the storage manager uses Global_Task_Lock.
1248 pragma Warnings (Off);
1249 function Check_Unactivated_Tasks return Boolean;
1250 pragma Warnings (On);
1251 -- Temporary error-checking code below. This is part of the checks
1252 -- added in the new run time. Call it only inside a pragma Assert.
1254 -----------------------------
1255 -- Check_Unactivated_Tasks --
1256 -----------------------------
1258 function Check_Unactivated_Tasks return Boolean is
1260 if not Single_Lock then
1264 Write_Lock (Self_ID);
1266 C := All_Tasks_List;
1267 while C /= null loop
1268 if C.Common.Activator = Self_ID then
1272 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1275 if C.Common.State = Unactivated then
1282 C := C.Common.All_Tasks_Link;
1287 if not Single_Lock then
1292 end Check_Unactivated_Tasks;
1294 -- Start of processing for Vulnerable_Complete_Master
1298 (Debug.Trace (Self_ID, "V_Complete_Master", 'C'));
1300 pragma Assert (Self_ID.Common.Wait_Count = 0);
1301 pragma Assert (Self_ID.Deferral_Level > 0);
1303 -- Count how many active dependent tasks this master currently
1304 -- has, and record this in Wait_Count.
1306 -- This count should start at zero, since it is initialized to
1307 -- zero for new tasks, and the task should not exit the
1308 -- sleep-loops that use this count until the count reaches zero.
1311 Write_Lock (Self_ID);
1313 C := All_Tasks_List;
1314 while C /= null loop
1315 if C.Common.Activator = Self_ID then
1316 pragma Assert (C.Common.State = Unactivated);
1319 C.Common.Activator := null;
1320 C.Common.State := Terminated;
1321 C.Callable := False;
1322 Utilities.Cancel_Queued_Entry_Calls (C);
1326 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1329 if C.Awake_Count /= 0 then
1330 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1336 C := C.Common.All_Tasks_Link;
1339 Self_ID.Common.State := Master_Completion_Sleep;
1342 if not Single_Lock then
1346 -- Wait until dependent tasks are all terminated or ready to terminate.
1347 -- While waiting, the task may be awakened if the task's priority needs
1348 -- changing, or this master is aborted. In the latter case, we want
1349 -- to abort the dependents, and resume waiting until Wait_Count goes
1352 Write_Lock (Self_ID);
1355 Initialization.Poll_Base_Priority_Change (Self_ID);
1356 exit when Self_ID.Common.Wait_Count = 0;
1358 -- Here is a difference as compared to Complete_Master
1360 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1361 and then not Self_ID.Dependents_Aborted
1364 Abort_Dependents (Self_ID);
1368 Abort_Dependents (Self_ID);
1370 Write_Lock (Self_ID);
1373 Sleep (Self_ID, Master_Completion_Sleep);
1377 Self_ID.Common.State := Runnable;
1380 -- Dependents are all terminated or on terminate alternatives.
1381 -- Now, force those on terminate alternatives to terminate, by
1384 pragma Assert (Check_Unactivated_Tasks);
1386 if Self_ID.Alive_Count > 1 then
1388 -- Consider finding a way to skip the following extra steps if there
1389 -- are no dependents with terminate alternatives. This could be done
1390 -- by adding another count to the ATCB, similar to Awake_Count, but
1391 -- keeping track of tasks that are on terminate alternatives.
1393 pragma Assert (Self_ID.Common.Wait_Count = 0);
1395 -- Force any remaining dependents to terminate by aborting them
1397 if not Single_Lock then
1401 Abort_Dependents (Self_ID);
1403 -- Above, when we "abort" the dependents we are simply using this
1404 -- operation for convenience. We are not required to support the full
1405 -- abort-statement semantics; in particular, we are not required to
1406 -- immediately cancel any queued or in-service entry calls. That is
1407 -- good, because if we tried to cancel a call we would need to lock
1408 -- the caller, in order to wake the caller up. Our anti-deadlock
1409 -- rules prevent us from doing that without releasing the locks on C
1410 -- and Self_ID. Releasing and retaking those locks would be wasteful
1411 -- at best, and should not be considered further without more
1412 -- detailed analysis of potential concurrent accesses to the
1413 -- ATCBs of C and Self_ID.
1415 -- Count how many "alive" dependent tasks this master currently
1416 -- has, and record this in Wait_Count. This count should start at
1417 -- zero, since it is initialized to zero for new tasks, and the
1418 -- task should not exit the sleep-loops that use this count until
1419 -- the count reaches zero.
1421 pragma Assert (Self_ID.Common.Wait_Count = 0);
1423 Write_Lock (Self_ID);
1425 C := All_Tasks_List;
1426 while C /= null loop
1427 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1430 pragma Assert (C.Awake_Count = 0);
1432 if C.Alive_Count > 0 then
1433 pragma Assert (C.Terminate_Alternative);
1434 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1440 C := C.Common.All_Tasks_Link;
1443 Self_ID.Common.State := Master_Phase_2_Sleep;
1446 if not Single_Lock then
1450 -- Wait for all counted tasks to finish terminating themselves
1452 Write_Lock (Self_ID);
1455 Initialization.Poll_Base_Priority_Change (Self_ID);
1456 exit when Self_ID.Common.Wait_Count = 0;
1457 Sleep (Self_ID, Master_Phase_2_Sleep);
1460 Self_ID.Common.State := Runnable;
1464 -- We don't wake up for abort here. We are already terminating just as
1465 -- fast as we can, so there is no point.
1467 -- Remove terminated tasks from the list of Self_ID's dependents, but
1468 -- don't free their ATCBs yet, because of lock order restrictions,
1469 -- which don't allow us to call "free" or "malloc" while holding any
1470 -- other locks. Instead, we put those ATCBs to be freed onto a
1471 -- temporary list, called To_Be_Freed.
1473 if not Single_Lock then
1477 C := All_Tasks_List;
1479 while C /= null loop
1480 if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then
1482 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
1484 All_Tasks_List := C.Common.All_Tasks_Link;
1487 T := C.Common.All_Tasks_Link;
1488 C.Common.All_Tasks_Link := To_Be_Freed;
1494 C := C.Common.All_Tasks_Link;
1500 -- Free all the ATCBs on the list To_Be_Freed
1502 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1503 -- any interrupt entries are detached from them they should no longer
1506 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1507 -- avoid a race between a terminating task and its parent. The parent
1508 -- might try to deallocate the ACTB out from underneath the exiting
1509 -- task. Note that Free will also lock Global_Task_Lock, but that is
1510 -- OK, since this is the *one* lock for which we have a mechanism to
1511 -- support nested locking. See Task_Wrapper and its finalizer for more
1515 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1516 -- references to terminated library-level tasks, which could
1517 -- otherwise occur during finalization of library-level objects.
1518 -- A better solution might be to hook task objects into the
1519 -- finalization chain and deallocate the ATCB when the task
1520 -- object is deallocated. However, this change is not likely
1521 -- to gain anything significant, since all this storage should
1522 -- be recovered en-masse when the process exits.
1524 while To_Be_Freed /= null loop
1526 To_Be_Freed := T.Common.All_Tasks_Link;
1528 -- ??? On SGI there is currently no Interrupt_Manager, that's
1529 -- why we need to check if the Interrupt_Manager_ID is null
1531 if T.Interrupt_Entry and Interrupt_Manager_ID /= null then
1533 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
1534 -- Corresponds to the entry index of System.Interrupts.
1535 -- Interrupt_Manager.Detach_Interrupt_Entries.
1536 -- Be sure to update this value when changing
1537 -- Interrupt_Manager specs.
1539 type Param_Type is access all Task_Id;
1541 Param : aliased Param_Type := T'Access;
1544 System.Tasking.Rendezvous.Call_Simple
1545 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
1550 if (T.Common.Parent /= null
1551 and then T.Common.Parent.Common.Parent /= null)
1552 or else T.Master_of_Task > 3
1554 Initialization.Task_Lock (Self_ID);
1556 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1557 -- has not been called yet (case of an unactivated task).
1559 if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then
1560 SSL.Destroy_TSD (T.Common.Compiler_Data);
1563 Vulnerable_Free_Task (T);
1564 Initialization.Task_Unlock (Self_ID);
1568 -- It might seem nice to let the terminated task deallocate its own
1569 -- ATCB. That would not cover the case of unactivated tasks. It also
1570 -- would force us to keep the underlying thread around past termination,
1571 -- since references to the ATCB are possible past termination.
1572 -- Currently, we get rid of the thread as soon as the task terminates,
1573 -- and let the parent recover the ATCB later.
1575 -- Some day, if we want to recover the ATCB earlier, at task
1576 -- termination, we could consider using "fat task IDs", that include the
1577 -- serial number with the ATCB pointer, to catch references to tasks
1578 -- that no longer have ATCBs. It is not clear how much this would gain,
1579 -- since the user-level task object would still be occupying storage.
1581 -- Make next master level up active.
1582 -- We don't need to lock the ATCB, since the value is only updated by
1583 -- each task for itself.
1585 Self_ID.Master_Within := CM - 1;
1586 end Vulnerable_Complete_Master;
1588 ------------------------------
1589 -- Vulnerable_Complete_Task --
1590 ------------------------------
1592 -- Complete the calling task
1594 -- This procedure must be called with abort deferred. (That's why the
1595 -- name has "Vulnerable" in it.) It should only be called by Complete_Task
1596 -- and Finalize_Global_Tasks (for the environment task).
1598 -- The effect is similar to that of Complete_Master. Differences include
1599 -- the closing of entries here, and computation of the number of active
1600 -- dependent tasks in Complete_Master.
1602 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1603 -- because that does its own locking, and because we do not need the lock
1604 -- to test Self_ID.Common.Activator. That value should only be read and
1605 -- modified by Self.
1607 procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
1609 pragma Assert (Self_ID.Deferral_Level > 0);
1610 pragma Assert (Self_ID = Self);
1611 pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1
1613 Self_ID.Master_Within = Self_ID.Master_of_Task + 2);
1614 pragma Assert (Self_ID.Common.Wait_Count = 0);
1615 pragma Assert (Self_ID.Open_Accepts = null);
1616 pragma Assert (Self_ID.ATC_Nesting_Level = 1);
1618 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
1624 Write_Lock (Self_ID);
1625 Self_ID.Callable := False;
1627 -- In theory, Self should have no pending entry calls left on its
1628 -- call-stack. Each async. select statement should clean its own call,
1629 -- and blocking entry calls should defer abort until the calls are
1630 -- cancelled, then clean up.
1632 Utilities.Cancel_Queued_Entry_Calls (Self_ID);
1635 if Self_ID.Common.Activator /= null then
1636 Vulnerable_Complete_Activation (Self_ID);
1643 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
1644 -- we may have dependent tasks for which we need to wait.
1645 -- Otherwise, we can just exit.
1647 if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
1648 Vulnerable_Complete_Master (Self_ID);
1650 end Vulnerable_Complete_Task;
1652 --------------------------
1653 -- Vulnerable_Free_Task --
1654 --------------------------
1656 -- Recover all runtime system storage associated with the task T.
1657 -- This should only be called after T has terminated and will no
1658 -- longer be referenced.
1660 -- For tasks created by an allocator that fails, due to an exception,
1661 -- it is called from Expunge_Unactivated_Tasks.
1663 -- For tasks created by elaboration of task object declarations it
1664 -- is called from the finalization code of the Task_Wrapper procedure.
1665 -- It is also called from Unchecked_Deallocation, for objects that
1666 -- are or contain tasks.
1668 procedure Vulnerable_Free_Task (T : Task_Id) is
1670 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
1677 Initialization.Finalize_Attributes_Link.all (T);
1684 System.Task_Primitives.Operations.Finalize_TCB (T);
1685 end Vulnerable_Free_Task;
1687 -- Package elaboration code
1690 -- Establish the Adafinal softlink
1692 -- This is not done inside the central RTS initialization routine
1693 -- to avoid with-ing this package from System.Tasking.Initialization.
1695 SSL.Adafinal := Finalize_Global_Tasks'Access;
1697 -- Establish soft links for subprograms that manipulate master_id's.
1698 -- This cannot be done when the RTS is initialized, because of various
1699 -- elaboration constraints.
1701 SSL.Current_Master := Stages.Current_Master'Access;
1702 SSL.Enter_Master := Stages.Enter_Master'Access;
1703 SSL.Complete_Master := Stages.Complete_Master'Access;
1704 end System.Tasking.Stages;