1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . S T A G E S --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
35 -- Turn off polling, we do not want ATC polling to take place during
36 -- tasking operations. It causes infinite loops and other problems.
39 -- Used for Raise_Exception
41 with System.Tasking.Debug;
42 -- Used for enabling tasking facilities with gdb
44 with System.Address_Image;
45 -- Used for the function itself
47 with System.Task_Primitives.Operations;
48 -- Used for Finalize_Lock
58 with System.Soft_Links;
59 -- These are procedure pointers to non-tasking routines that use task
60 -- specific data. In the absence of tasking, these routines refer to global
61 -- data. In the presense of tasking, they must be replaced with pointers to
62 -- task-specific versions. Also used for Create_TSD, Destroy_TSD,
63 -- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler.
65 with System.Tasking.Initialization;
66 -- Used for Remove_From_All_Tasks_List
69 -- Finalize_Attributes_Link
70 -- Initialize_Attributes_Link
72 pragma Elaborate_All (System.Tasking.Initialization);
73 -- This insures that tasking is initialized if any tasks are created
75 with System.Tasking.Utilities;
76 -- Used for Make_Passive
80 with System.Tasking.Queuing;
81 -- Used for Dequeue_Head
83 with System.Tasking.Rendezvous;
84 -- Used for Call_Simple
86 with System.OS_Primitives;
87 -- Used for Delay_Modes
89 with System.Secondary_Stack;
92 with System.Storage_Elements;
93 -- Used for Storage_Array
95 with System.Restrictions;
96 -- Used for Abort_Allowed
98 with System.Standard_Library;
99 -- Used for Exception_Trace
101 with System.Traces.Tasking;
102 -- Used for Send_Trace_Info
104 with Ada.Unchecked_Deallocation;
105 -- To recover from failure of ATCB initialization
107 with System.Stack_Usage;
109 package body System.Tasking.Stages is
111 package STPO renames System.Task_Primitives.Operations;
112 package SSL renames System.Soft_Links;
113 package SSE renames System.Storage_Elements;
114 package SST renames System.Secondary_Stack;
120 use Task_Primitives.Operations;
124 use System.Traces.Tasking;
126 -----------------------
127 -- Local Subprograms --
128 -----------------------
130 procedure Free is new
131 Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
133 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
134 -- This procedure outputs the task specific message for exception
137 procedure Task_Wrapper (Self_ID : Task_Id);
138 pragma Convention (C, Task_Wrapper);
139 -- This is the procedure that is called by the GNULL from the new context
140 -- when a task is created. It waits for activation and then calls the task
141 -- body procedure. When the task body procedure completes, it terminates
144 -- The Task_Wrapper's address will be provided to the underlying threads
145 -- library as the task entry point. Convention C is what makes most sense
146 -- for that purpose (Export C would make the function globally visible,
147 -- and affect the link name on which GDB depends). This will in addition
148 -- trigger an automatic stack alignment suitable for GCC's assumptions if
151 -- "Vulnerable_..." in the procedure names below means they must be called
152 -- with abort deferred.
154 procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
155 -- Complete the calling task. This procedure must be called with
156 -- abort deferred. It should only be called by Complete_Task and
157 -- Finalizate_Global_Tasks (for the environment task).
159 procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
160 -- Complete the current master of the calling task. This procedure
161 -- must be called with abort deferred. It should only be called by
162 -- Vulnerable_Complete_Task and Complete_Master.
164 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
165 -- Signal to Self_ID's activator that Self_ID has completed activation.
166 -- This procedure must be called with abort deferred.
168 procedure Abort_Dependents (Self_ID : Task_Id);
169 -- Abort all the direct dependents of Self at its current master
170 -- nesting level, plus all of their dependents, transitively.
171 -- RTS_Lock should be locked by the caller.
173 procedure Vulnerable_Free_Task (T : Task_Id);
174 -- Recover all runtime system storage associated with the task T.
175 -- This should only be called after T has terminated and will no
176 -- longer be referenced.
178 -- For tasks created by an allocator that fails, due to an exception,
179 -- it is called from Expunge_Unactivated_Tasks.
181 -- It is also called from Ada.Unchecked_Deallocation, for objects that
182 -- are or contain tasks.
184 -- Different code is used at master completion, in Terminate_Dependents,
185 -- due to a need for tighter synchronization with the master.
187 ----------------------
188 -- Abort_Dependents --
189 ----------------------
191 procedure Abort_Dependents (Self_ID : Task_Id) is
198 P := C.Common.Parent;
202 -- ??? C is supposed to take care of its own dependents, so
203 -- there should be no need to worry about them. Need to double
206 if C.Master_of_Task = Self_ID.Master_Within then
207 Utilities.Abort_One_Task (Self_ID, C);
208 C.Dependents_Aborted := True;
214 P := P.Common.Parent;
217 C := C.Common.All_Tasks_Link;
220 Self_ID.Dependents_Aborted := True;
221 end Abort_Dependents;
227 procedure Abort_Tasks (Tasks : Task_List) is
229 Utilities.Abort_Tasks (Tasks);
236 -- Note that locks of activator and activated task are both locked
237 -- here. This is necessary because C.Common.State and
238 -- Self.Common.Wait_Count have to be synchronized. This is safe from
239 -- deadlock because the activator is always created before the activated
240 -- task. That satisfies our in-order-of-creation ATCB locking policy.
242 -- At one point, we may also lock the parent, if the parent is
243 -- different from the activator. That is also consistent with the
244 -- lock ordering policy, since the activator cannot be created
245 -- before the parent.
247 -- Since we are holding both the activator's lock, and Task_Wrapper
248 -- locks that before it does anything more than initialize the
249 -- low-level ATCB components, it should be safe to wait to update
250 -- the counts until we see that the thread creation is successful.
252 -- If the thread creation fails, we do need to close the entries
253 -- of the task. The first phase, of dequeuing calls, only requires
254 -- locking the acceptor's ATCB, but the waking up of the callers
255 -- requires locking the caller's ATCB. We cannot safely do this
256 -- while we are holding other locks. Therefore, the queue-clearing
257 -- operation is done in a separate pass over the activation chain.
259 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
260 Self_ID : constant Task_Id := STPO.Self;
263 Next_C, Last_C : Task_Id;
264 Activate_Prio : System.Any_Priority;
266 All_Elaborated : Boolean := True;
269 -- If pragma Detect_Blocking is active, then we must check whether this
270 -- potentially blocking operation is called from a protected action.
272 if System.Tasking.Detect_Blocking
273 and then Self_ID.Common.Protected_Action_Nesting > 0
275 Ada.Exceptions.Raise_Exception
276 (Program_Error'Identity, "potentially blocking operation");
280 (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
282 Initialization.Defer_Abort_Nestable (Self_ID);
284 pragma Assert (Self_ID.Common.Wait_Count = 0);
286 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
287 -- we finish activating the chain.
291 -- Check that all task bodies have been elaborated
293 C := Chain_Access.T_ID;
296 if C.Common.Elaborated /= null
297 and then not C.Common.Elaborated.all
299 All_Elaborated := False;
302 -- Reverse the activation chain so that tasks are
303 -- activated in the same order they're declared.
305 Next_C := C.Common.Activation_Link;
306 C.Common.Activation_Link := Last_C;
311 Chain_Access.T_ID := Last_C;
313 if not All_Elaborated then
315 Initialization.Undefer_Abort_Nestable (Self_ID);
317 (Program_Error'Identity, "Some tasks have not been elaborated");
320 -- Activate all the tasks in the chain. Creation of the thread of
321 -- control was deferred until activation. So create it now.
323 C := Chain_Access.T_ID;
325 if C.Common.State /= Terminated then
326 pragma Assert (C.Common.State = Unactivated);
328 P := C.Common.Parent;
332 if C.Common.Base_Priority < Get_Priority (Self_ID) then
333 Activate_Prio := Get_Priority (Self_ID);
335 Activate_Prio := C.Common.Base_Priority;
338 System.Task_Primitives.Operations.Create_Task
339 (C, Task_Wrapper'Address,
341 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
342 Activate_Prio, Success);
344 -- There would be a race between the created task and the
345 -- creator to do the following initialization, if we did not
346 -- have a Lock/Unlock_RTS pair in the task wrapper to prevent
347 -- it from racing ahead.
350 C.Common.State := Runnable;
353 P.Awake_Count := P.Awake_Count + 1;
354 P.Alive_Count := P.Alive_Count + 1;
356 if P.Common.State = Master_Completion_Sleep and then
357 C.Master_of_Task = P.Master_Within
359 pragma Assert (Self_ID /= P);
360 P.Common.Wait_Count := P.Common.Wait_Count + 1;
367 -- No need to set Awake_Count, State, etc. here since the loop
368 -- below will do that for any Unactivated tasks.
372 Self_ID.Common.Activation_Failed := True;
376 C := C.Common.Activation_Link;
379 if not Single_Lock then
383 -- Close the entries of any tasks that failed thread creation,
384 -- and count those that have not finished activation.
386 Write_Lock (Self_ID);
387 Self_ID.Common.State := Activator_Sleep;
389 C := Chain_Access.T_ID;
393 if C.Common.State = Unactivated then
394 C.Common.Activator := null;
395 C.Common.State := Terminated;
397 Utilities.Cancel_Queued_Entry_Calls (C);
399 elsif C.Common.Activator /= null then
400 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
404 P := C.Common.Activation_Link;
405 C.Common.Activation_Link := null;
409 -- Wait for the activated tasks to complete activation. It is
410 -- unsafe to abort any of these tasks until the count goes to zero.
413 exit when Self_ID.Common.Wait_Count = 0;
414 Sleep (Self_ID, Activator_Sleep);
417 Self_ID.Common.State := Runnable;
424 -- Remove the tasks from the chain
426 Chain_Access.T_ID := null;
427 Initialization.Undefer_Abort_Nestable (Self_ID);
429 if Self_ID.Common.Activation_Failed then
430 Self_ID.Common.Activation_Failed := False;
431 Raise_Exception (Tasking_Error'Identity,
432 "Failure during activation");
436 -------------------------
437 -- Complete_Activation --
438 -------------------------
440 procedure Complete_Activation is
441 Self_ID : constant Task_Id := STPO.Self;
444 Initialization.Defer_Abort_Nestable (Self_ID);
450 Vulnerable_Complete_Activation (Self_ID);
456 Initialization.Undefer_Abort_Nestable (Self_ID);
459 -- Why do we need to allow for nested deferral here?
461 if Runtime_Traces then
462 Send_Trace_Info (T_Activate);
464 end Complete_Activation;
466 ---------------------
467 -- Complete_Master --
468 ---------------------
470 procedure Complete_Master is
471 Self_ID : constant Task_Id := STPO.Self;
474 (Self_ID.Deferral_Level > 0
475 or else not System.Restrictions.Abort_Allowed);
476 Vulnerable_Complete_Master (Self_ID);
483 -- See comments on Vulnerable_Complete_Task for details
485 procedure Complete_Task is
486 Self_ID : constant Task_Id := STPO.Self;
490 (Self_ID.Deferral_Level > 0
491 or else not System.Restrictions.Abort_Allowed);
493 Vulnerable_Complete_Task (Self_ID);
495 -- All of our dependents have terminated. Never undefer abort again!
503 -- Compiler interface only. Do not call from within the RTS.
504 -- This must be called to create a new task.
506 procedure Create_Task
508 Size : System.Parameters.Size_Type;
509 Task_Info : System.Task_Info.Task_Info_Type;
510 Num_Entries : Task_Entry_Index;
511 Master : Master_Level;
512 State : Task_Procedure_Access;
513 Discriminants : System.Address;
514 Elaborated : Access_Boolean;
515 Chain : in out Activation_Chain;
517 Created_Task : out Task_Id)
520 Self_ID : constant Task_Id := STPO.Self;
522 Base_Priority : System.Any_Priority;
526 -- If Master is greater than the current master, it means that Master
527 -- has already awaited its dependent tasks. This raises Program_Error,
528 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
530 if Self_ID.Master_of_Task /= Foreign_Task_Level
531 and then Master > Self_ID.Master_Within
533 raise Program_Error with
534 "create task after awaiting termination";
537 -- If pragma Detect_Blocking is active must be checked whether
538 -- this potentially blocking operation is called from a
541 if System.Tasking.Detect_Blocking
542 and then Self_ID.Common.Protected_Action_Nesting > 0
544 Ada.Exceptions.Raise_Exception
545 (Program_Error'Identity, "potentially blocking operation");
549 (Debug.Trace (Self_ID, "Create_Task", 'C'));
551 if Priority = Unspecified_Priority then
552 Base_Priority := Self_ID.Common.Base_Priority;
554 Base_Priority := System.Any_Priority (Priority);
557 -- Find parent P of new Task, via master level number
562 while P.Master_of_Task >= Master loop
563 P := P.Common.Parent;
568 Initialization.Defer_Abort_Nestable (Self_ID);
571 T := New_ATCB (Num_Entries);
574 Initialization.Undefer_Abort_Nestable (Self_ID);
575 Raise_Exception (Storage_Error'Identity, "Cannot allocate task");
578 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks.
579 -- Up to this point, it is possible that we may be part of
580 -- a family of tasks that is being aborted.
583 Write_Lock (Self_ID);
585 -- Now, we must check that we have not been aborted.
586 -- If so, we should give up on creating this task,
587 -- and simply return.
589 if not Self_ID.Callable then
590 pragma Assert (Self_ID.Pending_ATC_Level = 0);
591 pragma Assert (Self_ID.Pending_Action);
593 (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
597 Initialization.Undefer_Abort_Nestable (Self_ID);
599 -- ??? Should never get here
601 pragma Assert (False);
602 raise Standard'Abort_Signal;
605 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
606 Base_Priority, Task_Info, Size, T, Success);
612 Initialization.Undefer_Abort_Nestable (Self_ID);
614 (Storage_Error'Identity, "Failed to initialize task");
617 T.Master_of_Task := Master;
618 T.Master_Within := T.Master_of_Task + 1;
620 for L in T.Entry_Calls'Range loop
621 T.Entry_Calls (L).Self := T;
622 T.Entry_Calls (L).Level := L;
625 if Task_Image'Length = 0 then
626 T.Common.Task_Image_Len := 0;
629 T.Common.Task_Image (1) := Task_Image (Task_Image'First);
631 -- Remove unwanted blank space generated by 'Image
633 for J in Task_Image'First + 1 .. Task_Image'Last loop
634 if Task_Image (J) /= ' '
635 or else Task_Image (J - 1) /= '('
638 T.Common.Task_Image (Len) := Task_Image (J);
639 exit when Len = T.Common.Task_Image'Last;
643 T.Common.Task_Image_Len := Len;
649 -- Create TSD as early as possible in the creation of a task, since it
650 -- may be used by the operation of Ada code within the task.
652 SSL.Create_TSD (T.Common.Compiler_Data);
653 T.Common.Activation_Link := Chain.T_ID;
655 Initialization.Initialize_Attributes_Link.all (T);
657 Initialization.Undefer_Abort_Nestable (Self_ID);
659 if Runtime_Traces then
660 Send_Trace_Info (T_Create, T);
668 function Current_Master return Master_Level is
670 return STPO.Self.Master_Within;
677 procedure Enter_Master is
678 Self_ID : constant Task_Id := STPO.Self;
680 Self_ID.Master_Within := Self_ID.Master_Within + 1;
683 -------------------------------
684 -- Expunge_Unactivated_Tasks --
685 -------------------------------
687 -- See procedure Close_Entries for the general case
689 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
690 Self_ID : constant Task_Id := STPO.Self;
692 Call : Entry_Call_Link;
697 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
699 Initialization.Defer_Abort_Nestable (Self_ID);
702 -- Experimentation has shown that abort is sometimes (but not
703 -- always) already deferred when this is called.
705 -- That may indicate an error. Find out what is going on
709 pragma Assert (C.Common.State = Unactivated);
711 Temp := C.Common.Activation_Link;
713 if C.Common.State = Unactivated then
717 for J in 1 .. C.Entry_Num loop
718 Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
719 pragma Assert (Call = null);
724 Initialization.Remove_From_All_Tasks_List (C);
727 Vulnerable_Free_Task (C);
733 Initialization.Undefer_Abort_Nestable (Self_ID);
734 end Expunge_Unactivated_Tasks;
736 ---------------------------
737 -- Finalize_Global_Tasks --
738 ---------------------------
741 -- We have a potential problem here if finalization of global
742 -- objects does anything with signals or the timer server, since
743 -- by that time those servers have terminated.
745 -- It is hard to see how that would occur
747 -- However, a better solution might be to do all this finalization
748 -- using the global finalization chain.
750 procedure Finalize_Global_Tasks is
751 Self_ID : constant Task_Id := STPO.Self;
754 pragma Unreferenced (Ignore);
757 if Self_ID.Deferral_Level = 0 then
759 -- In principle, we should be able to predict whether
760 -- abort is already deferred here (and it should not be deferred
761 -- yet but in practice it seems Finalize_Global_Tasks is being
762 -- called sometimes, from RTS code for exceptions, with abort already
765 Initialization.Defer_Abort_Nestable (Self_ID);
767 -- Never undefer again!!!
770 -- This code is only executed by the environment task
772 pragma Assert (Self_ID = Environment_Task);
774 -- Set Environment_Task'Callable to false to notify library-level tasks
775 -- that it is waiting for them.
777 Self_ID.Callable := False;
779 -- Exit level 2 master, for normal tasks in library-level packages
783 -- Force termination of "independent" library-level server tasks
787 Abort_Dependents (Self_ID);
789 if not Single_Lock then
793 -- We need to explicitely wait for the task to be terminated here
794 -- because on true concurrent system, we may end this procedure
795 -- before the tasks are really terminated.
797 Write_Lock (Self_ID);
800 exit when Utilities.Independent_Task_Count = 0;
802 -- We used to yield here, but this did not take into account
803 -- low priority tasks that would cause dead lock in some cases
804 -- (true FIFO scheduling).
807 (Self_ID, 0.01, System.OS_Primitives.Relative,
808 Self_ID.Common.State, Ignore, Ignore);
811 -- ??? On multi-processor environments, it seems that the above loop
812 -- isn't sufficient, so we need to add an additional delay.
815 (Self_ID, 0.01, System.OS_Primitives.Relative,
816 Self_ID.Common.State, Ignore, Ignore);
824 -- Complete the environment task
826 Vulnerable_Complete_Task (Self_ID);
828 -- Handle normal task termination by the environment task, but only
829 -- for the normal task termination. In the case of Abnormal and
830 -- Unhandled_Exception they must have been handled before, and the
831 -- task termination soft link must have been changed so the task
832 -- termination routine is not executed twice.
834 SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
836 -- Finalize the global list for controlled objects if needed
838 SSL.Finalize_Global_List.all;
840 -- Reset the soft links to non-tasking
842 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
843 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
844 SSL.Lock_Task := SSL.Task_Lock_NT'Access;
845 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access;
846 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
847 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
848 SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access;
849 SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access;
850 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
851 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
853 -- Don't bother trying to finalize Initialization.Global_Task_Lock
854 -- and System.Task_Primitives.RTS_Lock.
856 end Finalize_Global_Tasks;
862 procedure Free_Task (T : Task_Id) is
863 Self_Id : constant Task_Id := Self;
866 if T.Common.State = Terminated then
868 -- It is not safe to call Abort_Defer or Write_Lock at this stage
870 Initialization.Task_Lock (Self_Id);
873 Initialization.Remove_From_All_Tasks_List (T);
876 Initialization.Task_Unlock (Self_Id);
878 System.Task_Primitives.Operations.Finalize_TCB (T);
880 -- If the task is not terminated, then we simply ignore the call. This
881 -- happens when a user program attempts an unchecked deallocation on
882 -- a non-terminated task.
889 ---------------------------
890 -- Move_Activation_Chain --
891 ---------------------------
893 procedure Move_Activation_Chain
894 (From, To : Activation_Chain_Access;
895 New_Master : Master_ID)
897 Self_ID : constant Task_Id := STPO.Self;
902 (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
904 -- Nothing to do if From is empty, and we can check that without
913 Initialization.Defer_Abort (Self_ID);
915 -- Loop through the From chain, changing their Master_of_Task
916 -- fields, and to find the end of the chain.
919 C.Master_of_Task := New_Master;
920 exit when C.Common.Activation_Link = null;
921 C := C.Common.Activation_Link;
924 -- Hook From in at the start of To
926 C.Common.Activation_Link := To.all.T_ID;
927 To.all.T_ID := From.all.T_ID;
931 From.all.T_ID := null;
933 Initialization.Undefer_Abort (Self_ID);
934 end Move_Activation_Chain;
940 -- The task wrapper is a procedure that is called first for each task
941 -- task body, and which in turn calls the compiler-generated task body
942 -- procedure. The wrapper's main job is to do initialization for the task.
943 -- It also has some locally declared objects that server as per-task local
944 -- data. Task finalization is done by Complete_Task, which is called from
945 -- an at-end handler that the compiler generates.
947 procedure Task_Wrapper (Self_ID : Task_Id) is
948 use type SSE.Storage_Offset;
949 use System.Standard_Library;
950 use System.Stack_Usage;
952 Bottom_Of_Stack : aliased Integer;
954 Secondary_Stack_Size :
955 constant SSE.Storage_Offset :=
956 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
957 SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100;
959 Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
961 pragma Warnings (Off);
962 -- Why are warnings being turned off here???
964 Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
966 Small_Overflow_Guard : constant := 12 * 1024;
967 -- Note: this used to be 4K, but was changed to 12K, since smaller
968 -- values resulted in segmentation faults from dynamic stack analysis.
970 Big_Overflow_Guard : constant := 16 * 1024;
971 Small_Stack_Limit : constant := 64 * 1024;
972 -- ??? These three values are experimental, and seems to work on most
973 -- platforms. They still need to be analyzed further. They also need
974 -- documentation, what are they???
977 Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size);
979 Overflow_Guard : Natural;
980 -- Size of the overflow guard, used by dynamic stack usage analysis
982 pragma Warnings (On);
983 -- Address of secondary stack. In the fixed secondary stack case, this
984 -- value is not modified, causing a warning, hence the bracketing with
985 -- Warnings (Off/On). But why is so much *more* bracketed ???
987 SEH_Table : aliased SSE.Storage_Array (1 .. 8);
988 -- Structured Exception Registration table (2 words)
990 procedure Install_SEH_Handler (Addr : System.Address);
991 pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
992 -- Install the SEH (Structured Exception Handling) handler
994 Cause : Cause_Of_Termination := Normal;
995 -- Indicates the reason why this task terminates. Normal corresponds to
996 -- a task terminating due to completing the last statement of its body,
997 -- or as a result of waiting on a terminate alternative. If the task
998 -- terminates because it is being aborted then Cause will be set to
999 -- Abnormal. If the task terminates because of an exception raised by
1000 -- the execution of its task body, then Cause is set to
1001 -- Unhandled_Exception.
1003 EO : Exception_Occurrence;
1004 -- If the task terminates because of an exception raised by the
1005 -- execution of its task body, then EO will contain the associated
1006 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
1008 TH : Termination_Handler := null;
1009 -- Pointer to the protected procedure to be executed upon task
1012 procedure Search_Fall_Back_Handler (ID : Task_Id);
1013 -- Procedure that searches recursively a fall-back handler through the
1014 -- master relationship. If the handler is found, its pointer is stored
1017 ------------------------------
1018 -- Search_Fall_Back_Handler --
1019 ------------------------------
1021 procedure Search_Fall_Back_Handler (ID : Task_Id) is
1023 -- If there is a fall back handler, store its pointer for later
1026 if ID.Common.Fall_Back_Handler /= null then
1027 TH := ID.Common.Fall_Back_Handler;
1029 -- Otherwise look for a fall back handler in the parent
1031 elsif ID.Common.Parent /= null then
1032 Search_Fall_Back_Handler (ID.Common.Parent);
1034 -- Otherwise, do nothing
1039 end Search_Fall_Back_Handler;
1042 pragma Assert (Self_ID.Deferral_Level = 1);
1044 -- Assume a size of the stack taken at this stage
1046 if Size < Small_Stack_Limit then
1047 Overflow_Guard := Small_Overflow_Guard;
1049 Overflow_Guard := Big_Overflow_Guard;
1052 Size := Size - Overflow_Guard;
1054 if not Parameters.Sec_Stack_Dynamic then
1055 Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
1056 Secondary_Stack'Address;
1057 SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
1058 Size := Size - Natural (Secondary_Stack_Size);
1061 if System.Stack_Usage.Is_Enabled then
1063 Initialize_Analyzer (Self_ID.Common.Analyzer,
1064 Self_ID.Common.Task_Image
1065 (1 .. Self_ID.Common.Task_Image_Len),
1068 SSE.To_Integer (Bottom_Of_Stack'Address));
1070 Fill_Stack (Self_ID.Common.Analyzer);
1073 -- Set the guard page at the bottom of the stack. The call to unprotect
1074 -- the page is done in Terminate_Task
1076 Stack_Guard (Self_ID, True);
1078 -- Initialize low-level TCB components, that cannot be initialized
1079 -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and
1080 -- also Self_ID.LL.Thread
1082 Enter_Task (Self_ID);
1084 -- We setup the SEH (Structured Exception Handling) handler if supported
1087 Install_SEH_Handler (SEH_Table'Address);
1089 -- Initialize exception occurrence
1091 Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
1093 -- We lock RTS_Lock to wait for activator to finish activating the rest
1094 -- of the chain, so that everyone in the chain comes out in priority
1097 -- This also protects the value of
1098 -- Self_ID.Common.Activator.Common.Wait_Count.
1103 if not System.Restrictions.Abort_Allowed then
1105 -- If Abort is not allowed, reset the deferral level since it will
1106 -- not get changed by the generated code. Keeping a default value
1107 -- of one would prevent some operations (e.g. select or delay) to
1108 -- proceed successfully.
1110 Self_ID.Deferral_Level := 0;
1114 -- We are separating the following portion of the code in order to
1115 -- place the exception handlers in a different block. In this way,
1116 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
1117 -- set Self in Enter_Task
1119 -- Call the task body procedure
1121 -- The task body is called with abort still deferred. That
1122 -- eliminates a dangerous window, for which we had to patch-up in
1125 -- During the expansion of the task body, we insert an RTS-call
1126 -- to Abort_Undefer, at the first point where abort should be
1129 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
1130 Initialization.Defer_Abort_Nestable (Self_ID);
1133 -- We can't call Terminate_Task in the exception handlers below,
1134 -- since there may be (e.g. in the case of GCC exception handling)
1135 -- clean ups associated with the exception handler that need to
1136 -- access task specific data.
1138 -- Defer abort so that this task can't be aborted while exiting
1140 when Standard'Abort_Signal =>
1141 Initialization.Defer_Abort_Nestable (Self_ID);
1143 -- Update the cause that motivated the task termination so that
1144 -- the appropriate information is passed to the task termination
1145 -- procedure. Task termination as a result of waiting on a
1146 -- terminate alternative is a normal termination, although it is
1147 -- implemented using the abort mechanisms.
1149 if Self_ID.Terminate_Alternative then
1155 -- ??? Using an E : others here causes CD2C11A to fail on Tru64.
1157 Initialization.Defer_Abort_Nestable (Self_ID);
1159 -- Perform the task specific exception tracing duty. We handle
1160 -- these outputs here and not in the common notification routine
1161 -- because we need access to tasking related data and we don't
1162 -- want to drag dependencies against tasking related units in the
1163 -- the common notification units. Additionally, no trace is ever
1164 -- triggered from the common routine for the Unhandled_Raise case
1165 -- in tasks, since an exception never appears unhandled in this
1166 -- context because of this handler.
1168 if Exception_Trace = Unhandled_Raise then
1169 Trace_Unhandled_Exception_In_Task (Self_ID);
1172 -- Update the cause that motivated the task termination so that
1173 -- the appropriate information is passed to the task termination
1174 -- procedure, as well as the associated Exception_Occurrence.
1176 Cause := Unhandled_Exception;
1177 Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
1180 -- Look for a task termination handler. This code is for all tasks but
1181 -- the environment task. The task termination code for the environment
1182 -- task is executed by SSL.Task_Termination_Handler.
1188 Write_Lock (Self_ID);
1190 if Self_ID.Common.Specific_Handler /= null then
1191 TH := Self_ID.Common.Specific_Handler;
1193 -- Look for a fall-back handler following the master relationship
1196 Search_Fall_Back_Handler (Self_ID);
1205 -- Execute the task termination handler if we found it
1208 TH.all (Cause, Self_ID, EO);
1211 if System.Stack_Usage.Is_Enabled then
1212 Compute_Result (Self_ID.Common.Analyzer);
1213 Report_Result (Self_ID.Common.Analyzer);
1216 Terminate_Task (Self_ID);
1219 --------------------
1220 -- Terminate_Task --
1221 --------------------
1223 -- Before we allow the thread to exit, we must clean up. This is a
1224 -- a delicate job. We must wake up the task's master, who may immediately
1225 -- try to deallocate the ATCB out from under the current task WHILE IT IS
1228 -- To avoid this, the parent task must be blocked up to the latest
1229 -- statement executed. The trouble is that we have another step that we
1230 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1231 -- We have to postpone that until the end because compiler-generated code
1232 -- is likely to try to access that data at just about any point.
1234 -- We can't call Destroy_TSD while we are holding any other locks, because
1235 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1236 -- that to be the outermost lock. Our first "solution" was to just lock
1237 -- Global_Task_Lock in addition to the other locks, and force the parent to
1238 -- also lock this lock between its wakeup and its freeing of the ATCB. See
1239 -- Complete_Task for the parent-side of the code that has the matching
1240 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1241 -- since the operation Task_Unlock continued to access the ATCB after
1242 -- unlocking, after which the parent was observed to race ahead, deallocate
1243 -- the ATCB, and then reallocate it to another task. The call to
1244 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
1245 -- the data of the new task that reused the ATCB! To solve this problem, we
1246 -- introduced the new operation Final_Task_Unlock.
1248 procedure Terminate_Task (Self_ID : Task_Id) is
1249 Environment_Task : constant Task_Id := STPO.Environment_Task;
1250 Master_of_Task : Integer;
1253 Debug.Task_Termination_Hook;
1255 if Runtime_Traces then
1256 Send_Trace_Info (T_Terminate);
1259 -- Since GCC cannot allocate stack chunks efficiently without reordering
1260 -- some of the allocations, we have to handle this unexpected situation
1261 -- here. We should normally never have to call Vulnerable_Complete_Task
1264 if Self_ID.Common.Activator /= null then
1265 Vulnerable_Complete_Task (Self_ID);
1268 Initialization.Task_Lock (Self_ID);
1274 Master_of_Task := Self_ID.Master_of_Task;
1276 -- Check if the current task is an independent task If so, decrement
1277 -- the Independent_Task_Count value.
1279 if Master_of_Task = 2 then
1281 Utilities.Independent_Task_Count :=
1282 Utilities.Independent_Task_Count - 1;
1284 Write_Lock (Environment_Task);
1285 Utilities.Independent_Task_Count :=
1286 Utilities.Independent_Task_Count - 1;
1287 Unlock (Environment_Task);
1291 -- Unprotect the guard page if needed
1293 Stack_Guard (Self_ID, False);
1295 Utilities.Make_Passive (Self_ID, Task_Completed => True);
1301 pragma Assert (Check_Exit (Self_ID));
1303 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
1304 Initialization.Final_Task_Unlock (Self_ID);
1306 -- WARNING: past this point, this thread must assume that the ATCB
1307 -- has been deallocated. It should not be accessed again.
1309 if Master_of_Task > 0 then
1318 function Terminated (T : Task_Id) return Boolean is
1319 Self_ID : constant Task_Id := STPO.Self;
1323 Initialization.Defer_Abort_Nestable (Self_ID);
1330 Result := T.Common.State = Terminated;
1337 Initialization.Undefer_Abort_Nestable (Self_ID);
1341 ----------------------------------------
1342 -- Trace_Unhandled_Exception_In_Task --
1343 ----------------------------------------
1345 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
1346 procedure To_Stderr (S : String);
1347 pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
1349 use System.Soft_Links;
1350 use System.Standard_Library;
1352 function To_Address is new
1353 Ada.Unchecked_Conversion (Task_Id, System.Address);
1355 function Tailored_Exception_Information
1356 (E : Exception_Occurrence) return String;
1358 (Ada, Tailored_Exception_Information,
1359 "__gnat_tailored_exception_information");
1361 Excep : constant Exception_Occurrence_Access :=
1362 SSL.Get_Current_Excep.all;
1365 -- This procedure is called by the task outermost handler in
1366 -- Task_Wrapper below, so only once the task stack has been fully
1367 -- unwound. The common notification routine has been called at the
1368 -- raise point already.
1370 To_Stderr ("task ");
1372 if Self_Id.Common.Task_Image_Len /= 0 then
1374 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
1378 To_Stderr (System.Address_Image (To_Address (Self_Id)));
1379 To_Stderr (" terminated by unhandled exception");
1380 To_Stderr ((1 => ASCII.LF));
1381 To_Stderr (Tailored_Exception_Information (Excep.all));
1382 end Trace_Unhandled_Exception_In_Task;
1384 ------------------------------------
1385 -- Vulnerable_Complete_Activation --
1386 ------------------------------------
1388 -- As in several other places, the locks of the activator and activated
1389 -- task are both locked here. This follows our deadlock prevention lock
1390 -- ordering policy, since the activated task must be created after the
1393 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
1394 Activator : constant Task_Id := Self_ID.Common.Activator;
1397 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
1399 Write_Lock (Activator);
1400 Write_Lock (Self_ID);
1402 pragma Assert (Self_ID.Common.Activator /= null);
1404 -- Remove dangling reference to Activator, since a task may
1405 -- outlive its activator.
1407 Self_ID.Common.Activator := null;
1409 -- Wake up the activator, if it is waiting for a chain of tasks to
1410 -- activate, and we are the last in the chain to complete activation.
1412 if Activator.Common.State = Activator_Sleep then
1413 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
1415 if Activator.Common.Wait_Count = 0 then
1416 Wakeup (Activator, Activator_Sleep);
1420 -- The activator raises a Tasking_Error if any task it is activating
1421 -- is completed before the activation is done. However, if the reason
1422 -- for the task completion is an abort, we do not raise an exception.
1425 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
1426 Activator.Common.Activation_Failed := True;
1432 -- After the activation, active priority should be the same
1433 -- as base priority. We must unlock the Activator first,
1434 -- though, since it should not wait if we have lower priority.
1436 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
1437 Write_Lock (Self_ID);
1438 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1441 end Vulnerable_Complete_Activation;
1443 --------------------------------
1444 -- Vulnerable_Complete_Master --
1445 --------------------------------
1447 procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
1450 CM : constant Master_Level := Self_ID.Master_Within;
1451 T : aliased Task_Id;
1453 To_Be_Freed : Task_Id;
1454 -- This is a list of ATCBs to be freed, after we have released
1455 -- all RTS locks. This is necessary because of the locking order
1456 -- rules, since the storage manager uses Global_Task_Lock.
1458 pragma Warnings (Off);
1459 function Check_Unactivated_Tasks return Boolean;
1460 pragma Warnings (On);
1461 -- Temporary error-checking code below. This is part of the checks
1462 -- added in the new run time. Call it only inside a pragma Assert.
1464 -----------------------------
1465 -- Check_Unactivated_Tasks --
1466 -----------------------------
1468 function Check_Unactivated_Tasks return Boolean is
1470 if not Single_Lock then
1474 Write_Lock (Self_ID);
1476 C := All_Tasks_List;
1477 while C /= null loop
1478 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
1482 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1485 if C.Common.State = Unactivated then
1492 C := C.Common.All_Tasks_Link;
1497 if not Single_Lock then
1502 end Check_Unactivated_Tasks;
1504 -- Start of processing for Vulnerable_Complete_Master
1508 (Debug.Trace (Self_ID, "V_Complete_Master", 'C'));
1510 pragma Assert (Self_ID.Common.Wait_Count = 0);
1512 (Self_ID.Deferral_Level > 0
1513 or else not System.Restrictions.Abort_Allowed);
1515 -- Count how many active dependent tasks this master currently
1516 -- has, and record this in Wait_Count.
1518 -- This count should start at zero, since it is initialized to
1519 -- zero for new tasks, and the task should not exit the
1520 -- sleep-loops that use this count until the count reaches zero.
1522 -- While we're counting, if we run across any unactivated tasks that
1523 -- belong to this master, we summarily terminate them as required by
1527 Write_Lock (Self_ID);
1529 C := All_Tasks_List;
1530 while C /= null loop
1532 -- Terminate unactivated (never-to-be activated) tasks
1534 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
1535 pragma Assert (C.Common.State = Unactivated);
1536 -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
1537 -- = CM. The only case where C is pending activation by this
1538 -- task, but the master of C is not CM is in Ada 2005, when C is
1539 -- part of a return object of a build-in-place function.
1542 C.Common.Activator := null;
1543 C.Common.State := Terminated;
1544 C.Callable := False;
1545 Utilities.Cancel_Queued_Entry_Calls (C);
1549 -- Count it if dependent on this master
1551 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1554 if C.Awake_Count /= 0 then
1555 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1561 C := C.Common.All_Tasks_Link;
1564 Self_ID.Common.State := Master_Completion_Sleep;
1567 if not Single_Lock then
1571 -- Wait until dependent tasks are all terminated or ready to terminate.
1572 -- While waiting, the task may be awakened if the task's priority needs
1573 -- changing, or this master is aborted. In the latter case, we want
1574 -- to abort the dependents, and resume waiting until Wait_Count goes
1577 Write_Lock (Self_ID);
1580 exit when Self_ID.Common.Wait_Count = 0;
1582 -- Here is a difference as compared to Complete_Master
1584 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1585 and then not Self_ID.Dependents_Aborted
1588 Abort_Dependents (Self_ID);
1592 Abort_Dependents (Self_ID);
1594 Write_Lock (Self_ID);
1597 Sleep (Self_ID, Master_Completion_Sleep);
1601 Self_ID.Common.State := Runnable;
1604 -- Dependents are all terminated or on terminate alternatives.
1605 -- Now, force those on terminate alternatives to terminate, by
1608 pragma Assert (Check_Unactivated_Tasks);
1610 if Self_ID.Alive_Count > 1 then
1612 -- Consider finding a way to skip the following extra steps if there
1613 -- are no dependents with terminate alternatives. This could be done
1614 -- by adding another count to the ATCB, similar to Awake_Count, but
1615 -- keeping track of tasks that are on terminate alternatives.
1617 pragma Assert (Self_ID.Common.Wait_Count = 0);
1619 -- Force any remaining dependents to terminate by aborting them
1621 if not Single_Lock then
1625 Abort_Dependents (Self_ID);
1627 -- Above, when we "abort" the dependents we are simply using this
1628 -- operation for convenience. We are not required to support the full
1629 -- abort-statement semantics; in particular, we are not required to
1630 -- immediately cancel any queued or in-service entry calls. That is
1631 -- good, because if we tried to cancel a call we would need to lock
1632 -- the caller, in order to wake the caller up. Our anti-deadlock
1633 -- rules prevent us from doing that without releasing the locks on C
1634 -- and Self_ID. Releasing and retaking those locks would be wasteful
1635 -- at best, and should not be considered further without more
1636 -- detailed analysis of potential concurrent accesses to the
1637 -- ATCBs of C and Self_ID.
1639 -- Count how many "alive" dependent tasks this master currently
1640 -- has, and record this in Wait_Count. This count should start at
1641 -- zero, since it is initialized to zero for new tasks, and the
1642 -- task should not exit the sleep-loops that use this count until
1643 -- the count reaches zero.
1645 pragma Assert (Self_ID.Common.Wait_Count = 0);
1647 Write_Lock (Self_ID);
1649 C := All_Tasks_List;
1650 while C /= null loop
1651 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1654 pragma Assert (C.Awake_Count = 0);
1656 if C.Alive_Count > 0 then
1657 pragma Assert (C.Terminate_Alternative);
1658 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1664 C := C.Common.All_Tasks_Link;
1667 Self_ID.Common.State := Master_Phase_2_Sleep;
1670 if not Single_Lock then
1674 -- Wait for all counted tasks to finish terminating themselves
1676 Write_Lock (Self_ID);
1679 exit when Self_ID.Common.Wait_Count = 0;
1680 Sleep (Self_ID, Master_Phase_2_Sleep);
1683 Self_ID.Common.State := Runnable;
1687 -- We don't wake up for abort here. We are already terminating just as
1688 -- fast as we can, so there is no point.
1690 -- Remove terminated tasks from the list of Self_ID's dependents, but
1691 -- don't free their ATCBs yet, because of lock order restrictions,
1692 -- which don't allow us to call "free" or "malloc" while holding any
1693 -- other locks. Instead, we put those ATCBs to be freed onto a
1694 -- temporary list, called To_Be_Freed.
1696 if not Single_Lock then
1700 C := All_Tasks_List;
1702 while C /= null loop
1703 if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then
1705 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
1707 All_Tasks_List := C.Common.All_Tasks_Link;
1710 T := C.Common.All_Tasks_Link;
1711 C.Common.All_Tasks_Link := To_Be_Freed;
1717 C := C.Common.All_Tasks_Link;
1723 -- Free all the ATCBs on the list To_Be_Freed
1725 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1726 -- any interrupt entries are detached from them they should no longer
1729 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1730 -- avoid a race between a terminating task and its parent. The parent
1731 -- might try to deallocate the ACTB out from underneath the exiting
1732 -- task. Note that Free will also lock Global_Task_Lock, but that is
1733 -- OK, since this is the *one* lock for which we have a mechanism to
1734 -- support nested locking. See Task_Wrapper and its finalizer for more
1738 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1739 -- references to terminated library-level tasks, which could
1740 -- otherwise occur during finalization of library-level objects.
1741 -- A better solution might be to hook task objects into the
1742 -- finalization chain and deallocate the ATCB when the task
1743 -- object is deallocated. However, this change is not likely
1744 -- to gain anything significant, since all this storage should
1745 -- be recovered en-masse when the process exits.
1747 while To_Be_Freed /= null loop
1749 To_Be_Freed := T.Common.All_Tasks_Link;
1751 -- ??? On SGI there is currently no Interrupt_Manager, that's
1752 -- why we need to check if the Interrupt_Manager_ID is null
1754 if T.Interrupt_Entry and Interrupt_Manager_ID /= null then
1756 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
1757 -- Corresponds to the entry index of System.Interrupts.
1758 -- Interrupt_Manager.Detach_Interrupt_Entries.
1759 -- Be sure to update this value when changing
1760 -- Interrupt_Manager specs.
1762 type Param_Type is access all Task_Id;
1764 Param : aliased Param_Type := T'Access;
1767 System.Tasking.Rendezvous.Call_Simple
1768 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
1773 if (T.Common.Parent /= null
1774 and then T.Common.Parent.Common.Parent /= null)
1775 or else T.Master_of_Task > 3
1777 Initialization.Task_Lock (Self_ID);
1779 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1780 -- has not been called yet (case of an unactivated task).
1782 if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then
1783 SSL.Destroy_TSD (T.Common.Compiler_Data);
1786 Vulnerable_Free_Task (T);
1787 Initialization.Task_Unlock (Self_ID);
1791 -- It might seem nice to let the terminated task deallocate its own
1792 -- ATCB. That would not cover the case of unactivated tasks. It also
1793 -- would force us to keep the underlying thread around past termination,
1794 -- since references to the ATCB are possible past termination.
1795 -- Currently, we get rid of the thread as soon as the task terminates,
1796 -- and let the parent recover the ATCB later.
1798 -- Some day, if we want to recover the ATCB earlier, at task
1799 -- termination, we could consider using "fat task IDs", that include the
1800 -- serial number with the ATCB pointer, to catch references to tasks
1801 -- that no longer have ATCBs. It is not clear how much this would gain,
1802 -- since the user-level task object would still be occupying storage.
1804 -- Make next master level up active.
1805 -- We don't need to lock the ATCB, since the value is only updated by
1806 -- each task for itself.
1808 Self_ID.Master_Within := CM - 1;
1809 end Vulnerable_Complete_Master;
1811 ------------------------------
1812 -- Vulnerable_Complete_Task --
1813 ------------------------------
1815 -- Complete the calling task
1817 -- This procedure must be called with abort deferred. It should only be
1818 -- called by Complete_Task and Finalize_Global_Tasks (for the environment
1821 -- The effect is similar to that of Complete_Master. Differences include
1822 -- the closing of entries here, and computation of the number of active
1823 -- dependent tasks in Complete_Master.
1825 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1826 -- because that does its own locking, and because we do not need the lock
1827 -- to test Self_ID.Common.Activator. That value should only be read and
1828 -- modified by Self.
1830 procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
1833 (Self_ID.Deferral_Level > 0
1834 or else not System.Restrictions.Abort_Allowed);
1835 pragma Assert (Self_ID = Self);
1836 pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1
1838 Self_ID.Master_Within = Self_ID.Master_of_Task + 2);
1839 pragma Assert (Self_ID.Common.Wait_Count = 0);
1840 pragma Assert (Self_ID.Open_Accepts = null);
1841 pragma Assert (Self_ID.ATC_Nesting_Level = 1);
1843 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
1849 Write_Lock (Self_ID);
1850 Self_ID.Callable := False;
1852 -- In theory, Self should have no pending entry calls left on its
1853 -- call-stack. Each async. select statement should clean its own call,
1854 -- and blocking entry calls should defer abort until the calls are
1855 -- cancelled, then clean up.
1857 Utilities.Cancel_Queued_Entry_Calls (Self_ID);
1860 if Self_ID.Common.Activator /= null then
1861 Vulnerable_Complete_Activation (Self_ID);
1868 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
1869 -- we may have dependent tasks for which we need to wait.
1870 -- Otherwise, we can just exit.
1872 if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
1873 Vulnerable_Complete_Master (Self_ID);
1875 end Vulnerable_Complete_Task;
1877 --------------------------
1878 -- Vulnerable_Free_Task --
1879 --------------------------
1881 -- Recover all runtime system storage associated with the task T.
1882 -- This should only be called after T has terminated and will no
1883 -- longer be referenced.
1885 -- For tasks created by an allocator that fails, due to an exception,
1886 -- it is called from Expunge_Unactivated_Tasks.
1888 -- For tasks created by elaboration of task object declarations it
1889 -- is called from the finalization code of the Task_Wrapper procedure.
1890 -- It is also called from Ada.Unchecked_Deallocation, for objects that
1891 -- are or contain tasks.
1893 procedure Vulnerable_Free_Task (T : Task_Id) is
1895 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
1902 Initialization.Finalize_Attributes_Link.all (T);
1909 System.Task_Primitives.Operations.Finalize_TCB (T);
1910 end Vulnerable_Free_Task;
1912 -- Package elaboration code
1915 -- Establish the Adafinal softlink
1917 -- This is not done inside the central RTS initialization routine
1918 -- to avoid with-ing this package from System.Tasking.Initialization.
1920 SSL.Adafinal := Finalize_Global_Tasks'Access;
1922 -- Establish soft links for subprograms that manipulate master_id's.
1923 -- This cannot be done when the RTS is initialized, because of various
1924 -- elaboration constraints.
1926 SSL.Current_Master := Stages.Current_Master'Access;
1927 SSL.Enter_Master := Stages.Enter_Master'Access;
1928 SSL.Complete_Master := Stages.Complete_Master'Access;
1929 end System.Tasking.Stages;