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-2008, 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 tasking
36 -- operations. It causes infinite loops and other problems.
39 with Ada.Unchecked_Deallocation;
41 with System.Tasking.Debug;
42 with System.Address_Image;
43 with System.Task_Primitives;
44 with System.Task_Primitives.Operations;
45 with System.Tasking.Utilities;
46 with System.Tasking.Queuing;
47 with System.Tasking.Rendezvous;
48 with System.OS_Primitives;
49 with System.Secondary_Stack;
50 with System.Storage_Elements;
51 with System.Restrictions;
52 with System.Standard_Library;
53 with System.Traces.Tasking;
54 with System.Stack_Usage;
56 with System.Soft_Links;
57 -- These are procedure pointers to non-tasking routines that use task
58 -- specific data. In the absence of tasking, these routines refer to global
59 -- data. In the presense of tasking, they must be replaced with pointers to
60 -- task-specific versions. Also used for Create_TSD, Destroy_TSD,
61 -- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler.
63 with System.Tasking.Initialization;
64 pragma Elaborate_All (System.Tasking.Initialization);
65 -- This insures that tasking is initialized if any tasks are created
67 package body System.Tasking.Stages is
69 package STPO renames System.Task_Primitives.Operations;
70 package SSL renames System.Soft_Links;
71 package SSE renames System.Storage_Elements;
72 package SST renames System.Secondary_Stack;
78 use Task_Primitives.Operations;
82 use System.Traces.Tasking;
84 -----------------------
85 -- Local Subprograms --
86 -----------------------
89 Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
91 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
92 -- This procedure outputs the task specific message for exception
95 procedure Task_Wrapper (Self_ID : Task_Id);
96 pragma Convention (C, Task_Wrapper);
97 -- This is the procedure that is called by the GNULL from the new context
98 -- when a task is created. It waits for activation and then calls the task
99 -- body procedure. When the task body procedure completes, it terminates
102 -- The Task_Wrapper's address will be provided to the underlying threads
103 -- library as the task entry point. Convention C is what makes most sense
104 -- for that purpose (Export C would make the function globally visible,
105 -- and affect the link name on which GDB depends). This will in addition
106 -- trigger an automatic stack alignment suitable for GCC's assumptions if
109 -- "Vulnerable_..." in the procedure names below means they must be called
110 -- with abort deferred.
112 procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
113 -- Complete the calling task. This procedure must be called with
114 -- abort deferred. It should only be called by Complete_Task and
115 -- Finalizate_Global_Tasks (for the environment task).
117 procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
118 -- Complete the current master of the calling task. This procedure
119 -- must be called with abort deferred. It should only be called by
120 -- Vulnerable_Complete_Task and Complete_Master.
122 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
123 -- Signal to Self_ID's activator that Self_ID has completed activation.
124 -- This procedure must be called with abort deferred.
126 procedure Abort_Dependents (Self_ID : Task_Id);
127 -- Abort all the direct dependents of Self at its current master nesting
128 -- level, plus all of their dependents, transitively. RTS_Lock should be
129 -- locked by the caller.
131 procedure Vulnerable_Free_Task (T : Task_Id);
132 -- Recover all runtime system storage associated with the task T. This
133 -- should only be called after T has terminated and will no longer be
136 -- For tasks created by an allocator that fails, due to an exception, it is
137 -- called from Expunge_Unactivated_Tasks.
139 -- Different code is used at master completion, in Terminate_Dependents,
140 -- due to a need for tighter synchronization with the master.
142 ----------------------
143 -- Abort_Dependents --
144 ----------------------
146 procedure Abort_Dependents (Self_ID : Task_Id) is
153 P := C.Common.Parent;
157 -- ??? C is supposed to take care of its own dependents, so
158 -- there should be no need to worry about them. Need to double
161 if C.Master_of_Task = Self_ID.Master_Within then
162 Utilities.Abort_One_Task (Self_ID, C);
163 C.Dependents_Aborted := True;
169 P := P.Common.Parent;
172 C := C.Common.All_Tasks_Link;
175 Self_ID.Dependents_Aborted := True;
176 end Abort_Dependents;
182 procedure Abort_Tasks (Tasks : Task_List) is
184 Utilities.Abort_Tasks (Tasks);
191 -- Note that locks of activator and activated task are both locked here.
192 -- This is necessary because C.Common.State and Self.Common.Wait_Count have
193 -- to be synchronized. This is safe from deadlock because the activator is
194 -- always created before the activated task. That satisfies our
195 -- in-order-of-creation ATCB locking policy.
197 -- At one point, we may also lock the parent, if the parent is different
198 -- from the activator. That is also consistent with the lock ordering
199 -- policy, since the activator cannot be created before the parent.
201 -- Since we are holding both the activator's lock, and Task_Wrapper locks
202 -- that before it does anything more than initialize the low-level ATCB
203 -- components, it should be safe to wait to update the counts until we see
204 -- that the thread creation is successful.
206 -- If the thread creation fails, we do need to close the entries of the
207 -- task. The first phase, of dequeuing calls, only requires locking the
208 -- acceptor's ATCB, but the waking up of the callers requires locking the
209 -- caller's ATCB. We cannot safely do this while we are holding other
210 -- locks. Therefore, the queue-clearing operation is done in a separate
211 -- pass over the activation chain.
213 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
214 Self_ID : constant Task_Id := STPO.Self;
217 Next_C, Last_C : Task_Id;
218 Activate_Prio : System.Any_Priority;
220 All_Elaborated : Boolean := True;
223 -- If pragma Detect_Blocking is active, then we must check whether this
224 -- potentially blocking operation is called from a protected action.
226 if System.Tasking.Detect_Blocking
227 and then Self_ID.Common.Protected_Action_Nesting > 0
229 raise Program_Error with "potentially blocking operation";
233 (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
235 Initialization.Defer_Abort_Nestable (Self_ID);
237 pragma Assert (Self_ID.Common.Wait_Count = 0);
239 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
240 -- we finish activating the chain.
244 -- Check that all task bodies have been elaborated
246 C := Chain_Access.T_ID;
249 if C.Common.Elaborated /= null
250 and then not C.Common.Elaborated.all
252 All_Elaborated := False;
255 -- Reverse the activation chain so that tasks are activated in the
256 -- same order they're declared.
258 Next_C := C.Common.Activation_Link;
259 C.Common.Activation_Link := Last_C;
264 Chain_Access.T_ID := Last_C;
266 if not All_Elaborated then
268 Initialization.Undefer_Abort_Nestable (Self_ID);
269 raise Program_Error with "Some tasks have not been elaborated";
272 -- Activate all the tasks in the chain. Creation of the thread of
273 -- control was deferred until activation. So create it now.
275 C := Chain_Access.T_ID;
277 if C.Common.State /= Terminated then
278 pragma Assert (C.Common.State = Unactivated);
280 P := C.Common.Parent;
284 if C.Common.Base_Priority < Get_Priority (Self_ID) then
285 Activate_Prio := Get_Priority (Self_ID);
287 Activate_Prio := C.Common.Base_Priority;
290 System.Task_Primitives.Operations.Create_Task
291 (C, Task_Wrapper'Address,
293 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
294 Activate_Prio, Success);
296 -- There would be a race between the created task and the creator
297 -- to do the following initialization, if we did not have a
298 -- Lock/Unlock_RTS pair in the task wrapper to prevent it from
302 C.Common.State := Runnable;
305 P.Awake_Count := P.Awake_Count + 1;
306 P.Alive_Count := P.Alive_Count + 1;
308 if P.Common.State = Master_Completion_Sleep and then
309 C.Master_of_Task = P.Master_Within
311 pragma Assert (Self_ID /= P);
312 P.Common.Wait_Count := P.Common.Wait_Count + 1;
319 -- No need to set Awake_Count, State, etc. here since the loop
320 -- below will do that for any Unactivated tasks.
324 Self_ID.Common.Activation_Failed := True;
328 C := C.Common.Activation_Link;
331 if not Single_Lock then
335 -- Close the entries of any tasks that failed thread creation, and count
336 -- those that have not finished activation.
338 Write_Lock (Self_ID);
339 Self_ID.Common.State := Activator_Sleep;
341 C := Chain_Access.T_ID;
345 if C.Common.State = Unactivated then
346 C.Common.Activator := null;
347 C.Common.State := Terminated;
349 Utilities.Cancel_Queued_Entry_Calls (C);
351 elsif C.Common.Activator /= null then
352 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
356 P := C.Common.Activation_Link;
357 C.Common.Activation_Link := null;
361 -- Wait for the activated tasks to complete activation. It is
362 -- unsafe to abort any of these tasks until the count goes to zero.
365 exit when Self_ID.Common.Wait_Count = 0;
366 Sleep (Self_ID, Activator_Sleep);
369 Self_ID.Common.State := Runnable;
376 -- Remove the tasks from the chain
378 Chain_Access.T_ID := null;
379 Initialization.Undefer_Abort_Nestable (Self_ID);
381 if Self_ID.Common.Activation_Failed then
382 Self_ID.Common.Activation_Failed := False;
383 raise Tasking_Error with "Failure during activation";
387 -------------------------
388 -- Complete_Activation --
389 -------------------------
391 procedure Complete_Activation is
392 Self_ID : constant Task_Id := STPO.Self;
395 Initialization.Defer_Abort_Nestable (Self_ID);
401 Vulnerable_Complete_Activation (Self_ID);
407 Initialization.Undefer_Abort_Nestable (Self_ID);
409 -- ??? Why do we need to allow for nested deferral here?
411 if Runtime_Traces then
412 Send_Trace_Info (T_Activate);
414 end Complete_Activation;
416 ---------------------
417 -- Complete_Master --
418 ---------------------
420 procedure Complete_Master is
421 Self_ID : constant Task_Id := STPO.Self;
424 (Self_ID.Deferral_Level > 0
425 or else not System.Restrictions.Abort_Allowed);
426 Vulnerable_Complete_Master (Self_ID);
433 -- See comments on Vulnerable_Complete_Task for details
435 procedure Complete_Task is
436 Self_ID : constant Task_Id := STPO.Self;
440 (Self_ID.Deferral_Level > 0
441 or else not System.Restrictions.Abort_Allowed);
443 Vulnerable_Complete_Task (Self_ID);
445 -- All of our dependents have terminated. Never undefer abort again!
453 -- Compiler interface only. Do not call from within the RTS. This must be
454 -- called to create a new task.
456 procedure Create_Task
458 Size : System.Parameters.Size_Type;
459 Task_Info : System.Task_Info.Task_Info_Type;
460 Relative_Deadline : Ada.Real_Time.Time_Span;
461 Num_Entries : Task_Entry_Index;
462 Master : Master_Level;
463 State : Task_Procedure_Access;
464 Discriminants : System.Address;
465 Elaborated : Access_Boolean;
466 Chain : in out Activation_Chain;
468 Created_Task : out Task_Id)
471 Self_ID : constant Task_Id := STPO.Self;
473 Base_Priority : System.Any_Priority;
476 pragma Unreferenced (Relative_Deadline);
477 -- EDF scheduling is not supported by any of the target platforms so
478 -- this parameter is not passed any further.
481 -- If Master is greater than the current master, it means that Master
482 -- has already awaited its dependent tasks. This raises Program_Error,
483 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
485 if Self_ID.Master_of_Task /= Foreign_Task_Level
486 and then Master > Self_ID.Master_Within
488 raise Program_Error with
489 "create task after awaiting termination";
492 -- If pragma Detect_Blocking is active must be checked whether this
493 -- potentially blocking operation is called from a protected action.
495 if System.Tasking.Detect_Blocking
496 and then Self_ID.Common.Protected_Action_Nesting > 0
498 raise Program_Error with "potentially blocking operation";
502 (Debug.Trace (Self_ID, "Create_Task", 'C'));
504 if Priority = Unspecified_Priority then
505 Base_Priority := Self_ID.Common.Base_Priority;
507 Base_Priority := System.Any_Priority (Priority);
510 -- Find parent P of new Task, via master level number
515 while P.Master_of_Task >= Master loop
516 P := P.Common.Parent;
521 Initialization.Defer_Abort_Nestable (Self_ID);
524 T := New_ATCB (Num_Entries);
527 Initialization.Undefer_Abort_Nestable (Self_ID);
528 raise Storage_Error with "Cannot allocate task";
531 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this
532 -- point, it is possible that we may be part of a family of tasks that
536 Write_Lock (Self_ID);
538 -- Now, we must check that we have not been aborted. If so, we should
539 -- give up on creating this task, and simply return.
541 if not Self_ID.Callable then
542 pragma Assert (Self_ID.Pending_ATC_Level = 0);
543 pragma Assert (Self_ID.Pending_Action);
545 (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
549 Initialization.Undefer_Abort_Nestable (Self_ID);
551 -- ??? Should never get here
553 pragma Assert (False);
554 raise Standard'Abort_Signal;
557 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
558 Base_Priority, Task_Info, Size, T, Success);
564 Initialization.Undefer_Abort_Nestable (Self_ID);
565 raise Storage_Error with "Failed to initialize task";
568 if Master = Foreign_Task_Level + 2 then
570 -- This should not happen, except when a foreign task creates non
571 -- library-level Ada tasks. In this case, we pretend the master is
572 -- a regular library level task, otherwise the run-time will get
573 -- confused when waiting for these tasks to terminate.
575 T.Master_of_Task := Library_Task_Level;
577 T.Master_of_Task := Master;
580 T.Master_Within := T.Master_of_Task + 1;
582 for L in T.Entry_Calls'Range loop
583 T.Entry_Calls (L).Self := T;
584 T.Entry_Calls (L).Level := L;
587 if Task_Image'Length = 0 then
588 T.Common.Task_Image_Len := 0;
591 T.Common.Task_Image (1) := Task_Image (Task_Image'First);
593 -- Remove unwanted blank space generated by 'Image
595 for J in Task_Image'First + 1 .. Task_Image'Last loop
596 if Task_Image (J) /= ' '
597 or else Task_Image (J - 1) /= '('
600 T.Common.Task_Image (Len) := Task_Image (J);
601 exit when Len = T.Common.Task_Image'Last;
605 T.Common.Task_Image_Len := Len;
611 -- Create TSD as early as possible in the creation of a task, since it
612 -- may be used by the operation of Ada code within the task.
614 SSL.Create_TSD (T.Common.Compiler_Data);
615 T.Common.Activation_Link := Chain.T_ID;
617 Initialization.Initialize_Attributes_Link.all (T);
619 Initialization.Undefer_Abort_Nestable (Self_ID);
621 if Runtime_Traces then
622 Send_Trace_Info (T_Create, T);
630 function Current_Master return Master_Level is
632 return STPO.Self.Master_Within;
639 procedure Enter_Master is
640 Self_ID : constant Task_Id := STPO.Self;
642 Self_ID.Master_Within := Self_ID.Master_Within + 1;
645 -------------------------------
646 -- Expunge_Unactivated_Tasks --
647 -------------------------------
649 -- See procedure Close_Entries for the general case
651 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
652 Self_ID : constant Task_Id := STPO.Self;
654 Call : Entry_Call_Link;
659 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
661 Initialization.Defer_Abort_Nestable (Self_ID);
664 -- Experimentation has shown that abort is sometimes (but not always)
665 -- already deferred when this is called.
667 -- That may indicate an error. Find out what is going on
671 pragma Assert (C.Common.State = Unactivated);
673 Temp := C.Common.Activation_Link;
675 if C.Common.State = Unactivated then
679 for J in 1 .. C.Entry_Num loop
680 Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
681 pragma Assert (Call = null);
686 Initialization.Remove_From_All_Tasks_List (C);
689 Vulnerable_Free_Task (C);
695 Initialization.Undefer_Abort_Nestable (Self_ID);
696 end Expunge_Unactivated_Tasks;
698 ---------------------------
699 -- Finalize_Global_Tasks --
700 ---------------------------
703 -- We have a potential problem here if finalization of global objects does
704 -- anything with signals or the timer server, since by that time those
705 -- servers have terminated.
707 -- It is hard to see how that would occur
709 -- However, a better solution might be to do all this finalization
710 -- using the global finalization chain.
712 procedure Finalize_Global_Tasks is
713 Self_ID : constant Task_Id := STPO.Self;
716 pragma Unreferenced (Ignore);
719 if Self_ID.Deferral_Level = 0 then
721 -- In principle, we should be able to predict whether abort is
722 -- already deferred here (and it should not be deferred yet but in
723 -- practice it seems Finalize_Global_Tasks is being called sometimes,
724 -- from RTS code for exceptions, with abort already deferred.
726 Initialization.Defer_Abort_Nestable (Self_ID);
728 -- Never undefer again!!!
731 -- This code is only executed by the environment task
733 pragma Assert (Self_ID = Environment_Task);
735 -- Set Environment_Task'Callable to false to notify library-level tasks
736 -- that it is waiting for them.
738 Self_ID.Callable := False;
740 -- Exit level 2 master, for normal tasks in library-level packages
744 -- Force termination of "independent" library-level server tasks
748 Abort_Dependents (Self_ID);
750 if not Single_Lock then
754 -- We need to explicitly wait for the task to be terminated here
755 -- because on true concurrent system, we may end this procedure before
756 -- the tasks are really terminated.
758 Write_Lock (Self_ID);
761 exit when Utilities.Independent_Task_Count = 0;
763 -- We used to yield here, but this did not take into account low
764 -- priority tasks that would cause dead lock in some cases (true
768 (Self_ID, 0.01, System.OS_Primitives.Relative,
769 Self_ID.Common.State, Ignore, Ignore);
772 -- ??? On multi-processor environments, it seems that the above loop
773 -- isn't sufficient, so we need to add an additional delay.
776 (Self_ID, 0.01, System.OS_Primitives.Relative,
777 Self_ID.Common.State, Ignore, Ignore);
785 -- Complete the environment task
787 Vulnerable_Complete_Task (Self_ID);
789 -- Handle normal task termination by the environment task, but only
790 -- for the normal task termination. In the case of Abnormal and
791 -- Unhandled_Exception they must have been handled before, and the
792 -- task termination soft link must have been changed so the task
793 -- termination routine is not executed twice.
795 SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
797 -- Finalize the global list for controlled objects if needed
799 SSL.Finalize_Global_List.all;
801 -- Reset the soft links to non-tasking
803 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
804 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
805 SSL.Lock_Task := SSL.Task_Lock_NT'Access;
806 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access;
807 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
808 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
809 SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access;
810 SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access;
811 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
812 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
814 -- Don't bother trying to finalize Initialization.Global_Task_Lock
815 -- and System.Task_Primitives.RTS_Lock.
817 end Finalize_Global_Tasks;
823 procedure Free_Task (T : Task_Id) is
824 Self_Id : constant Task_Id := Self;
827 if T.Common.State = Terminated then
829 -- It is not safe to call Abort_Defer or Write_Lock at this stage
831 Initialization.Task_Lock (Self_Id);
834 Initialization.Finalize_Attributes_Link.all (T);
835 Initialization.Remove_From_All_Tasks_List (T);
838 Initialization.Task_Unlock (Self_Id);
840 System.Task_Primitives.Operations.Finalize_TCB (T);
842 -- If the task is not terminated, then we simply ignore the call. This
843 -- happens when a user program attempts an unchecked deallocation on
844 -- a non-terminated task.
851 ---------------------------
852 -- Move_Activation_Chain --
853 ---------------------------
855 procedure Move_Activation_Chain
856 (From, To : Activation_Chain_Access;
857 New_Master : Master_ID)
859 Self_ID : constant Task_Id := STPO.Self;
864 (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
866 -- Nothing to do if From is empty, and we can check that without
875 Initialization.Defer_Abort (Self_ID);
877 -- Loop through the From chain, changing their Master_of_Task
878 -- fields, and to find the end of the chain.
881 C.Master_of_Task := New_Master;
882 exit when C.Common.Activation_Link = null;
883 C := C.Common.Activation_Link;
886 -- Hook From in at the start of To
888 C.Common.Activation_Link := To.all.T_ID;
889 To.all.T_ID := From.all.T_ID;
893 From.all.T_ID := null;
895 Initialization.Undefer_Abort (Self_ID);
896 end Move_Activation_Chain;
902 -- The task wrapper is a procedure that is called first for each task body
903 -- and which in turn calls the compiler-generated task body procedure.
904 -- The wrapper's main job is to do initialization for the task. It also
905 -- has some locally declared objects that serve as per-task local data.
906 -- Task finalization is done by Complete_Task, which is called from an
907 -- at-end handler that the compiler generates.
909 procedure Task_Wrapper (Self_ID : Task_Id) is
910 use type SSE.Storage_Offset;
911 use System.Standard_Library;
912 use System.Stack_Usage;
914 Bottom_Of_Stack : aliased Integer;
916 Task_Alternate_Stack :
917 aliased SSE.Storage_Array (1 .. Alternate_Stack_Size);
918 -- The alternate signal stack for this task, if any
920 Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
921 -- Whether to use above alternate signal stack for stack overflows
923 Secondary_Stack_Size :
924 constant SSE.Storage_Offset :=
925 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
926 SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100;
928 Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
930 pragma Warnings (Off);
931 -- Why are warnings being turned off here???
933 Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
934 -- Address of secondary stack. In the fixed secondary stack case, this
935 -- value is not modified, causing a warning, hence the bracketing with
936 -- Warnings (Off/On). But why is so much *more* bracketed???
938 Small_Overflow_Guard : constant := 12 * 1024;
939 -- Note: this used to be 4K, but was changed to 12K, since smaller
940 -- values resulted in segmentation faults from dynamic stack analysis.
942 Big_Overflow_Guard : constant := 16 * 1024;
943 Small_Stack_Limit : constant := 64 * 1024;
944 -- ??? These three values are experimental, and seems to work on most
945 -- platforms. They still need to be analyzed further. They also need
946 -- documentation, what are they???
949 Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size);
951 Overflow_Guard : Natural;
952 -- Size of the overflow guard, used by dynamic stack usage analysis
954 pragma Warnings (On);
956 SEH_Table : aliased SSE.Storage_Array (1 .. 8);
957 -- Structured Exception Registration table (2 words)
959 procedure Install_SEH_Handler (Addr : System.Address);
960 pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
961 -- Install the SEH (Structured Exception Handling) handler
963 Cause : Cause_Of_Termination := Normal;
964 -- Indicates the reason why this task terminates. Normal corresponds to
965 -- a task terminating due to completing the last statement of its body,
966 -- or as a result of waiting on a terminate alternative. If the task
967 -- terminates because it is being aborted then Cause will be set to
968 -- Abnormal. If the task terminates because of an exception raised by
969 -- the execution of its task body, then Cause is set to
970 -- Unhandled_Exception.
972 EO : Exception_Occurrence;
973 -- If the task terminates because of an exception raised by the
974 -- execution of its task body, then EO will contain the associated
975 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
977 TH : Termination_Handler := null;
978 -- Pointer to the protected procedure to be executed upon task
981 procedure Search_Fall_Back_Handler (ID : Task_Id);
982 -- Procedure that searches recursively a fall-back handler through the
983 -- master relationship. If the handler is found, its pointer is stored
986 ------------------------------
987 -- Search_Fall_Back_Handler --
988 ------------------------------
990 procedure Search_Fall_Back_Handler (ID : Task_Id) is
992 -- If there is a fall back handler, store its pointer for later
995 if ID.Common.Fall_Back_Handler /= null then
996 TH := ID.Common.Fall_Back_Handler;
998 -- Otherwise look for a fall back handler in the parent
1000 elsif ID.Common.Parent /= null then
1001 Search_Fall_Back_Handler (ID.Common.Parent);
1003 -- Otherwise, do nothing
1008 end Search_Fall_Back_Handler;
1011 pragma Assert (Self_ID.Deferral_Level = 1);
1013 -- Assume a size of the stack taken at this stage
1015 if Size < Small_Stack_Limit then
1016 Overflow_Guard := Small_Overflow_Guard;
1018 Overflow_Guard := Big_Overflow_Guard;
1021 Size := Size - Overflow_Guard;
1023 if not Parameters.Sec_Stack_Dynamic then
1024 Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
1025 Secondary_Stack'Address;
1026 SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
1027 Size := Size - Natural (Secondary_Stack_Size);
1030 if Use_Alternate_Stack then
1031 Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address;
1034 if System.Stack_Usage.Is_Enabled then
1036 Initialize_Analyzer (Self_ID.Common.Analyzer,
1037 Self_ID.Common.Task_Image
1038 (1 .. Self_ID.Common.Task_Image_Len),
1041 SSE.To_Integer (Bottom_Of_Stack'Address));
1043 Fill_Stack (Self_ID.Common.Analyzer);
1046 -- Set the guard page at the bottom of the stack. The call to unprotect
1047 -- the page is done in Terminate_Task
1049 Stack_Guard (Self_ID, True);
1051 -- Initialize low-level TCB components, that cannot be initialized by
1052 -- the creator. Enter_Task sets Self_ID.Known_Tasks_Index and also
1053 -- Self_ID.LL.Thread
1055 Enter_Task (Self_ID);
1057 -- We setup the SEH (Structured Exception Handling) handler if supported
1060 Install_SEH_Handler (SEH_Table'Address);
1062 -- Initialize exception occurrence
1064 Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
1066 -- We lock RTS_Lock to wait for activator to finish activating the rest
1067 -- of the chain, so that everyone in the chain comes out in priority
1070 -- This also protects the value of
1071 -- Self_ID.Common.Activator.Common.Wait_Count.
1076 if not System.Restrictions.Abort_Allowed then
1078 -- If Abort is not allowed, reset the deferral level since it will
1079 -- not get changed by the generated code. Keeping a default value
1080 -- of one would prevent some operations (e.g. select or delay) to
1081 -- proceed successfully.
1083 Self_ID.Deferral_Level := 0;
1087 -- We are separating the following portion of the code in order to
1088 -- place the exception handlers in a different block. In this way,
1089 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
1090 -- set Self in Enter_Task
1092 -- Call the task body procedure
1094 -- The task body is called with abort still deferred. That
1095 -- eliminates a dangerous window, for which we had to patch-up in
1098 -- During the expansion of the task body, we insert an RTS-call
1099 -- to Abort_Undefer, at the first point where abort should be
1102 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
1103 Initialization.Defer_Abort_Nestable (Self_ID);
1106 -- We can't call Terminate_Task in the exception handlers below,
1107 -- since there may be (e.g. in the case of GCC exception handling)
1108 -- clean ups associated with the exception handler that need to
1109 -- access task specific data.
1111 -- Defer abort so that this task can't be aborted while exiting
1113 when Standard'Abort_Signal =>
1114 Initialization.Defer_Abort_Nestable (Self_ID);
1116 -- Update the cause that motivated the task termination so that
1117 -- the appropriate information is passed to the task termination
1118 -- procedure. Task termination as a result of waiting on a
1119 -- terminate alternative is a normal termination, although it is
1120 -- implemented using the abort mechanisms.
1122 if Self_ID.Terminate_Alternative then
1128 -- ??? Using an E : others here causes CD2C11A to fail on Tru64
1130 Initialization.Defer_Abort_Nestable (Self_ID);
1132 -- Perform the task specific exception tracing duty. We handle
1133 -- these outputs here and not in the common notification routine
1134 -- because we need access to tasking related data and we don't
1135 -- want to drag dependencies against tasking related units in the
1136 -- the common notification units. Additionally, no trace is ever
1137 -- triggered from the common routine for the Unhandled_Raise case
1138 -- in tasks, since an exception never appears unhandled in this
1139 -- context because of this handler.
1141 if Exception_Trace = Unhandled_Raise then
1142 Trace_Unhandled_Exception_In_Task (Self_ID);
1145 -- Update the cause that motivated the task termination so that
1146 -- the appropriate information is passed to the task termination
1147 -- procedure, as well as the associated Exception_Occurrence.
1149 Cause := Unhandled_Exception;
1150 Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
1153 -- Look for a task termination handler. This code is for all tasks but
1154 -- the environment task. The task termination code for the environment
1155 -- task is executed by SSL.Task_Termination_Handler.
1161 Write_Lock (Self_ID);
1163 if Self_ID.Common.Specific_Handler /= null then
1164 TH := Self_ID.Common.Specific_Handler;
1166 -- Look for a fall-back handler following the master relationship
1169 Search_Fall_Back_Handler (Self_ID);
1178 -- Execute the task termination handler if we found it
1181 TH.all (Cause, Self_ID, EO);
1184 if System.Stack_Usage.Is_Enabled then
1185 Compute_Result (Self_ID.Common.Analyzer);
1186 Report_Result (Self_ID.Common.Analyzer);
1189 Terminate_Task (Self_ID);
1192 --------------------
1193 -- Terminate_Task --
1194 --------------------
1196 -- Before we allow the thread to exit, we must clean up. This is a a
1197 -- delicate job. We must wake up the task's master, who may immediately try
1198 -- to deallocate the ATCB out from under the current task WHILE IT IS STILL
1201 -- To avoid this, the parent task must be blocked up to the latest
1202 -- statement executed. The trouble is that we have another step that we
1203 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1204 -- We have to postpone that until the end because compiler-generated code
1205 -- is likely to try to access that data at just about any point.
1207 -- We can't call Destroy_TSD while we are holding any other locks, because
1208 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1209 -- that to be the outermost lock. Our first "solution" was to just lock
1210 -- Global_Task_Lock in addition to the other locks, and force the parent to
1211 -- also lock this lock between its wakeup and its freeing of the ATCB. See
1212 -- Complete_Task for the parent-side of the code that has the matching
1213 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1214 -- since the operation Task_Unlock continued to access the ATCB after
1215 -- unlocking, after which the parent was observed to race ahead, deallocate
1216 -- the ATCB, and then reallocate it to another task. The call to
1217 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
1218 -- the data of the new task that reused the ATCB! To solve this problem, we
1219 -- introduced the new operation Final_Task_Unlock.
1221 procedure Terminate_Task (Self_ID : Task_Id) is
1222 Environment_Task : constant Task_Id := STPO.Environment_Task;
1223 Master_of_Task : Integer;
1226 Debug.Task_Termination_Hook;
1228 if Runtime_Traces then
1229 Send_Trace_Info (T_Terminate);
1232 -- Since GCC cannot allocate stack chunks efficiently without reordering
1233 -- some of the allocations, we have to handle this unexpected situation
1234 -- here. We should normally never have to call Vulnerable_Complete_Task
1237 if Self_ID.Common.Activator /= null then
1238 Vulnerable_Complete_Task (Self_ID);
1241 Initialization.Task_Lock (Self_ID);
1247 Master_of_Task := Self_ID.Master_of_Task;
1249 -- Check if the current task is an independent task If so, decrement
1250 -- the Independent_Task_Count value.
1252 if Master_of_Task = Independent_Task_Level then
1254 Utilities.Independent_Task_Count :=
1255 Utilities.Independent_Task_Count - 1;
1257 Write_Lock (Environment_Task);
1258 Utilities.Independent_Task_Count :=
1259 Utilities.Independent_Task_Count - 1;
1260 Unlock (Environment_Task);
1264 -- Unprotect the guard page if needed
1266 Stack_Guard (Self_ID, False);
1268 Utilities.Make_Passive (Self_ID, Task_Completed => True);
1274 pragma Assert (Check_Exit (Self_ID));
1276 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
1277 Initialization.Final_Task_Unlock (Self_ID);
1279 -- WARNING: past this point, this thread must assume that the ATCB has
1280 -- been deallocated. It should not be accessed again.
1282 if Master_of_Task > 0 then
1291 function Terminated (T : Task_Id) return Boolean is
1292 Self_ID : constant Task_Id := STPO.Self;
1296 Initialization.Defer_Abort_Nestable (Self_ID);
1303 Result := T.Common.State = Terminated;
1310 Initialization.Undefer_Abort_Nestable (Self_ID);
1314 ----------------------------------------
1315 -- Trace_Unhandled_Exception_In_Task --
1316 ----------------------------------------
1318 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
1319 procedure To_Stderr (S : String);
1320 pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
1322 use System.Soft_Links;
1323 use System.Standard_Library;
1325 function To_Address is new
1326 Ada.Unchecked_Conversion
1327 (Task_Id, System.Task_Primitives.Task_Address);
1329 function Tailored_Exception_Information
1330 (E : Exception_Occurrence) return String;
1332 (Ada, Tailored_Exception_Information,
1333 "__gnat_tailored_exception_information");
1335 Excep : constant Exception_Occurrence_Access :=
1336 SSL.Get_Current_Excep.all;
1339 -- This procedure is called by the task outermost handler in
1340 -- Task_Wrapper below, so only once the task stack has been fully
1341 -- unwound. The common notification routine has been called at the
1342 -- raise point already.
1344 To_Stderr ("task ");
1346 if Self_Id.Common.Task_Image_Len /= 0 then
1348 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
1352 To_Stderr (System.Address_Image (To_Address (Self_Id)));
1353 To_Stderr (" terminated by unhandled exception");
1354 To_Stderr ((1 => ASCII.LF));
1355 To_Stderr (Tailored_Exception_Information (Excep.all));
1356 end Trace_Unhandled_Exception_In_Task;
1358 ------------------------------------
1359 -- Vulnerable_Complete_Activation --
1360 ------------------------------------
1362 -- As in several other places, the locks of the activator and activated
1363 -- task are both locked here. This follows our deadlock prevention lock
1364 -- ordering policy, since the activated task must be created after the
1367 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
1368 Activator : constant Task_Id := Self_ID.Common.Activator;
1371 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
1373 Write_Lock (Activator);
1374 Write_Lock (Self_ID);
1376 pragma Assert (Self_ID.Common.Activator /= null);
1378 -- Remove dangling reference to Activator, since a task may
1379 -- outlive its activator.
1381 Self_ID.Common.Activator := null;
1383 -- Wake up the activator, if it is waiting for a chain of tasks to
1384 -- activate, and we are the last in the chain to complete activation.
1386 if Activator.Common.State = Activator_Sleep then
1387 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
1389 if Activator.Common.Wait_Count = 0 then
1390 Wakeup (Activator, Activator_Sleep);
1394 -- The activator raises a Tasking_Error if any task it is activating
1395 -- is completed before the activation is done. However, if the reason
1396 -- for the task completion is an abort, we do not raise an exception.
1399 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
1400 Activator.Common.Activation_Failed := True;
1406 -- After the activation, active priority should be the same as base
1407 -- priority. We must unlock the Activator first, though, since it
1408 -- should not wait if we have lower priority.
1410 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
1411 Write_Lock (Self_ID);
1412 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1415 end Vulnerable_Complete_Activation;
1417 --------------------------------
1418 -- Vulnerable_Complete_Master --
1419 --------------------------------
1421 procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
1424 CM : constant Master_Level := Self_ID.Master_Within;
1425 T : aliased Task_Id;
1427 To_Be_Freed : Task_Id;
1428 -- This is a list of ATCBs to be freed, after we have released
1429 -- all RTS locks. This is necessary because of the locking order
1430 -- rules, since the storage manager uses Global_Task_Lock.
1432 pragma Warnings (Off);
1433 function Check_Unactivated_Tasks return Boolean;
1434 pragma Warnings (On);
1435 -- Temporary error-checking code below. This is part of the checks
1436 -- added in the new run time. Call it only inside a pragma Assert.
1438 -----------------------------
1439 -- Check_Unactivated_Tasks --
1440 -----------------------------
1442 function Check_Unactivated_Tasks return Boolean is
1444 if not Single_Lock then
1448 Write_Lock (Self_ID);
1450 C := All_Tasks_List;
1451 while C /= null loop
1452 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
1456 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1459 if C.Common.State = Unactivated then
1466 C := C.Common.All_Tasks_Link;
1471 if not Single_Lock then
1476 end Check_Unactivated_Tasks;
1478 -- Start of processing for Vulnerable_Complete_Master
1482 (Debug.Trace (Self_ID, "V_Complete_Master", 'C'));
1484 pragma Assert (Self_ID.Common.Wait_Count = 0);
1486 (Self_ID.Deferral_Level > 0
1487 or else not System.Restrictions.Abort_Allowed);
1489 -- Count how many active dependent tasks this master currently has, and
1490 -- record this in Wait_Count.
1492 -- This count should start at zero, since it is initialized to zero for
1493 -- new tasks, and the task should not exit the sleep-loops that use this
1494 -- count until the count reaches zero.
1496 -- While we're counting, if we run across any unactivated tasks that
1497 -- belong to this master, we summarily terminate them as required by
1501 Write_Lock (Self_ID);
1503 C := All_Tasks_List;
1504 while C /= null loop
1506 -- Terminate unactivated (never-to-be activated) tasks
1508 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
1510 pragma Assert (C.Common.State = Unactivated);
1511 -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
1512 -- = CM. The only case where C is pending activation by this
1513 -- task, but the master of C is not CM is in Ada 2005, when C is
1514 -- part of a return object of a build-in-place function.
1517 C.Common.Activator := null;
1518 C.Common.State := Terminated;
1519 C.Callable := False;
1520 Utilities.Cancel_Queued_Entry_Calls (C);
1524 -- Count it if dependent on this master
1526 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1529 if C.Awake_Count /= 0 then
1530 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1536 C := C.Common.All_Tasks_Link;
1539 Self_ID.Common.State := Master_Completion_Sleep;
1542 if not Single_Lock then
1546 -- Wait until dependent tasks are all terminated or ready to terminate.
1547 -- While waiting, the task may be awakened if the task's priority needs
1548 -- changing, or this master is aborted. In the latter case, we abort the
1549 -- dependents, and resume waiting until Wait_Count goes to zero.
1551 Write_Lock (Self_ID);
1554 exit when Self_ID.Common.Wait_Count = 0;
1556 -- Here is a difference as compared to Complete_Master
1558 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1559 and then not Self_ID.Dependents_Aborted
1562 Abort_Dependents (Self_ID);
1566 Abort_Dependents (Self_ID);
1568 Write_Lock (Self_ID);
1571 Sleep (Self_ID, Master_Completion_Sleep);
1575 Self_ID.Common.State := Runnable;
1578 -- Dependents are all terminated or on terminate alternatives. Now,
1579 -- force those on terminate alternatives to terminate, by aborting them.
1581 pragma Assert (Check_Unactivated_Tasks);
1583 if Self_ID.Alive_Count > 1 then
1585 -- Consider finding a way to skip the following extra steps if there
1586 -- are no dependents with terminate alternatives. This could be done
1587 -- by adding another count to the ATCB, similar to Awake_Count, but
1588 -- keeping track of tasks that are on terminate alternatives.
1590 pragma Assert (Self_ID.Common.Wait_Count = 0);
1592 -- Force any remaining dependents to terminate by aborting them
1594 if not Single_Lock then
1598 Abort_Dependents (Self_ID);
1600 -- Above, when we "abort" the dependents we are simply using this
1601 -- operation for convenience. We are not required to support the full
1602 -- abort-statement semantics; in particular, we are not required to
1603 -- immediately cancel any queued or in-service entry calls. That is
1604 -- good, because if we tried to cancel a call we would need to lock
1605 -- the caller, in order to wake the caller up. Our anti-deadlock
1606 -- rules prevent us from doing that without releasing the locks on C
1607 -- and Self_ID. Releasing and retaking those locks would be wasteful
1608 -- at best, and should not be considered further without more
1609 -- detailed analysis of potential concurrent accesses to the ATCBs
1610 -- of C and Self_ID.
1612 -- Count how many "alive" dependent tasks this master currently has,
1613 -- and record this in Wait_Count. This count should start at zero,
1614 -- since it is initialized to zero for new tasks, and the task should
1615 -- not exit the sleep-loops that use this count until the count
1618 pragma Assert (Self_ID.Common.Wait_Count = 0);
1620 Write_Lock (Self_ID);
1622 C := All_Tasks_List;
1623 while C /= null loop
1624 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1627 pragma Assert (C.Awake_Count = 0);
1629 if C.Alive_Count > 0 then
1630 pragma Assert (C.Terminate_Alternative);
1631 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1637 C := C.Common.All_Tasks_Link;
1640 Self_ID.Common.State := Master_Phase_2_Sleep;
1643 if not Single_Lock then
1647 -- Wait for all counted tasks to finish terminating themselves
1649 Write_Lock (Self_ID);
1652 exit when Self_ID.Common.Wait_Count = 0;
1653 Sleep (Self_ID, Master_Phase_2_Sleep);
1656 Self_ID.Common.State := Runnable;
1660 -- We don't wake up for abort here. We are already terminating just as
1661 -- fast as we can, so there is no point.
1663 -- Remove terminated tasks from the list of Self_ID's dependents, but
1664 -- don't free their ATCBs yet, because of lock order restrictions, which
1665 -- don't allow us to call "free" or "malloc" while holding any other
1666 -- locks. Instead, we put those ATCBs to be freed onto a temporary list,
1667 -- called To_Be_Freed.
1669 if not Single_Lock then
1673 C := All_Tasks_List;
1675 while C /= null loop
1676 if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then
1678 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
1680 All_Tasks_List := C.Common.All_Tasks_Link;
1683 T := C.Common.All_Tasks_Link;
1684 C.Common.All_Tasks_Link := To_Be_Freed;
1690 C := C.Common.All_Tasks_Link;
1696 -- Free all the ATCBs on the list To_Be_Freed
1698 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1699 -- any interrupt entries are detached from them they should no longer
1702 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1703 -- avoid a race between a terminating task and its parent. The parent
1704 -- might try to deallocate the ACTB out from underneath the exiting
1705 -- task. Note that Free will also lock Global_Task_Lock, but that is
1706 -- OK, since this is the *one* lock for which we have a mechanism to
1707 -- support nested locking. See Task_Wrapper and its finalizer for more
1711 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1712 -- references to terminated library-level tasks, which could otherwise
1713 -- occur during finalization of library-level objects. A better solution
1714 -- might be to hook task objects into the finalization chain and
1715 -- deallocate the ATCB when the task object is deallocated. However,
1716 -- this change is not likely to gain anything significant, since all
1717 -- this storage should be recovered en-masse when the process exits.
1719 while To_Be_Freed /= null loop
1721 To_Be_Freed := T.Common.All_Tasks_Link;
1723 -- ??? On SGI there is currently no Interrupt_Manager, that's
1724 -- why we need to check if the Interrupt_Manager_ID is null
1726 if T.Interrupt_Entry and Interrupt_Manager_ID /= null then
1728 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
1729 -- Corresponds to the entry index of System.Interrupts.
1730 -- Interrupt_Manager.Detach_Interrupt_Entries.
1731 -- Be sure to update this value when changing
1732 -- Interrupt_Manager specs.
1734 type Param_Type is access all Task_Id;
1736 Param : aliased Param_Type := T'Access;
1739 System.Tasking.Rendezvous.Call_Simple
1740 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
1745 if (T.Common.Parent /= null
1746 and then T.Common.Parent.Common.Parent /= null)
1747 or else T.Master_of_Task > Library_Task_Level
1749 Initialization.Task_Lock (Self_ID);
1751 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1752 -- has not been called yet (case of an unactivated task).
1754 if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then
1755 SSL.Destroy_TSD (T.Common.Compiler_Data);
1758 Vulnerable_Free_Task (T);
1759 Initialization.Task_Unlock (Self_ID);
1763 -- It might seem nice to let the terminated task deallocate its own
1764 -- ATCB. That would not cover the case of unactivated tasks. It also
1765 -- would force us to keep the underlying thread around past termination,
1766 -- since references to the ATCB are possible past termination.
1768 -- Currently, we get rid of the thread as soon as the task terminates,
1769 -- and let the parent recover the ATCB later.
1771 -- Some day, if we want to recover the ATCB earlier, at task
1772 -- termination, we could consider using "fat task IDs", that include the
1773 -- serial number with the ATCB pointer, to catch references to tasks
1774 -- that no longer have ATCBs. It is not clear how much this would gain,
1775 -- since the user-level task object would still be occupying storage.
1777 -- Make next master level up active. We don't need to lock the ATCB,
1778 -- since the value is only updated by each task for itself.
1780 Self_ID.Master_Within := CM - 1;
1781 end Vulnerable_Complete_Master;
1783 ------------------------------
1784 -- Vulnerable_Complete_Task --
1785 ------------------------------
1787 -- Complete the calling task
1789 -- This procedure must be called with abort deferred. It should only be
1790 -- called by Complete_Task and Finalize_Global_Tasks (for the environment
1793 -- The effect is similar to that of Complete_Master. Differences include
1794 -- the closing of entries here, and computation of the number of active
1795 -- dependent tasks in Complete_Master.
1797 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1798 -- because that does its own locking, and because we do not need the lock
1799 -- to test Self_ID.Common.Activator. That value should only be read and
1800 -- modified by Self.
1802 procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
1805 (Self_ID.Deferral_Level > 0
1806 or else not System.Restrictions.Abort_Allowed);
1807 pragma Assert (Self_ID = Self);
1808 pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1
1810 Self_ID.Master_Within = Self_ID.Master_of_Task + 2);
1811 pragma Assert (Self_ID.Common.Wait_Count = 0);
1812 pragma Assert (Self_ID.Open_Accepts = null);
1813 pragma Assert (Self_ID.ATC_Nesting_Level = 1);
1815 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
1821 Write_Lock (Self_ID);
1822 Self_ID.Callable := False;
1824 -- In theory, Self should have no pending entry calls left on its
1825 -- call-stack. Each async. select statement should clean its own call,
1826 -- and blocking entry calls should defer abort until the calls are
1827 -- cancelled, then clean up.
1829 Utilities.Cancel_Queued_Entry_Calls (Self_ID);
1832 if Self_ID.Common.Activator /= null then
1833 Vulnerable_Complete_Activation (Self_ID);
1840 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have
1841 -- dependent tasks for which we need to wait. Otherwise we just exit.
1843 if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
1844 Vulnerable_Complete_Master (Self_ID);
1846 end Vulnerable_Complete_Task;
1848 --------------------------
1849 -- Vulnerable_Free_Task --
1850 --------------------------
1852 -- Recover all runtime system storage associated with the task T. This
1853 -- should only be called after T has terminated and will no longer be
1856 -- For tasks created by an allocator that fails, due to an exception, it
1857 -- is called from Expunge_Unactivated_Tasks.
1859 -- For tasks created by elaboration of task object declarations it is
1860 -- called from the finalization code of the Task_Wrapper procedure. It is
1861 -- also called from Ada.Unchecked_Deallocation, for objects that are or
1864 procedure Vulnerable_Free_Task (T : Task_Id) is
1866 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
1873 Initialization.Finalize_Attributes_Link.all (T);
1880 System.Task_Primitives.Operations.Finalize_TCB (T);
1881 end Vulnerable_Free_Task;
1883 -- Package elaboration code
1886 -- Establish the Adafinal softlink
1888 -- This is not done inside the central RTS initialization routine
1889 -- to avoid with-ing this package from System.Tasking.Initialization.
1891 SSL.Adafinal := Finalize_Global_Tasks'Access;
1893 -- Establish soft links for subprograms that manipulate master_id's.
1894 -- This cannot be done when the RTS is initialized, because of various
1895 -- elaboration constraints.
1897 SSL.Current_Master := Stages.Current_Master'Access;
1898 SSL.Enter_Master := Stages.Enter_Master'Access;
1899 SSL.Complete_Master := Stages.Complete_Master'Access;
1900 end System.Tasking.Stages;