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-2011, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
33 -- Turn off polling, we do not want ATC polling to take place during tasking
34 -- operations. It causes infinite loops and other problems.
37 with Ada.Unchecked_Deallocation;
39 with System.Interrupt_Management;
40 with System.Tasking.Debug;
41 with System.Address_Image;
42 with System.Task_Primitives;
43 with System.Task_Primitives.Operations;
44 with System.Tasking.Utilities;
45 with System.Tasking.Queuing;
46 with System.Tasking.Rendezvous;
47 with System.OS_Primitives;
48 with System.Secondary_Stack;
49 with System.Storage_Elements;
50 with System.Restrictions;
51 with System.Standard_Library;
52 with System.Traces.Tasking;
53 with System.Stack_Usage;
55 with System.Soft_Links;
56 -- These are procedure pointers to non-tasking routines that use task
57 -- specific data. In the absence of tasking, these routines refer to global
58 -- data. In the presence of tasking, they must be replaced with pointers to
59 -- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current
60 -- _Excep, Finalize_Library_Objects, Task_Termination, Handler.
62 with System.Tasking.Initialization;
63 pragma Elaborate_All (System.Tasking.Initialization);
64 -- This insures that tasking is initialized if any tasks are created
66 package body System.Tasking.Stages is
68 package STPO renames System.Task_Primitives.Operations;
69 package SSL renames System.Soft_Links;
70 package SSE renames System.Storage_Elements;
71 package SST renames System.Secondary_Stack;
77 use Task_Primitives.Operations;
81 use System.Traces.Tasking;
83 -----------------------
84 -- Local Subprograms --
85 -----------------------
88 Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
90 procedure Free_Entry_Names (T : Task_Id);
91 -- Deallocate all string names associated with task entries
93 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
94 -- This procedure outputs the task specific message for exception
97 procedure Task_Wrapper (Self_ID : Task_Id);
98 pragma Convention (C, Task_Wrapper);
99 -- This is the procedure that is called by the GNULL from the new context
100 -- when a task is created. It waits for activation and then calls the task
101 -- body procedure. When the task body procedure completes, it terminates
104 -- The Task_Wrapper's address will be provided to the underlying threads
105 -- library as the task entry point. Convention C is what makes most sense
106 -- for that purpose (Export C would make the function globally visible,
107 -- and affect the link name on which GDB depends). This will in addition
108 -- trigger an automatic stack alignment suitable for GCC's assumptions if
111 -- "Vulnerable_..." in the procedure names below means they must be called
112 -- with abort deferred.
114 procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
115 -- Complete the calling task. This procedure must be called with
116 -- abort deferred. It should only be called by Complete_Task and
117 -- Finalize_Global_Tasks (for the environment task).
119 procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
120 -- Complete the current master of the calling task. This procedure
121 -- must be called with abort deferred. It should only be called by
122 -- Vulnerable_Complete_Task and Complete_Master.
124 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
125 -- Signal to Self_ID's activator that Self_ID has completed activation.
126 -- This procedure must be called with abort deferred.
128 procedure Abort_Dependents (Self_ID : Task_Id);
129 -- Abort all the direct dependents of Self at its current master nesting
130 -- level, plus all of their dependents, transitively. RTS_Lock should be
131 -- locked by the caller.
133 procedure Vulnerable_Free_Task (T : Task_Id);
134 -- Recover all runtime system storage associated with the task T. This
135 -- should only be called after T has terminated and will no longer be
138 -- For tasks created by an allocator that fails, due to an exception, it is
139 -- called from Expunge_Unactivated_Tasks.
141 -- Different code is used at master completion, in Terminate_Dependents,
142 -- due to a need for tighter synchronization with the master.
144 ----------------------
145 -- Abort_Dependents --
146 ----------------------
148 procedure Abort_Dependents (Self_ID : Task_Id) is
155 P := C.Common.Parent;
159 -- ??? C is supposed to take care of its own dependents, so
160 -- there should be no need to worry about them. Need to double
163 if C.Master_of_Task = Self_ID.Master_Within then
164 Utilities.Abort_One_Task (Self_ID, C);
165 C.Dependents_Aborted := True;
171 P := P.Common.Parent;
174 C := C.Common.All_Tasks_Link;
177 Self_ID.Dependents_Aborted := True;
178 end Abort_Dependents;
184 procedure Abort_Tasks (Tasks : Task_List) is
186 Utilities.Abort_Tasks (Tasks);
193 -- Note that locks of activator and activated task are both locked here.
194 -- This is necessary because C.Common.State and Self.Common.Wait_Count have
195 -- to be synchronized. This is safe from deadlock because the activator is
196 -- always created before the activated task. That satisfies our
197 -- in-order-of-creation ATCB locking policy.
199 -- At one point, we may also lock the parent, if the parent is different
200 -- from the activator. That is also consistent with the lock ordering
201 -- policy, since the activator cannot be created before the parent.
203 -- Since we are holding both the activator's lock, and Task_Wrapper locks
204 -- that before it does anything more than initialize the low-level ATCB
205 -- components, it should be safe to wait to update the counts until we see
206 -- that the thread creation is successful.
208 -- If the thread creation fails, we do need to close the entries of the
209 -- task. The first phase, of dequeuing calls, only requires locking the
210 -- acceptor's ATCB, but the waking up of the callers requires locking the
211 -- caller's ATCB. We cannot safely do this while we are holding other
212 -- locks. Therefore, the queue-clearing operation is done in a separate
213 -- pass over the activation chain.
215 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
216 Self_ID : constant Task_Id := STPO.Self;
219 Next_C, Last_C : Task_Id;
220 Activate_Prio : System.Any_Priority;
222 All_Elaborated : Boolean := True;
225 -- If pragma Detect_Blocking is active, then we must check whether this
226 -- potentially blocking operation is called from a protected action.
228 if System.Tasking.Detect_Blocking
229 and then Self_ID.Common.Protected_Action_Nesting > 0
231 raise Program_Error with "potentially blocking operation";
235 (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
237 Initialization.Defer_Abort_Nestable (Self_ID);
239 pragma Assert (Self_ID.Common.Wait_Count = 0);
241 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
242 -- we finish activating the chain.
246 -- Check that all task bodies have been elaborated
248 C := Chain_Access.T_ID;
251 if C.Common.Elaborated /= null
252 and then not C.Common.Elaborated.all
254 All_Elaborated := False;
257 -- Reverse the activation chain so that tasks are activated in the
258 -- same order they're declared.
260 Next_C := C.Common.Activation_Link;
261 C.Common.Activation_Link := Last_C;
266 Chain_Access.T_ID := Last_C;
268 if not All_Elaborated then
270 Initialization.Undefer_Abort_Nestable (Self_ID);
271 raise Program_Error with "Some tasks have not been elaborated";
274 -- Activate all the tasks in the chain. Creation of the thread of
275 -- control was deferred until activation. So create it now.
277 C := Chain_Access.T_ID;
279 if C.Common.State /= Terminated then
280 pragma Assert (C.Common.State = Unactivated);
282 P := C.Common.Parent;
287 (if C.Common.Base_Priority < Get_Priority (Self_ID)
288 then Get_Priority (Self_ID)
289 else C.Common.Base_Priority);
291 System.Task_Primitives.Operations.Create_Task
292 (C, Task_Wrapper'Address,
294 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
295 Activate_Prio, Success);
297 -- There would be a race between the created task and the creator
298 -- to do the following initialization, if we did not have a
299 -- Lock/Unlock_RTS pair in the task wrapper to prevent it from
303 C.Common.State := Activating;
306 P.Awake_Count := P.Awake_Count + 1;
307 P.Alive_Count := P.Alive_Count + 1;
309 if P.Common.State = Master_Completion_Sleep and then
310 C.Master_of_Task = P.Master_Within
312 pragma Assert (Self_ID /= P);
313 P.Common.Wait_Count := P.Common.Wait_Count + 1;
316 for J in System.Tasking.Debug.Known_Tasks'Range loop
317 if System.Tasking.Debug.Known_Tasks (J) = null then
318 System.Tasking.Debug.Known_Tasks (J) := C;
319 C.Known_Tasks_Index := J;
324 if Global_Task_Debug_Event_Set then
325 Debug.Signal_Debug_Event
326 (Debug.Debug_Event_Activating, C);
329 C.Common.State := Runnable;
335 -- No need to set Awake_Count, State, etc. here since the loop
336 -- below will do that for any Unactivated tasks.
340 Self_ID.Common.Activation_Failed := True;
344 C := C.Common.Activation_Link;
347 if not Single_Lock then
351 -- Close the entries of any tasks that failed thread creation, and count
352 -- those that have not finished activation.
354 Write_Lock (Self_ID);
355 Self_ID.Common.State := Activator_Sleep;
357 C := Chain_Access.T_ID;
361 if C.Common.State = Unactivated then
362 C.Common.Activator := null;
363 C.Common.State := Terminated;
365 Utilities.Cancel_Queued_Entry_Calls (C);
367 elsif C.Common.Activator /= null then
368 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
372 P := C.Common.Activation_Link;
373 C.Common.Activation_Link := null;
377 -- Wait for the activated tasks to complete activation. It is
378 -- unsafe to abort any of these tasks until the count goes to zero.
381 exit when Self_ID.Common.Wait_Count = 0;
382 Sleep (Self_ID, Activator_Sleep);
385 Self_ID.Common.State := Runnable;
392 -- Remove the tasks from the chain
394 Chain_Access.T_ID := null;
395 Initialization.Undefer_Abort_Nestable (Self_ID);
397 if Self_ID.Common.Activation_Failed then
398 Self_ID.Common.Activation_Failed := False;
399 raise Tasking_Error with "Failure during activation";
403 -------------------------
404 -- Complete_Activation --
405 -------------------------
407 procedure Complete_Activation is
408 Self_ID : constant Task_Id := STPO.Self;
411 Initialization.Defer_Abort_Nestable (Self_ID);
417 Vulnerable_Complete_Activation (Self_ID);
423 Initialization.Undefer_Abort_Nestable (Self_ID);
425 -- ??? Why do we need to allow for nested deferral here?
427 if Runtime_Traces then
428 Send_Trace_Info (T_Activate);
430 end Complete_Activation;
432 ---------------------
433 -- Complete_Master --
434 ---------------------
436 procedure Complete_Master is
437 Self_ID : constant Task_Id := STPO.Self;
440 (Self_ID.Deferral_Level > 0
441 or else not System.Restrictions.Abort_Allowed);
442 Vulnerable_Complete_Master (Self_ID);
449 -- See comments on Vulnerable_Complete_Task for details
451 procedure Complete_Task is
452 Self_ID : constant Task_Id := STPO.Self;
456 (Self_ID.Deferral_Level > 0
457 or else not System.Restrictions.Abort_Allowed);
459 Vulnerable_Complete_Task (Self_ID);
461 -- All of our dependents have terminated. Never undefer abort again!
469 -- Compiler interface only. Do not call from within the RTS. This must be
470 -- called to create a new task.
472 procedure Create_Task
474 Size : System.Parameters.Size_Type;
475 Task_Info : System.Task_Info.Task_Info_Type;
477 Relative_Deadline : Ada.Real_Time.Time_Span;
478 Domain : Dispatching_Domain_Access;
479 Num_Entries : Task_Entry_Index;
480 Master : Master_Level;
481 State : Task_Procedure_Access;
482 Discriminants : System.Address;
483 Elaborated : Access_Boolean;
484 Chain : in out Activation_Chain;
486 Created_Task : out Task_Id;
487 Build_Entry_Names : Boolean)
490 Self_ID : constant Task_Id := STPO.Self;
492 Base_Priority : System.Any_Priority;
494 Base_CPU : System.Multiprocessors.CPU_Range;
496 use type System.Multiprocessors.CPU_Range;
498 pragma Unreferenced (Relative_Deadline);
499 -- EDF scheduling is not supported by any of the target platforms so
500 -- this parameter is not passed any further.
503 -- If Master is greater than the current master, it means that Master
504 -- has already awaited its dependent tasks. This raises Program_Error,
505 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
507 if Self_ID.Master_of_Task /= Foreign_Task_Level
508 and then Master > Self_ID.Master_Within
510 raise Program_Error with
511 "create task after awaiting termination";
514 -- If pragma Detect_Blocking is active must be checked whether this
515 -- potentially blocking operation is called from a protected action.
517 if System.Tasking.Detect_Blocking
518 and then Self_ID.Common.Protected_Action_Nesting > 0
520 raise Program_Error with "potentially blocking operation";
523 pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C'));
526 (if Priority = Unspecified_Priority
527 then Self_ID.Common.Base_Priority
528 else System.Any_Priority (Priority));
530 if CPU /= Unspecified_CPU
531 and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
533 CPU > Integer (System.Multiprocessors.CPU_Range'Last)
535 CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
537 raise Tasking_Error with "CPU not in range";
539 -- Normal CPU affinity
543 (if CPU = Unspecified_CPU
544 then Self_ID.Common.Base_CPU
545 else System.Multiprocessors.CPU_Range (CPU));
548 -- Find parent P of new Task, via master level number
553 while P.Master_of_Task >= Master loop
554 P := P.Common.Parent;
559 Initialization.Defer_Abort_Nestable (Self_ID);
562 T := New_ATCB (Num_Entries);
565 Initialization.Undefer_Abort_Nestable (Self_ID);
566 raise Storage_Error with "Cannot allocate task";
569 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this
570 -- point, it is possible that we may be part of a family of tasks that
574 Write_Lock (Self_ID);
576 -- Now, we must check that we have not been aborted. If so, we should
577 -- give up on creating this task, and simply return.
579 if not Self_ID.Callable then
580 pragma Assert (Self_ID.Pending_ATC_Level = 0);
581 pragma Assert (Self_ID.Pending_Action);
583 (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
587 Initialization.Undefer_Abort_Nestable (Self_ID);
589 -- ??? Should never get here
591 pragma Assert (False);
592 raise Standard'Abort_Signal;
595 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
596 Base_Priority, Base_CPU, Domain, Task_Info, Size, T, Success);
602 Initialization.Undefer_Abort_Nestable (Self_ID);
603 raise Storage_Error with "Failed to initialize task";
606 if Master = Foreign_Task_Level + 2 then
608 -- This should not happen, except when a foreign task creates non
609 -- library-level Ada tasks. In this case, we pretend the master is
610 -- a regular library level task, otherwise the run-time will get
611 -- confused when waiting for these tasks to terminate.
613 T.Master_of_Task := Library_Task_Level;
616 T.Master_of_Task := Master;
619 T.Master_Within := T.Master_of_Task + 1;
621 for L in T.Entry_Calls'Range loop
622 T.Entry_Calls (L).Self := T;
623 T.Entry_Calls (L).Level := L;
626 if Task_Image'Length = 0 then
627 T.Common.Task_Image_Len := 0;
630 T.Common.Task_Image (1) := Task_Image (Task_Image'First);
632 -- Remove unwanted blank space generated by 'Image
634 for J in Task_Image'First + 1 .. Task_Image'Last loop
635 if Task_Image (J) /= ' '
636 or else Task_Image (J - 1) /= '('
639 T.Common.Task_Image (Len) := Task_Image (J);
640 exit when Len = T.Common.Task_Image'Last;
644 T.Common.Task_Image_Len := Len;
647 -- The task inherits the dispatching domain of the parent only if no
648 -- specific domain has been defined in the spec of the task (using the
649 -- dispatching domain pragma or aspect).
651 if T.Common.Domain /= null then
653 elsif T.Common.Activator /= null then
654 T.Common.Domain := T.Common.Activator.Common.Domain;
656 T.Common.Domain := System.Tasking.System_Domain;
662 -- The CPU associated to the task (if any) must belong to the
663 -- dispatching domain.
665 if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
667 (Base_CPU not in T.Common.Domain'Range
668 or else not T.Common.Domain (Base_CPU))
670 Initialization.Undefer_Abort_Nestable (Self_ID);
671 raise Tasking_Error with "CPU not in dispatching domain";
674 -- To handle the interaction between pragma CPU and dispatching domains
675 -- we need to signal that this task is being allocated to a processor.
676 -- This is needed only for tasks belonging to the system domain (the
677 -- creation of new dispatching domains can only take processors from the
678 -- system domain) and only before the environment task calls the main
679 -- procedure (dispatching domains cannot be created after this).
681 if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
682 and then T.Common.Domain = System.Tasking.System_Domain
683 and then not System.Tasking.Dispatching_Domains_Frozen
685 -- Increase the number of tasks attached to the CPU to which this
686 -- task is being moved.
688 Dispatching_Domain_Tasks (Base_CPU) :=
689 Dispatching_Domain_Tasks (Base_CPU) + 1;
692 -- Note: we should not call 'new' while holding locks since new may use
693 -- locks (e.g. RTS_Lock under Windows) itself and cause a deadlock.
695 if Build_Entry_Names then
697 new Entry_Names_Array (1 .. Entry_Index (Num_Entries));
700 -- Create TSD as early as possible in the creation of a task, since it
701 -- may be used by the operation of Ada code within the task.
703 SSL.Create_TSD (T.Common.Compiler_Data);
704 T.Common.Activation_Link := Chain.T_ID;
706 Initialization.Initialize_Attributes_Link.all (T);
708 Initialization.Undefer_Abort_Nestable (Self_ID);
710 if Runtime_Traces then
711 Send_Trace_Info (T_Create, T);
719 function Current_Master return Master_Level is
721 return STPO.Self.Master_Within;
728 procedure Enter_Master is
729 Self_ID : constant Task_Id := STPO.Self;
731 Self_ID.Master_Within := Self_ID.Master_Within + 1;
734 -------------------------------
735 -- Expunge_Unactivated_Tasks --
736 -------------------------------
738 -- See procedure Close_Entries for the general case
740 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
741 Self_ID : constant Task_Id := STPO.Self;
743 Call : Entry_Call_Link;
748 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
750 Initialization.Defer_Abort_Nestable (Self_ID);
753 -- Experimentation has shown that abort is sometimes (but not always)
754 -- already deferred when this is called.
756 -- That may indicate an error. Find out what is going on
760 pragma Assert (C.Common.State = Unactivated);
762 Temp := C.Common.Activation_Link;
764 if C.Common.State = Unactivated then
768 for J in 1 .. C.Entry_Num loop
769 Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
770 pragma Assert (Call = null);
775 Initialization.Remove_From_All_Tasks_List (C);
778 Vulnerable_Free_Task (C);
784 Initialization.Undefer_Abort_Nestable (Self_ID);
785 end Expunge_Unactivated_Tasks;
787 ---------------------------
788 -- Finalize_Global_Tasks --
789 ---------------------------
792 -- We have a potential problem here if finalization of global objects does
793 -- anything with signals or the timer server, since by that time those
794 -- servers have terminated.
796 -- It is hard to see how that would occur
798 -- However, a better solution might be to do all this finalization
799 -- using the global finalization chain.
801 procedure Finalize_Global_Tasks is
802 Self_ID : constant Task_Id := STPO.Self;
805 pragma Unreferenced (Ignore);
808 (Int : System.Interrupt_Management.Interrupt_ID) return Character;
809 pragma Import (C, State, "__gnat_get_interrupt_state");
810 -- Get interrupt state for interrupt number Int. Defined in init.c
812 Default : constant Character := 's';
813 -- 's' Interrupt_State pragma set state to System (use "default"
817 if Self_ID.Deferral_Level = 0 then
819 -- In principle, we should be able to predict whether abort is
820 -- already deferred here (and it should not be deferred yet but in
821 -- practice it seems Finalize_Global_Tasks is being called sometimes,
822 -- from RTS code for exceptions, with abort already deferred.
824 Initialization.Defer_Abort_Nestable (Self_ID);
826 -- Never undefer again!!!
829 -- This code is only executed by the environment task
831 pragma Assert (Self_ID = Environment_Task);
833 -- Set Environment_Task'Callable to false to notify library-level tasks
834 -- that it is waiting for them.
836 Self_ID.Callable := False;
838 -- Exit level 2 master, for normal tasks in library-level packages
842 -- Force termination of "independent" library-level server tasks
846 Abort_Dependents (Self_ID);
848 if not Single_Lock then
852 -- We need to explicitly wait for the task to be terminated here
853 -- because on true concurrent system, we may end this procedure before
854 -- the tasks are really terminated.
856 Write_Lock (Self_ID);
858 -- If the Abort_Task signal is set to system, it means that we may not
859 -- have been able to abort all independent tasks (in particular
860 -- Server_Task may be blocked, waiting for a signal), in which case,
861 -- do not wait for Independent_Task_Count to go down to 0.
864 (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
867 exit when Utilities.Independent_Task_Count = 0;
869 -- We used to yield here, but this did not take into account low
870 -- priority tasks that would cause dead lock in some cases (true
874 (Self_ID, 0.01, System.OS_Primitives.Relative,
875 Self_ID.Common.State, Ignore, Ignore);
879 -- ??? On multi-processor environments, it seems that the above loop
880 -- isn't sufficient, so we need to add an additional delay.
883 (Self_ID, 0.01, System.OS_Primitives.Relative,
884 Self_ID.Common.State, Ignore, Ignore);
892 -- Complete the environment task
894 Vulnerable_Complete_Task (Self_ID);
896 -- Handle normal task termination by the environment task, but only
897 -- for the normal task termination. In the case of Abnormal and
898 -- Unhandled_Exception they must have been handled before, and the
899 -- task termination soft link must have been changed so the task
900 -- termination routine is not executed twice.
902 SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
904 -- Finalize all library-level controlled objects
906 if not SSL."=" (SSL.Finalize_Library_Objects, null) then
907 SSL.Finalize_Library_Objects.all;
910 -- Reset the soft links to non-tasking
912 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
913 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
914 SSL.Lock_Task := SSL.Task_Lock_NT'Access;
915 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access;
916 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
917 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
918 SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access;
919 SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access;
920 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
921 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
923 -- Don't bother trying to finalize Initialization.Global_Task_Lock
924 -- and System.Task_Primitives.RTS_Lock.
926 end Finalize_Global_Tasks;
928 ----------------------
929 -- Free_Entry_Names --
930 ----------------------
932 procedure Free_Entry_Names (T : Task_Id) is
933 Names : Entry_Names_Array_Access := T.Entry_Names;
935 procedure Free_Entry_Names_Array_Access is new
936 Ada.Unchecked_Deallocation
937 (Entry_Names_Array, Entry_Names_Array_Access);
944 Free_Entry_Names_Array (Names.all);
945 Free_Entry_Names_Array_Access (Names);
946 end Free_Entry_Names;
952 procedure Free_Task (T : Task_Id) is
953 Self_Id : constant Task_Id := Self;
956 if T.Common.State = Terminated then
958 -- It is not safe to call Abort_Defer or Write_Lock at this stage
960 Initialization.Task_Lock (Self_Id);
963 Initialization.Finalize_Attributes_Link.all (T);
964 Initialization.Remove_From_All_Tasks_List (T);
967 Initialization.Task_Unlock (Self_Id);
969 Free_Entry_Names (T);
970 System.Task_Primitives.Operations.Finalize_TCB (T);
973 -- If the task is not terminated, then mark the task as to be freed
976 T.Free_On_Termination := True;
980 ---------------------------
981 -- Move_Activation_Chain --
982 ---------------------------
984 procedure Move_Activation_Chain
985 (From, To : Activation_Chain_Access;
986 New_Master : Master_ID)
988 Self_ID : constant Task_Id := STPO.Self;
993 (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
995 -- Nothing to do if From is empty, and we can check that without
1004 Initialization.Defer_Abort (Self_ID);
1006 -- Loop through the From chain, changing their Master_of_Task fields,
1007 -- and to find the end of the chain.
1010 C.Master_of_Task := New_Master;
1011 exit when C.Common.Activation_Link = null;
1012 C := C.Common.Activation_Link;
1015 -- Hook From in at the start of To
1017 C.Common.Activation_Link := To.all.T_ID;
1018 To.all.T_ID := From.all.T_ID;
1020 -- Set From to empty
1022 From.all.T_ID := null;
1024 Initialization.Undefer_Abort (Self_ID);
1025 end Move_Activation_Chain;
1027 -- Compiler interface only. Do not call from within the RTS
1029 --------------------
1030 -- Set_Entry_Name --
1031 --------------------
1033 procedure Set_Entry_Name
1035 Pos : Task_Entry_Index;
1036 Val : String_Access)
1039 pragma Assert (T.Entry_Names /= null);
1041 T.Entry_Names (Entry_Index (Pos)) := Val;
1048 -- The task wrapper is a procedure that is called first for each task body
1049 -- and which in turn calls the compiler-generated task body procedure.
1050 -- The wrapper's main job is to do initialization for the task. It also
1051 -- has some locally declared objects that serve as per-task local data.
1052 -- Task finalization is done by Complete_Task, which is called from an
1053 -- at-end handler that the compiler generates.
1055 procedure Task_Wrapper (Self_ID : Task_Id) is
1056 use type SSE.Storage_Offset;
1057 use System.Standard_Library;
1058 use System.Stack_Usage;
1060 Bottom_Of_Stack : aliased Integer;
1062 Task_Alternate_Stack :
1063 aliased SSE.Storage_Array (1 .. Alternate_Stack_Size);
1064 -- The alternate signal stack for this task, if any
1066 Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
1067 -- Whether to use above alternate signal stack for stack overflows
1069 Secondary_Stack_Size :
1070 constant SSE.Storage_Offset :=
1071 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
1072 SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100;
1074 Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
1075 -- Actual area allocated for secondary stack
1077 Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
1078 -- Address of secondary stack. In the fixed secondary stack case, this
1079 -- value is not modified, causing a warning, hence the bracketing with
1080 -- Warnings (Off/On). But why is so much *more* bracketed???
1082 SEH_Table : aliased SSE.Storage_Array (1 .. 8);
1083 -- Structured Exception Registration table (2 words)
1085 procedure Install_SEH_Handler (Addr : System.Address);
1086 pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
1087 -- Install the SEH (Structured Exception Handling) handler
1089 Cause : Cause_Of_Termination := Normal;
1090 -- Indicates the reason why this task terminates. Normal corresponds to
1091 -- a task terminating due to completing the last statement of its body,
1092 -- or as a result of waiting on a terminate alternative. If the task
1093 -- terminates because it is being aborted then Cause will be set
1094 -- to Abnormal. If the task terminates because of an exception
1095 -- raised by the execution of its task body, then Cause is set
1096 -- to Unhandled_Exception.
1098 EO : Exception_Occurrence;
1099 -- If the task terminates because of an exception raised by the
1100 -- execution of its task body, then EO will contain the associated
1101 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
1103 TH : Termination_Handler := null;
1104 -- Pointer to the protected procedure to be executed upon task
1107 procedure Search_Fall_Back_Handler (ID : Task_Id);
1108 -- Procedure that searches recursively a fall-back handler through the
1109 -- master relationship. If the handler is found, its pointer is stored
1112 ------------------------------
1113 -- Search_Fall_Back_Handler --
1114 ------------------------------
1116 procedure Search_Fall_Back_Handler (ID : Task_Id) is
1118 -- If there is a fall back handler, store its pointer for later
1121 if ID.Common.Fall_Back_Handler /= null then
1122 TH := ID.Common.Fall_Back_Handler;
1124 -- Otherwise look for a fall back handler in the parent
1126 elsif ID.Common.Parent /= null then
1127 Search_Fall_Back_Handler (ID.Common.Parent);
1129 -- Otherwise, do nothing
1134 end Search_Fall_Back_Handler;
1136 -- Start of processing for Task_Wrapper
1139 pragma Assert (Self_ID.Deferral_Level = 1);
1141 -- Assume a size of the stack taken at this stage
1143 if not Parameters.Sec_Stack_Dynamic then
1144 Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
1145 Secondary_Stack'Address;
1146 SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
1149 if Use_Alternate_Stack then
1150 Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address;
1153 -- Set the guard page at the bottom of the stack. The call to unprotect
1154 -- the page is done in Terminate_Task
1156 Stack_Guard (Self_ID, True);
1158 -- Initialize low-level TCB components, that cannot be initialized by
1159 -- the creator. Enter_Task sets Self_ID.LL.Thread.
1161 Enter_Task (Self_ID);
1163 -- Initialize dynamic stack usage
1165 if System.Stack_Usage.Is_Enabled then
1167 Guard_Page_Size : constant := 16 * 1024;
1168 -- Part of the stack used as a guard page. This is an OS dependent
1169 -- value, so we need to use the maximum. This value is only used
1170 -- when the stack address is known, that is currently Windows.
1172 Small_Overflow_Guard : constant := 12 * 1024;
1173 -- Note: this used to be 4K, but was changed to 12K, since
1174 -- smaller values resulted in segmentation faults from dynamic
1177 Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024;
1178 Small_Stack_Limit : constant := 64 * 1024;
1179 -- ??? These three values are experimental, and seem to work on
1180 -- most platforms. They still need to be analyzed further. They
1181 -- also need documentation, what are they and why does the logic
1182 -- differ depending on whether the stack is large or small???
1184 Pattern_Size : Natural :=
1185 Natural (Self_ID.Common.
1186 Compiler_Data.Pri_Stack_Info.Size);
1187 -- Size of the pattern
1189 Stack_Base : Address;
1190 -- Address of the base of the stack
1193 Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base;
1195 if Stack_Base = Null_Address then
1197 -- On many platforms, we don't know the real stack base
1198 -- address. Estimate it using an address in the frame.
1200 Stack_Base := Bottom_Of_Stack'Address;
1202 -- Also reduce the size of the stack to take into account the
1203 -- secondary stack array declared in this frame. This is for
1204 -- sure very conservative.
1206 if not Parameters.Sec_Stack_Dynamic then
1208 Pattern_Size - Natural (Secondary_Stack_Size);
1211 -- Adjustments for inner frames
1213 Pattern_Size := Pattern_Size -
1214 (if Pattern_Size < Small_Stack_Limit
1215 then Small_Overflow_Guard
1216 else Big_Overflow_Guard);
1218 -- Reduce by the size of the final guard page
1220 Pattern_Size := Pattern_Size - Guard_Page_Size;
1225 (Self_ID.Common.Analyzer,
1226 Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len),
1227 Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size),
1228 SSE.To_Integer (Stack_Base),
1231 Fill_Stack (Self_ID.Common.Analyzer);
1235 -- We setup the SEH (Structured Exception Handling) handler if supported
1238 Install_SEH_Handler (SEH_Table'Address);
1240 -- Initialize exception occurrence
1242 Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
1244 -- We lock RTS_Lock to wait for activator to finish activating the rest
1245 -- of the chain, so that everyone in the chain comes out in priority
1248 -- This also protects the value of
1249 -- Self_ID.Common.Activator.Common.Wait_Count.
1254 if not System.Restrictions.Abort_Allowed then
1256 -- If Abort is not allowed, reset the deferral level since it will
1257 -- not get changed by the generated code. Keeping a default value
1258 -- of one would prevent some operations (e.g. select or delay) to
1259 -- proceed successfully.
1261 Self_ID.Deferral_Level := 0;
1264 if Global_Task_Debug_Event_Set then
1265 Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID);
1269 -- We are separating the following portion of the code in order to
1270 -- place the exception handlers in a different block. In this way,
1271 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
1272 -- set Self in Enter_Task
1274 -- Call the task body procedure
1276 -- The task body is called with abort still deferred. That
1277 -- eliminates a dangerous window, for which we had to patch-up in
1280 -- During the expansion of the task body, we insert an RTS-call
1281 -- to Abort_Undefer, at the first point where abort should be
1284 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
1285 Initialization.Defer_Abort_Nestable (Self_ID);
1288 -- We can't call Terminate_Task in the exception handlers below,
1289 -- since there may be (e.g. in the case of GCC exception handling)
1290 -- clean ups associated with the exception handler that need to
1291 -- access task specific data.
1293 -- Defer abort so that this task can't be aborted while exiting
1295 when Standard'Abort_Signal =>
1296 Initialization.Defer_Abort_Nestable (Self_ID);
1298 -- Update the cause that motivated the task termination so that
1299 -- the appropriate information is passed to the task termination
1300 -- procedure. Task termination as a result of waiting on a
1301 -- terminate alternative is a normal termination, although it is
1302 -- implemented using the abort mechanisms.
1304 if Self_ID.Terminate_Alternative then
1307 if Global_Task_Debug_Event_Set then
1308 Debug.Signal_Debug_Event
1309 (Debug.Debug_Event_Terminated, Self_ID);
1314 if Global_Task_Debug_Event_Set then
1315 Debug.Signal_Debug_Event
1316 (Debug.Debug_Event_Abort_Terminated, Self_ID);
1321 -- ??? Using an E : others here causes CD2C11A to fail on Tru64
1323 Initialization.Defer_Abort_Nestable (Self_ID);
1325 -- Perform the task specific exception tracing duty. We handle
1326 -- these outputs here and not in the common notification routine
1327 -- because we need access to tasking related data and we don't
1328 -- want to drag dependencies against tasking related units in the
1329 -- the common notification units. Additionally, no trace is ever
1330 -- triggered from the common routine for the Unhandled_Raise case
1331 -- in tasks, since an exception never appears unhandled in this
1332 -- context because of this handler.
1334 if Exception_Trace = Unhandled_Raise then
1335 Trace_Unhandled_Exception_In_Task (Self_ID);
1338 -- Update the cause that motivated the task termination so that
1339 -- the appropriate information is passed to the task termination
1340 -- procedure, as well as the associated Exception_Occurrence.
1342 Cause := Unhandled_Exception;
1344 Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
1346 if Global_Task_Debug_Event_Set then
1347 Debug.Signal_Debug_Event
1348 (Debug.Debug_Event_Exception_Terminated, Self_ID);
1352 -- Look for a task termination handler. This code is for all tasks but
1353 -- the environment task. The task termination code for the environment
1354 -- task is executed by SSL.Task_Termination_Handler.
1360 Write_Lock (Self_ID);
1362 if Self_ID.Common.Specific_Handler /= null then
1363 TH := Self_ID.Common.Specific_Handler;
1365 -- Look for a fall-back handler following the master relationship
1368 Search_Fall_Back_Handler (Self_ID);
1377 -- Execute the task termination handler if we found it
1381 TH.all (Cause, Self_ID, EO);
1385 -- RM-C.7.3 requires all exceptions raised here to be ignored
1392 if System.Stack_Usage.Is_Enabled then
1393 Compute_Result (Self_ID.Common.Analyzer);
1394 Report_Result (Self_ID.Common.Analyzer);
1397 Terminate_Task (Self_ID);
1400 --------------------
1401 -- Terminate_Task --
1402 --------------------
1404 -- Before we allow the thread to exit, we must clean up. This is a delicate
1405 -- job. We must wake up the task's master, who may immediately try to
1406 -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING.
1408 -- To avoid this, the parent task must be blocked up to the latest
1409 -- statement executed. The trouble is that we have another step that we
1410 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1411 -- We have to postpone that until the end because compiler-generated code
1412 -- is likely to try to access that data at just about any point.
1414 -- We can't call Destroy_TSD while we are holding any other locks, because
1415 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1416 -- that to be the outermost lock. Our first "solution" was to just lock
1417 -- Global_Task_Lock in addition to the other locks, and force the parent to
1418 -- also lock this lock between its wakeup and its freeing of the ATCB. See
1419 -- Complete_Task for the parent-side of the code that has the matching
1420 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1421 -- since the operation Task_Unlock continued to access the ATCB after
1422 -- unlocking, after which the parent was observed to race ahead, deallocate
1423 -- the ATCB, and then reallocate it to another task. The call to
1424 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
1425 -- the data of the new task that reused the ATCB! To solve this problem, we
1426 -- introduced the new operation Final_Task_Unlock.
1428 procedure Terminate_Task (Self_ID : Task_Id) is
1429 Environment_Task : constant Task_Id := STPO.Environment_Task;
1430 Master_of_Task : Integer;
1431 Deallocate : Boolean;
1434 Debug.Task_Termination_Hook;
1436 if Runtime_Traces then
1437 Send_Trace_Info (T_Terminate);
1440 -- Since GCC cannot allocate stack chunks efficiently without reordering
1441 -- some of the allocations, we have to handle this unexpected situation
1442 -- here. Normally we never have to call Vulnerable_Complete_Task here.
1444 if Self_ID.Common.Activator /= null then
1445 Vulnerable_Complete_Task (Self_ID);
1448 Initialization.Task_Lock (Self_ID);
1454 Master_of_Task := Self_ID.Master_of_Task;
1456 -- Check if the current task is an independent task If so, decrement
1457 -- the Independent_Task_Count value.
1459 if Master_of_Task = Independent_Task_Level then
1461 Utilities.Independent_Task_Count :=
1462 Utilities.Independent_Task_Count - 1;
1465 Write_Lock (Environment_Task);
1466 Utilities.Independent_Task_Count :=
1467 Utilities.Independent_Task_Count - 1;
1468 Unlock (Environment_Task);
1472 -- Unprotect the guard page if needed
1474 Stack_Guard (Self_ID, False);
1476 Utilities.Make_Passive (Self_ID, Task_Completed => True);
1477 Deallocate := Self_ID.Free_On_Termination;
1483 pragma Assert (Check_Exit (Self_ID));
1485 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
1486 Initialization.Final_Task_Unlock (Self_ID);
1488 -- WARNING: past this point, this thread must assume that the ATCB has
1489 -- been deallocated, and can't access it anymore (which is why we have
1490 -- saved the Free_On_Termination flag in a temporary variable).
1493 Free_Task (Self_ID);
1496 if Master_of_Task > 0 then
1505 function Terminated (T : Task_Id) return Boolean is
1506 Self_ID : constant Task_Id := STPO.Self;
1510 Initialization.Defer_Abort_Nestable (Self_ID);
1517 Result := T.Common.State = Terminated;
1524 Initialization.Undefer_Abort_Nestable (Self_ID);
1528 ----------------------------------------
1529 -- Trace_Unhandled_Exception_In_Task --
1530 ----------------------------------------
1532 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
1533 procedure To_Stderr (S : String);
1534 pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
1536 use System.Soft_Links;
1537 use System.Standard_Library;
1539 function To_Address is new
1540 Ada.Unchecked_Conversion
1541 (Task_Id, System.Task_Primitives.Task_Address);
1543 function Tailored_Exception_Information
1544 (E : Exception_Occurrence) return String;
1546 (Ada, Tailored_Exception_Information,
1547 "__gnat_tailored_exception_information");
1549 Excep : constant Exception_Occurrence_Access :=
1550 SSL.Get_Current_Excep.all;
1553 -- This procedure is called by the task outermost handler in
1554 -- Task_Wrapper below, so only once the task stack has been fully
1555 -- unwound. The common notification routine has been called at the
1556 -- raise point already.
1558 -- Lock to prevent unsynchronized output
1560 Initialization.Task_Lock (Self_Id);
1561 To_Stderr ("task ");
1563 if Self_Id.Common.Task_Image_Len /= 0 then
1565 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
1569 To_Stderr (System.Address_Image (To_Address (Self_Id)));
1570 To_Stderr (" terminated by unhandled exception");
1571 To_Stderr ((1 => ASCII.LF));
1572 To_Stderr (Tailored_Exception_Information (Excep.all));
1573 Initialization.Task_Unlock (Self_Id);
1574 end Trace_Unhandled_Exception_In_Task;
1576 ------------------------------------
1577 -- Vulnerable_Complete_Activation --
1578 ------------------------------------
1580 -- As in several other places, the locks of the activator and activated
1581 -- task are both locked here. This follows our deadlock prevention lock
1582 -- ordering policy, since the activated task must be created after the
1585 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
1586 Activator : constant Task_Id := Self_ID.Common.Activator;
1589 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
1591 Write_Lock (Activator);
1592 Write_Lock (Self_ID);
1594 pragma Assert (Self_ID.Common.Activator /= null);
1596 -- Remove dangling reference to Activator, since a task may outlive its
1599 Self_ID.Common.Activator := null;
1601 -- Wake up the activator, if it is waiting for a chain of tasks to
1602 -- activate, and we are the last in the chain to complete activation.
1604 if Activator.Common.State = Activator_Sleep then
1605 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
1607 if Activator.Common.Wait_Count = 0 then
1608 Wakeup (Activator, Activator_Sleep);
1612 -- The activator raises a Tasking_Error if any task it is activating
1613 -- is completed before the activation is done. However, if the reason
1614 -- for the task completion is an abort, we do not raise an exception.
1617 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
1618 Activator.Common.Activation_Failed := True;
1624 -- After the activation, active priority should be the same as base
1625 -- priority. We must unlock the Activator first, though, since it
1626 -- should not wait if we have lower priority.
1628 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
1629 Write_Lock (Self_ID);
1630 Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1633 end Vulnerable_Complete_Activation;
1635 --------------------------------
1636 -- Vulnerable_Complete_Master --
1637 --------------------------------
1639 procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
1642 CM : constant Master_Level := Self_ID.Master_Within;
1643 T : aliased Task_Id;
1645 To_Be_Freed : Task_Id;
1646 -- This is a list of ATCBs to be freed, after we have released all RTS
1647 -- locks. This is necessary because of the locking order rules, since
1648 -- the storage manager uses Global_Task_Lock.
1650 pragma Warnings (Off);
1651 function Check_Unactivated_Tasks return Boolean;
1652 pragma Warnings (On);
1653 -- Temporary error-checking code below. This is part of the checks
1654 -- added in the new run time. Call it only inside a pragma Assert.
1656 -----------------------------
1657 -- Check_Unactivated_Tasks --
1658 -----------------------------
1660 function Check_Unactivated_Tasks return Boolean is
1662 if not Single_Lock then
1666 Write_Lock (Self_ID);
1668 C := All_Tasks_List;
1669 while C /= null loop
1670 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
1674 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1677 if C.Common.State = Unactivated then
1684 C := C.Common.All_Tasks_Link;
1689 if not Single_Lock then
1694 end Check_Unactivated_Tasks;
1696 -- Start of processing for Vulnerable_Complete_Master
1700 (Debug.Trace (Self_ID, "V_Complete_Master", 'C'));
1702 pragma Assert (Self_ID.Common.Wait_Count = 0);
1704 (Self_ID.Deferral_Level > 0
1705 or else not System.Restrictions.Abort_Allowed);
1707 -- Count how many active dependent tasks this master currently has, and
1708 -- record this in Wait_Count.
1710 -- This count should start at zero, since it is initialized to zero for
1711 -- new tasks, and the task should not exit the sleep-loops that use this
1712 -- count until the count reaches zero.
1714 -- While we're counting, if we run across any unactivated tasks that
1715 -- belong to this master, we summarily terminate them as required by
1719 Write_Lock (Self_ID);
1721 C := All_Tasks_List;
1722 while C /= null loop
1724 -- Terminate unactivated (never-to-be activated) tasks
1726 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
1728 -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
1729 -- = CM. The only case where C is pending activation by this
1730 -- task, but the master of C is not CM is in Ada 2005, when C is
1731 -- part of a return object of a build-in-place function.
1733 pragma Assert (C.Common.State = Unactivated);
1736 C.Common.Activator := null;
1737 C.Common.State := Terminated;
1738 C.Callable := False;
1739 Utilities.Cancel_Queued_Entry_Calls (C);
1743 -- Count it if dependent on this master
1745 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1748 if C.Awake_Count /= 0 then
1749 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1755 C := C.Common.All_Tasks_Link;
1758 Self_ID.Common.State := Master_Completion_Sleep;
1761 if not Single_Lock then
1765 -- Wait until dependent tasks are all terminated or ready to terminate.
1766 -- While waiting, the task may be awakened if the task's priority needs
1767 -- changing, or this master is aborted. In the latter case, we abort the
1768 -- dependents, and resume waiting until Wait_Count goes to zero.
1770 Write_Lock (Self_ID);
1773 exit when Self_ID.Common.Wait_Count = 0;
1775 -- Here is a difference as compared to Complete_Master
1777 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1778 and then not Self_ID.Dependents_Aborted
1781 Abort_Dependents (Self_ID);
1785 Abort_Dependents (Self_ID);
1787 Write_Lock (Self_ID);
1790 Sleep (Self_ID, Master_Completion_Sleep);
1794 Self_ID.Common.State := Runnable;
1797 -- Dependents are all terminated or on terminate alternatives. Now,
1798 -- force those on terminate alternatives to terminate, by aborting them.
1800 pragma Assert (Check_Unactivated_Tasks);
1802 if Self_ID.Alive_Count > 1 then
1804 -- Consider finding a way to skip the following extra steps if there
1805 -- are no dependents with terminate alternatives. This could be done
1806 -- by adding another count to the ATCB, similar to Awake_Count, but
1807 -- keeping track of tasks that are on terminate alternatives.
1809 pragma Assert (Self_ID.Common.Wait_Count = 0);
1811 -- Force any remaining dependents to terminate by aborting them
1813 if not Single_Lock then
1817 Abort_Dependents (Self_ID);
1819 -- Above, when we "abort" the dependents we are simply using this
1820 -- operation for convenience. We are not required to support the full
1821 -- abort-statement semantics; in particular, we are not required to
1822 -- immediately cancel any queued or in-service entry calls. That is
1823 -- good, because if we tried to cancel a call we would need to lock
1824 -- the caller, in order to wake the caller up. Our anti-deadlock
1825 -- rules prevent us from doing that without releasing the locks on C
1826 -- and Self_ID. Releasing and retaking those locks would be wasteful
1827 -- at best, and should not be considered further without more
1828 -- detailed analysis of potential concurrent accesses to the ATCBs
1829 -- of C and Self_ID.
1831 -- Count how many "alive" dependent tasks this master currently has,
1832 -- and record this in Wait_Count. This count should start at zero,
1833 -- since it is initialized to zero for new tasks, and the task should
1834 -- not exit the sleep-loops that use this count until the count
1837 pragma Assert (Self_ID.Common.Wait_Count = 0);
1839 Write_Lock (Self_ID);
1841 C := All_Tasks_List;
1842 while C /= null loop
1843 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1846 pragma Assert (C.Awake_Count = 0);
1848 if C.Alive_Count > 0 then
1849 pragma Assert (C.Terminate_Alternative);
1850 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1856 C := C.Common.All_Tasks_Link;
1859 Self_ID.Common.State := Master_Phase_2_Sleep;
1862 if not Single_Lock then
1866 -- Wait for all counted tasks to finish terminating themselves
1868 Write_Lock (Self_ID);
1871 exit when Self_ID.Common.Wait_Count = 0;
1872 Sleep (Self_ID, Master_Phase_2_Sleep);
1875 Self_ID.Common.State := Runnable;
1879 -- We don't wake up for abort here. We are already terminating just as
1880 -- fast as we can, so there is no point.
1882 -- Remove terminated tasks from the list of Self_ID's dependents, but
1883 -- don't free their ATCBs yet, because of lock order restrictions, which
1884 -- don't allow us to call "free" or "malloc" while holding any other
1885 -- locks. Instead, we put those ATCBs to be freed onto a temporary list,
1886 -- called To_Be_Freed.
1888 if not Single_Lock then
1892 C := All_Tasks_List;
1894 while C /= null loop
1895 if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then
1897 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
1899 All_Tasks_List := C.Common.All_Tasks_Link;
1902 T := C.Common.All_Tasks_Link;
1903 C.Common.All_Tasks_Link := To_Be_Freed;
1909 C := C.Common.All_Tasks_Link;
1915 -- Free all the ATCBs on the list To_Be_Freed
1917 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1918 -- any interrupt entries are detached from them they should no longer
1921 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1922 -- avoid a race between a terminating task and its parent. The parent
1923 -- might try to deallocate the ACTB out from underneath the exiting
1924 -- task. Note that Free will also lock Global_Task_Lock, but that is
1925 -- OK, since this is the *one* lock for which we have a mechanism to
1926 -- support nested locking. See Task_Wrapper and its finalizer for more
1930 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1931 -- references to terminated library-level tasks, which could otherwise
1932 -- occur during finalization of library-level objects. A better solution
1933 -- might be to hook task objects into the finalization chain and
1934 -- deallocate the ATCB when the task object is deallocated. However,
1935 -- this change is not likely to gain anything significant, since all
1936 -- this storage should be recovered en-masse when the process exits.
1938 while To_Be_Freed /= null loop
1940 To_Be_Freed := T.Common.All_Tasks_Link;
1942 -- ??? On SGI there is currently no Interrupt_Manager, that's why we
1943 -- need to check if the Interrupt_Manager_ID is null.
1945 if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then
1947 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
1948 -- Corresponds to the entry index of System.Interrupts.
1949 -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure
1950 -- to update this value when changing Interrupt_Manager specs.
1952 type Param_Type is access all Task_Id;
1954 Param : aliased Param_Type := T'Access;
1957 System.Tasking.Rendezvous.Call_Simple
1958 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
1963 if (T.Common.Parent /= null
1964 and then T.Common.Parent.Common.Parent /= null)
1965 or else T.Master_of_Task > Library_Task_Level
1967 Initialization.Task_Lock (Self_ID);
1969 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1970 -- has not been called yet (case of an unactivated task).
1972 if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then
1973 SSL.Destroy_TSD (T.Common.Compiler_Data);
1976 Vulnerable_Free_Task (T);
1977 Initialization.Task_Unlock (Self_ID);
1981 -- It might seem nice to let the terminated task deallocate its own
1982 -- ATCB. That would not cover the case of unactivated tasks. It also
1983 -- would force us to keep the underlying thread around past termination,
1984 -- since references to the ATCB are possible past termination.
1986 -- Currently, we get rid of the thread as soon as the task terminates,
1987 -- and let the parent recover the ATCB later.
1989 -- Some day, if we want to recover the ATCB earlier, at task
1990 -- termination, we could consider using "fat task IDs", that include the
1991 -- serial number with the ATCB pointer, to catch references to tasks
1992 -- that no longer have ATCBs. It is not clear how much this would gain,
1993 -- since the user-level task object would still be occupying storage.
1995 -- Make next master level up active. We don't need to lock the ATCB,
1996 -- since the value is only updated by each task for itself.
1998 Self_ID.Master_Within := CM - 1;
1999 end Vulnerable_Complete_Master;
2001 ------------------------------
2002 -- Vulnerable_Complete_Task --
2003 ------------------------------
2005 -- Complete the calling task
2007 -- This procedure must be called with abort deferred. It should only be
2008 -- called by Complete_Task and Finalize_Global_Tasks (for the environment
2011 -- The effect is similar to that of Complete_Master. Differences include
2012 -- the closing of entries here, and computation of the number of active
2013 -- dependent tasks in Complete_Master.
2015 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
2016 -- because that does its own locking, and because we do not need the lock
2017 -- to test Self_ID.Common.Activator. That value should only be read and
2018 -- modified by Self.
2020 procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
2023 (Self_ID.Deferral_Level > 0
2024 or else not System.Restrictions.Abort_Allowed);
2025 pragma Assert (Self_ID = Self);
2026 pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1
2028 Self_ID.Master_Within = Self_ID.Master_of_Task + 2);
2029 pragma Assert (Self_ID.Common.Wait_Count = 0);
2030 pragma Assert (Self_ID.Open_Accepts = null);
2031 pragma Assert (Self_ID.ATC_Nesting_Level = 1);
2033 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
2039 Write_Lock (Self_ID);
2040 Self_ID.Callable := False;
2042 -- In theory, Self should have no pending entry calls left on its
2043 -- call-stack. Each async. select statement should clean its own call,
2044 -- and blocking entry calls should defer abort until the calls are
2045 -- cancelled, then clean up.
2047 Utilities.Cancel_Queued_Entry_Calls (Self_ID);
2050 if Self_ID.Common.Activator /= null then
2051 Vulnerable_Complete_Activation (Self_ID);
2058 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have
2059 -- dependent tasks for which we need to wait. Otherwise we just exit.
2061 if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
2062 Vulnerable_Complete_Master (Self_ID);
2064 end Vulnerable_Complete_Task;
2066 --------------------------
2067 -- Vulnerable_Free_Task --
2068 --------------------------
2070 -- Recover all runtime system storage associated with the task T. This
2071 -- should only be called after T has terminated and will no longer be
2074 -- For tasks created by an allocator that fails, due to an exception, it
2075 -- is called from Expunge_Unactivated_Tasks.
2077 -- For tasks created by elaboration of task object declarations it is
2078 -- called from the finalization code of the Task_Wrapper procedure. It is
2079 -- also called from Ada.Unchecked_Deallocation, for objects that are or
2082 procedure Vulnerable_Free_Task (T : Task_Id) is
2084 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
2091 Initialization.Finalize_Attributes_Link.all (T);
2098 Free_Entry_Names (T);
2099 System.Task_Primitives.Operations.Finalize_TCB (T);
2100 end Vulnerable_Free_Task;
2102 -- Package elaboration code
2105 -- Establish the Adafinal softlink
2107 -- This is not done inside the central RTS initialization routine
2108 -- to avoid with'ing this package from System.Tasking.Initialization.
2110 SSL.Adafinal := Finalize_Global_Tasks'Access;
2112 -- Establish soft links for subprograms that manipulate master_id's.
2113 -- This cannot be done when the RTS is initialized, because of various
2114 -- elaboration constraints.
2116 SSL.Current_Master := Stages.Current_Master'Access;
2117 SSL.Enter_Master := Stages.Enter_Master'Access;
2118 SSL.Complete_Master := Stages.Complete_Master'Access;
2119 end System.Tasking.Stages;