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-2016, 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.
36 pragma Partition_Elaboration_Policy
(Concurrent
);
37 -- This package only implements the concurrent elaboration policy. This pragma
38 -- will enforce it (and detect conflicts with user specified policy).
41 with Ada
.Unchecked_Deallocation
;
43 with System
.Interrupt_Management
;
44 with System
.Tasking
.Debug
;
45 with System
.Address_Image
;
46 with System
.Task_Primitives
;
47 with System
.Task_Primitives
.Operations
;
48 with System
.Tasking
.Utilities
;
49 with System
.Tasking
.Queuing
;
50 with System
.Tasking
.Rendezvous
;
51 with System
.OS_Primitives
;
52 with System
.Secondary_Stack
;
53 with System
.Restrictions
;
54 with System
.Standard_Library
;
55 with System
.Traces
.Tasking
;
56 with System
.Stack_Usage
;
57 with System
.Storage_Elements
;
59 with System
.Soft_Links
;
60 -- These are procedure pointers to non-tasking routines that use task
61 -- specific data. In the absence of tasking, these routines refer to global
62 -- data. In the presence of tasking, they must be replaced with pointers to
63 -- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current
64 -- _Excep, Finalize_Library_Objects, Task_Termination, Handler.
66 with System
.Tasking
.Initialization
;
67 pragma Elaborate_All
(System
.Tasking
.Initialization
);
68 -- This insures that tasking is initialized if any tasks are created
70 package body System
.Tasking
.Stages
is
72 package STPO
renames System
.Task_Primitives
.Operations
;
73 package SSL
renames System
.Soft_Links
;
74 package SSE
renames System
.Storage_Elements
;
75 package SST
renames System
.Secondary_Stack
;
81 use Task_Primitives
.Operations
;
85 use System
.Traces
.Tasking
;
87 -----------------------
88 -- Local Subprograms --
89 -----------------------
92 Ada
.Unchecked_Deallocation
(Ada_Task_Control_Block
, Task_Id
);
94 procedure Trace_Unhandled_Exception_In_Task
(Self_Id
: Task_Id
);
95 -- This procedure outputs the task specific message for exception
98 procedure Task_Wrapper
(Self_ID
: Task_Id
);
99 pragma Convention
(C
, Task_Wrapper
);
100 -- This is the procedure that is called by the GNULL from the new context
101 -- when a task is created. It waits for activation and then calls the task
102 -- body procedure. When the task body procedure completes, it terminates
105 -- The Task_Wrapper's address will be provided to the underlying threads
106 -- library as the task entry point. Convention C is what makes most sense
107 -- for that purpose (Export C would make the function globally visible,
108 -- and affect the link name on which GDB depends). This will in addition
109 -- trigger an automatic stack alignment suitable for GCC's assumptions if
112 -- "Vulnerable_..." in the procedure names below means they must be called
113 -- with abort deferred.
115 procedure Vulnerable_Complete_Task
(Self_ID
: Task_Id
);
116 -- Complete the calling task. This procedure must be called with
117 -- abort deferred. It should only be called by Complete_Task and
118 -- Finalize_Global_Tasks (for the environment task).
120 procedure Vulnerable_Complete_Master
(Self_ID
: Task_Id
);
121 -- Complete the current master of the calling task. This procedure
122 -- must be called with abort deferred. It should only be called by
123 -- Vulnerable_Complete_Task and Complete_Master.
125 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_Id
);
126 -- Signal to Self_ID's activator that Self_ID has completed activation.
127 -- This procedure must be called with abort deferred.
129 procedure Abort_Dependents
(Self_ID
: Task_Id
);
130 -- Abort all the direct dependents of Self at its current master nesting
131 -- level, plus all of their dependents, transitively. RTS_Lock should be
132 -- locked by the caller.
134 procedure Vulnerable_Free_Task
(T
: Task_Id
);
135 -- Recover all runtime system storage associated with the task T. This
136 -- should only be called after T has terminated and will no longer be
139 -- For tasks created by an allocator that fails, due to an exception, it is
140 -- called from Expunge_Unactivated_Tasks.
142 -- Different code is used at master completion, in Terminate_Dependents,
143 -- due to a need for tighter synchronization with the master.
145 ----------------------
146 -- Abort_Dependents --
147 ----------------------
149 procedure Abort_Dependents
(Self_ID
: Task_Id
) is
153 -- Each task C will take care of its own dependents, so there is no
154 -- need to worry about them here. In fact, it would be wrong to abort
155 -- indirect dependents here, because we can't distinguish between
156 -- duplicate master ids. For example, suppose we have three nested
157 -- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and
158 -- both P and Q are task masters). Q will have the same master id as
159 -- Master_of_Task of T3. Previous versions of this would abort T3 when
160 -- Q calls Complete_Master, which was completely wrong.
165 P
:= C
.Common
.Parent
;
168 if C
.Master_of_Task
= Self_ID
.Master_Within
then
170 (Debug
.Trace
(Self_ID
, "Aborting", 'X', C
));
171 Utilities
.Abort_One_Task
(Self_ID
, C
);
172 C
.Dependents_Aborted
:= True;
176 C
:= C
.Common
.All_Tasks_Link
;
179 Self_ID
.Dependents_Aborted
:= True;
180 end Abort_Dependents
;
186 procedure Abort_Tasks
(Tasks
: Task_List
) is
188 Utilities
.Abort_Tasks
(Tasks
);
195 -- Note that locks of activator and activated task are both locked here.
196 -- This is necessary because C.Common.State and Self.Common.Wait_Count have
197 -- to be synchronized. This is safe from deadlock because the activator is
198 -- always created before the activated task. That satisfies our
199 -- in-order-of-creation ATCB locking policy.
201 -- At one point, we may also lock the parent, if the parent is different
202 -- from the activator. That is also consistent with the lock ordering
203 -- policy, since the activator cannot be created before the parent.
205 -- Since we are holding both the activator's lock, and Task_Wrapper locks
206 -- that before it does anything more than initialize the low-level ATCB
207 -- components, it should be safe to wait to update the counts until we see
208 -- that the thread creation is successful.
210 -- If the thread creation fails, we do need to close the entries of the
211 -- task. The first phase, of dequeuing calls, only requires locking the
212 -- acceptor's ATCB, but the waking up of the callers requires locking the
213 -- caller's ATCB. We cannot safely do this while we are holding other
214 -- locks. Therefore, the queue-clearing operation is done in a separate
215 -- pass over the activation chain.
217 procedure Activate_Tasks
(Chain_Access
: Activation_Chain_Access
) is
218 Self_ID
: constant Task_Id
:= STPO
.Self
;
221 Next_C
, Last_C
: Task_Id
;
222 Activate_Prio
: System
.Any_Priority
;
224 All_Elaborated
: Boolean := True;
227 -- If pragma Detect_Blocking is active, then we must check whether this
228 -- potentially blocking operation is called from a protected action.
230 if System
.Tasking
.Detect_Blocking
231 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
233 raise Program_Error
with "potentially blocking operation";
237 (Debug
.Trace
(Self_ID
, "Activate_Tasks", 'C'));
239 Initialization
.Defer_Abort_Nestable
(Self_ID
);
241 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
243 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before
244 -- we finish activating the chain.
248 -- Check that all task bodies have been elaborated
250 C
:= Chain_Access
.T_ID
;
253 if C
.Common
.Elaborated
/= null
254 and then not C
.Common
.Elaborated
.all
256 All_Elaborated
:= False;
259 -- Reverse the activation chain so that tasks are activated in the
260 -- same order they're declared.
262 Next_C
:= C
.Common
.Activation_Link
;
263 C
.Common
.Activation_Link
:= Last_C
;
268 Chain_Access
.T_ID
:= Last_C
;
270 if not All_Elaborated
then
272 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
273 raise Program_Error
with "Some tasks have not been elaborated";
276 -- Activate all the tasks in the chain. Creation of the thread of
277 -- control was deferred until activation. So create it now.
279 C
:= Chain_Access
.T_ID
;
281 if C
.Common
.State
/= Terminated
then
282 pragma Assert
(C
.Common
.State
= Unactivated
);
284 P
:= C
.Common
.Parent
;
289 (if C
.Common
.Base_Priority
< Get_Priority
(Self_ID
)
290 then Get_Priority
(Self_ID
)
291 else C
.Common
.Base_Priority
);
293 System
.Task_Primitives
.Operations
.Create_Task
294 (C
, Task_Wrapper
'Address,
296 (C
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
297 Activate_Prio
, Success
);
299 -- There would be a race between the created task and the creator
300 -- to do the following initialization, if we did not have a
301 -- Lock/Unlock_RTS pair in the task wrapper to prevent it from
305 C
.Common
.State
:= Activating
;
308 P
.Awake_Count
:= P
.Awake_Count
+ 1;
309 P
.Alive_Count
:= P
.Alive_Count
+ 1;
311 if P
.Common
.State
= Master_Completion_Sleep
and then
312 C
.Master_of_Task
= P
.Master_Within
314 pragma Assert
(Self_ID
/= P
);
315 P
.Common
.Wait_Count
:= P
.Common
.Wait_Count
+ 1;
318 for J
in System
.Tasking
.Debug
.Known_Tasks
'Range loop
319 if System
.Tasking
.Debug
.Known_Tasks
(J
) = null then
320 System
.Tasking
.Debug
.Known_Tasks
(J
) := C
;
321 C
.Known_Tasks_Index
:= J
;
326 if Global_Task_Debug_Event_Set
then
327 Debug
.Signal_Debug_Event
328 (Debug
.Debug_Event_Activating
, C
);
331 C
.Common
.State
:= Runnable
;
337 -- No need to set Awake_Count, State, etc. here since the loop
338 -- below will do that for any Unactivated tasks.
342 Self_ID
.Common
.Activation_Failed
:= True;
346 C
:= C
.Common
.Activation_Link
;
349 if not Single_Lock
then
353 -- Close the entries of any tasks that failed thread creation, and count
354 -- those that have not finished activation.
356 Write_Lock
(Self_ID
);
357 Self_ID
.Common
.State
:= Activator_Sleep
;
359 C
:= Chain_Access
.T_ID
;
363 if C
.Common
.State
= Unactivated
then
364 C
.Common
.Activator
:= null;
365 C
.Common
.State
:= Terminated
;
367 Utilities
.Cancel_Queued_Entry_Calls
(C
);
369 elsif C
.Common
.Activator
/= null then
370 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
374 P
:= C
.Common
.Activation_Link
;
375 C
.Common
.Activation_Link
:= null;
379 -- Wait for the activated tasks to complete activation. It is
380 -- unsafe to abort any of these tasks until the count goes to zero.
383 exit when Self_ID
.Common
.Wait_Count
= 0;
384 Sleep
(Self_ID
, Activator_Sleep
);
387 Self_ID
.Common
.State
:= Runnable
;
394 -- Remove the tasks from the chain
396 Chain_Access
.T_ID
:= null;
397 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
399 if Self_ID
.Common
.Activation_Failed
then
400 Self_ID
.Common
.Activation_Failed
:= False;
401 raise Tasking_Error
with "Failure during activation";
405 -------------------------
406 -- Complete_Activation --
407 -------------------------
409 procedure Complete_Activation
is
410 Self_ID
: constant Task_Id
:= STPO
.Self
;
413 Initialization
.Defer_Abort_Nestable
(Self_ID
);
419 Vulnerable_Complete_Activation
(Self_ID
);
425 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
427 -- ??? Why do we need to allow for nested deferral here?
429 if Runtime_Traces
then
430 Send_Trace_Info
(T_Activate
);
432 end Complete_Activation
;
434 ---------------------
435 -- Complete_Master --
436 ---------------------
438 procedure Complete_Master
is
439 Self_ID
: constant Task_Id
:= STPO
.Self
;
442 (Self_ID
.Deferral_Level
> 0
443 or else not System
.Restrictions
.Abort_Allowed
);
444 Vulnerable_Complete_Master
(Self_ID
);
451 -- See comments on Vulnerable_Complete_Task for details
453 procedure Complete_Task
is
454 Self_ID
: constant Task_Id
:= STPO
.Self
;
458 (Self_ID
.Deferral_Level
> 0
459 or else not System
.Restrictions
.Abort_Allowed
);
461 Vulnerable_Complete_Task
(Self_ID
);
463 -- All of our dependents have terminated, never undefer abort again
471 -- Compiler interface only. Do not call from within the RTS. This must be
472 -- called to create a new task.
474 procedure Create_Task
476 Size
: System
.Parameters
.Size_Type
;
477 Secondary_Stack_Size
: System
.Parameters
.Size_Type
;
478 Task_Info
: System
.Task_Info
.Task_Info_Type
;
480 Relative_Deadline
: Ada
.Real_Time
.Time_Span
;
481 Domain
: Dispatching_Domain_Access
;
482 Num_Entries
: Task_Entry_Index
;
483 Master
: Master_Level
;
484 State
: Task_Procedure_Access
;
485 Discriminants
: System
.Address
;
486 Elaborated
: Access_Boolean
;
487 Chain
: in out Activation_Chain
;
489 Created_Task
: out Task_Id
)
492 Self_ID
: constant Task_Id
:= STPO
.Self
;
494 Base_Priority
: System
.Any_Priority
;
496 Base_CPU
: System
.Multiprocessors
.CPU_Range
;
498 use type System
.Multiprocessors
.CPU_Range
;
500 pragma Unreferenced
(Relative_Deadline
);
501 -- EDF scheduling is not supported by any of the target platforms so
502 -- this parameter is not passed any further.
505 -- If Master is greater than the current master, it means that Master
506 -- has already awaited its dependent tasks. This raises Program_Error,
507 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
509 if Self_ID
.Master_of_Task
/= Foreign_Task_Level
510 and then Master
> Self_ID
.Master_Within
512 raise Program_Error
with
513 "create task after awaiting termination";
516 -- If pragma Detect_Blocking is active must be checked whether this
517 -- potentially blocking operation is called from a protected action.
519 if System
.Tasking
.Detect_Blocking
520 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
522 raise Program_Error
with "potentially blocking operation";
525 pragma Debug
(Debug
.Trace
(Self_ID
, "Create_Task", 'C'));
528 (if Priority
= Unspecified_Priority
529 then Self_ID
.Common
.Base_Priority
530 else System
.Any_Priority
(Priority
));
532 -- Legal values of CPU are the special Unspecified_CPU value which is
533 -- inserted by the compiler for tasks without CPU aspect, and those in
534 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
535 -- the task is defined to have failed, and it becomes a completed task
538 if CPU
/= Unspecified_CPU
539 and then (CPU
< Integer (System
.Multiprocessors
.CPU_Range
'First)
541 CPU
> Integer (System
.Multiprocessors
.Number_Of_CPUs
))
543 raise Tasking_Error
with "CPU not in range";
545 -- Normal CPU affinity
548 -- When the application code says nothing about the task affinity
549 -- (task without CPU aspect) then the compiler inserts the value
550 -- Unspecified_CPU which indicates to the run-time library that
551 -- the task will activate and execute on the same processor as its
552 -- activating task if the activating task is assigned a processor
556 (if CPU
= Unspecified_CPU
557 then Self_ID
.Common
.Base_CPU
558 else System
.Multiprocessors
.CPU_Range
(CPU
));
561 -- Find parent P of new Task, via master level number. Independent
562 -- tasks should have Parent = Environment_Task, and all tasks created
563 -- by independent tasks are also independent. See, for example,
564 -- s-interr.adb, where Interrupt_Manager does "new Server_Task". The
565 -- access type is at library level, so the parent of the Server_Task
566 -- is Environment_Task.
570 if P
.Master_of_Task
<= Independent_Task_Level
then
571 P
:= Environment_Task
;
573 while P
/= null and then P
.Master_of_Task
>= Master
loop
574 P
:= P
.Common
.Parent
;
578 Initialization
.Defer_Abort_Nestable
(Self_ID
);
581 T
:= New_ATCB
(Num_Entries
);
584 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
585 raise Storage_Error
with "Cannot allocate task";
588 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this
589 -- point, it is possible that we may be part of a family of tasks that
593 Write_Lock
(Self_ID
);
595 -- Now, we must check that we have not been aborted. If so, we should
596 -- give up on creating this task, and simply return.
598 if not Self_ID
.Callable
then
599 pragma Assert
(Self_ID
.Pending_ATC_Level
= 0);
600 pragma Assert
(Self_ID
.Pending_Action
);
602 (Chain
.T_ID
= null or else Chain
.T_ID
.Common
.State
= Unactivated
);
606 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
608 -- ??? Should never get here
610 pragma Assert
(False);
611 raise Standard
'Abort_Signal;
614 Initialize_ATCB
(Self_ID
, State
, Discriminants
, P
, Elaborated
,
615 Base_Priority
, Base_CPU
, Domain
, Task_Info
, Size
,
616 Secondary_Stack_Size
, T
, Success
);
622 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
623 raise Storage_Error
with "Failed to initialize task";
626 if Master
= Foreign_Task_Level
+ 2 then
628 -- This should not happen, except when a foreign task creates non
629 -- library-level Ada tasks. In this case, we pretend the master is
630 -- a regular library level task, otherwise the run-time will get
631 -- confused when waiting for these tasks to terminate.
633 T
.Master_of_Task
:= Library_Task_Level
;
636 T
.Master_of_Task
:= Master
;
639 T
.Master_Within
:= T
.Master_of_Task
+ 1;
641 for L
in T
.Entry_Calls
'Range loop
642 T
.Entry_Calls
(L
).Self
:= T
;
643 T
.Entry_Calls
(L
).Level
:= L
;
646 if Task_Image
'Length = 0 then
647 T
.Common
.Task_Image_Len
:= 0;
650 T
.Common
.Task_Image
(1) := Task_Image
(Task_Image
'First);
652 -- Remove unwanted blank space generated by 'Image
654 for J
in Task_Image
'First + 1 .. Task_Image
'Last loop
655 if Task_Image
(J
) /= ' '
656 or else Task_Image
(J
- 1) /= '('
659 T
.Common
.Task_Image
(Len
) := Task_Image
(J
);
660 exit when Len
= T
.Common
.Task_Image
'Last;
664 T
.Common
.Task_Image_Len
:= Len
;
667 -- Note: we used to have code here to initialize T.Commmon.Domain, but
668 -- that is not needed, since this is initialized in System.Tasking.
673 -- The CPU associated to the task (if any) must belong to the
674 -- dispatching domain.
676 if Base_CPU
/= System
.Multiprocessors
.Not_A_Specific_CPU
678 (Base_CPU
not in T
.Common
.Domain
'Range
679 or else not T
.Common
.Domain
(Base_CPU
))
681 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
682 raise Tasking_Error
with "CPU not in dispatching domain";
685 -- To handle the interaction between pragma CPU and dispatching domains
686 -- we need to signal that this task is being allocated to a processor.
687 -- This is needed only for tasks belonging to the system domain (the
688 -- creation of new dispatching domains can only take processors from the
689 -- system domain) and only before the environment task calls the main
690 -- procedure (dispatching domains cannot be created after this).
692 if Base_CPU
/= System
.Multiprocessors
.Not_A_Specific_CPU
693 and then T
.Common
.Domain
= System
.Tasking
.System_Domain
694 and then not System
.Tasking
.Dispatching_Domains_Frozen
696 -- Increase the number of tasks attached to the CPU to which this
697 -- task is being moved.
699 Dispatching_Domain_Tasks
(Base_CPU
) :=
700 Dispatching_Domain_Tasks
(Base_CPU
) + 1;
703 -- Create TSD as early as possible in the creation of a task, since it
704 -- may be used by the operation of Ada code within the task.
706 SSL
.Create_TSD
(T
.Common
.Compiler_Data
);
707 T
.Common
.Activation_Link
:= Chain
.T_ID
;
710 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
712 if Runtime_Traces
then
713 Send_Trace_Info
(T_Create
, T
);
718 (Self_ID
, "Created task in " & T
.Master_of_Task
'Img, 'C', T
));
725 function Current_Master
return Master_Level
is
727 return STPO
.Self
.Master_Within
;
734 procedure Enter_Master
is
735 Self_ID
: constant Task_Id
:= STPO
.Self
;
737 Self_ID
.Master_Within
:= Self_ID
.Master_Within
+ 1;
740 (Self_ID
, "Enter_Master ->" & Self_ID
.Master_Within
'Img, 'M'));
743 -------------------------------
744 -- Expunge_Unactivated_Tasks --
745 -------------------------------
747 -- See procedure Close_Entries for the general case
749 procedure Expunge_Unactivated_Tasks
(Chain
: in out Activation_Chain
) is
750 Self_ID
: constant Task_Id
:= STPO
.Self
;
752 Call
: Entry_Call_Link
;
757 (Debug
.Trace
(Self_ID
, "Expunge_Unactivated_Tasks", 'C'));
759 Initialization
.Defer_Abort_Nestable
(Self_ID
);
762 -- Experimentation has shown that abort is sometimes (but not always)
763 -- already deferred when this is called.
765 -- That may indicate an error. Find out what is going on
769 pragma Assert
(C
.Common
.State
= Unactivated
);
771 Temp
:= C
.Common
.Activation_Link
;
773 if C
.Common
.State
= Unactivated
then
777 for J
in 1 .. C
.Entry_Num
loop
778 Queuing
.Dequeue_Head
(C
.Entry_Queues
(J
), Call
);
779 pragma Assert
(Call
= null);
784 Initialization
.Remove_From_All_Tasks_List
(C
);
787 Vulnerable_Free_Task
(C
);
793 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
794 end Expunge_Unactivated_Tasks
;
796 ---------------------------
797 -- Finalize_Global_Tasks --
798 ---------------------------
801 -- We have a potential problem here if finalization of global objects does
802 -- anything with signals or the timer server, since by that time those
803 -- servers have terminated.
805 -- It is hard to see how that would occur
807 -- However, a better solution might be to do all this finalization
808 -- using the global finalization chain.
810 procedure Finalize_Global_Tasks
is
811 Self_ID
: constant Task_Id
:= STPO
.Self
;
817 (Int
: System
.Interrupt_Management
.Interrupt_ID
) return Character;
818 pragma Import
(C
, State
, "__gnat_get_interrupt_state");
819 -- Get interrupt state for interrupt number Int. Defined in init.c
821 Default
: constant Character := 's';
822 -- 's' Interrupt_State pragma set state to System (use "default"
826 if Self_ID
.Deferral_Level
= 0 then
828 -- In principle, we should be able to predict whether abort is
829 -- already deferred here (and it should not be deferred yet but in
830 -- practice it seems Finalize_Global_Tasks is being called sometimes,
831 -- from RTS code for exceptions, with abort already deferred.
833 Initialization
.Defer_Abort_Nestable
(Self_ID
);
835 -- Never undefer again
838 -- This code is only executed by the environment task
840 pragma Assert
(Self_ID
= Environment_Task
);
842 -- Set Environment_Task'Callable to false to notify library-level tasks
843 -- that it is waiting for them.
845 Self_ID
.Callable
:= False;
847 -- Exit level 2 master, for normal tasks in library-level packages
851 -- Force termination of "independent" library-level server tasks
855 Abort_Dependents
(Self_ID
);
857 if not Single_Lock
then
861 -- We need to explicitly wait for the task to be terminated here
862 -- because on true concurrent system, we may end this procedure before
863 -- the tasks are really terminated.
865 Write_Lock
(Self_ID
);
867 -- If the Abort_Task signal is set to system, it means that we may
868 -- not have been able to abort all independent tasks (in particular,
869 -- Server_Task may be blocked, waiting for a signal), in which case, do
870 -- not wait for Independent_Task_Count to go down to 0. We arbitrarily
871 -- limit the number of loop iterations; if an independent task does not
872 -- terminate, we do not want to hang here. In that case, the thread will
873 -- be terminated when the process exits.
875 if State
(System
.Interrupt_Management
.Abort_Task_Interrupt
) /= Default
877 for J
in 1 .. 10 loop
878 exit when Utilities
.Independent_Task_Count
= 0;
880 -- We used to yield here, but this did not take into account low
881 -- priority tasks that would cause dead lock in some cases (true
885 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
886 Self_ID
.Common
.State
, Ignore_1
, Ignore_2
);
890 -- ??? On multi-processor environments, it seems that the above loop
891 -- isn't sufficient, so we need to add an additional delay.
894 (Self_ID
, 0.01, System
.OS_Primitives
.Relative
,
895 Self_ID
.Common
.State
, Ignore_1
, Ignore_2
);
903 -- Complete the environment task
905 Vulnerable_Complete_Task
(Self_ID
);
907 -- Handle normal task termination by the environment task, but only
908 -- for the normal task termination. In the case of Abnormal and
909 -- Unhandled_Exception they must have been handled before, and the
910 -- task termination soft link must have been changed so the task
911 -- termination routine is not executed twice.
913 SSL
.Task_Termination_Handler
.all (Ada
.Exceptions
.Null_Occurrence
);
915 -- Finalize all library-level controlled objects
917 if not SSL
."=" (SSL
.Finalize_Library_Objects
, null) then
918 SSL
.Finalize_Library_Objects
.all;
921 -- Reset the soft links to non-tasking
923 SSL
.Abort_Defer
:= SSL
.Abort_Defer_NT
'Access;
924 SSL
.Abort_Undefer
:= SSL
.Abort_Undefer_NT
'Access;
925 SSL
.Lock_Task
:= SSL
.Task_Lock_NT
'Access;
926 SSL
.Unlock_Task
:= SSL
.Task_Unlock_NT
'Access;
927 SSL
.Get_Jmpbuf_Address
:= SSL
.Get_Jmpbuf_Address_NT
'Access;
928 SSL
.Set_Jmpbuf_Address
:= SSL
.Set_Jmpbuf_Address_NT
'Access;
929 SSL
.Get_Sec_Stack_Addr
:= SSL
.Get_Sec_Stack_Addr_NT
'Access;
930 SSL
.Set_Sec_Stack_Addr
:= SSL
.Set_Sec_Stack_Addr_NT
'Access;
931 SSL
.Check_Abort_Status
:= SSL
.Check_Abort_Status_NT
'Access;
932 SSL
.Get_Stack_Info
:= SSL
.Get_Stack_Info_NT
'Access;
934 -- Don't bother trying to finalize Initialization.Global_Task_Lock
935 -- and System.Task_Primitives.RTS_Lock.
937 end Finalize_Global_Tasks
;
943 procedure Free_Task
(T
: Task_Id
) is
944 Self_Id
: constant Task_Id
:= Self
;
947 if T
.Common
.State
= Terminated
then
949 -- It is not safe to call Abort_Defer or Write_Lock at this stage
951 Initialization
.Task_Lock
(Self_Id
);
954 Initialization
.Finalize_Attributes
(T
);
955 Initialization
.Remove_From_All_Tasks_List
(T
);
958 Initialization
.Task_Unlock
(Self_Id
);
960 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
963 -- If the task is not terminated, then mark the task as to be freed
966 T
.Free_On_Termination
:= True;
970 ---------------------------
971 -- Move_Activation_Chain --
972 ---------------------------
974 procedure Move_Activation_Chain
975 (From
, To
: Activation_Chain_Access
;
976 New_Master
: Master_ID
)
978 Self_ID
: constant Task_Id
:= STPO
.Self
;
983 (Debug
.Trace
(Self_ID
, "Move_Activation_Chain", 'C'));
985 -- Nothing to do if From is empty, and we can check that without
994 Initialization
.Defer_Abort_Nestable
(Self_ID
);
996 -- Loop through the From chain, changing their Master_of_Task fields,
997 -- and to find the end of the chain.
1000 C
.Master_of_Task
:= New_Master
;
1001 exit when C
.Common
.Activation_Link
= null;
1002 C
:= C
.Common
.Activation_Link
;
1005 -- Hook From in at the start of To
1007 C
.Common
.Activation_Link
:= To
.all.T_ID
;
1008 To
.all.T_ID
:= From
.all.T_ID
;
1010 -- Set From to empty
1012 From
.all.T_ID
:= null;
1014 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
1015 end Move_Activation_Chain
;
1021 -- The task wrapper is a procedure that is called first for each task body
1022 -- and which in turn calls the compiler-generated task body procedure.
1023 -- The wrapper's main job is to do initialization for the task. It also
1024 -- has some locally declared objects that serve as per-task local data.
1025 -- Task finalization is done by Complete_Task, which is called from an
1026 -- at-end handler that the compiler generates.
1028 procedure Task_Wrapper
(Self_ID
: Task_Id
) is
1029 use type SSE
.Storage_Offset
;
1030 use System
.Standard_Library
;
1031 use System
.Stack_Usage
;
1033 Bottom_Of_Stack
: aliased Integer;
1035 Task_Alternate_Stack
:
1036 aliased SSE
.Storage_Array
(1 .. Alternate_Stack_Size
);
1037 -- The alternate signal stack for this task, if any
1039 Use_Alternate_Stack
: constant Boolean := Alternate_Stack_Size
/= 0;
1040 -- Whether to use above alternate signal stack for stack overflows
1042 function Secondary_Stack_Size
return Storage_Elements
.Storage_Offset
;
1043 -- Returns the size of the secondary stack for the task. For fixed
1044 -- secondary stacks, the function will return the ATCB field
1045 -- Secondary_Stack_Size if it is not set to Unspecified_Size,
1046 -- otherwise a percentage of the stack is reserved using the
1047 -- System.Parameters.Sec_Stack_Percentage property.
1049 -- Dynamic secondary stacks are allocated in System.Soft_Links.
1050 -- Create_TSD and thus the function returns 0 to suppress the
1051 -- creation of the fixed secondary stack in the primary stack.
1053 --------------------------
1054 -- Secondary_Stack_Size --
1055 --------------------------
1057 function Secondary_Stack_Size
return Storage_Elements
.Storage_Offset
is
1058 use System
.Storage_Elements
;
1059 use System
.Secondary_Stack
;
1062 if Parameters
.Sec_Stack_Dynamic
then
1065 elsif Self_ID
.Common
.Secondary_Stack_Size
= Unspecified_Size
then
1066 return (Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
1067 * SSE
.Storage_Offset
(Sec_Stack_Percentage
) / 100);
1069 -- Use the size specified by aspect Secondary_Stack_Size padded
1070 -- by the amount of space used by the stack data structure.
1072 return Storage_Offset
(Self_ID
.Common
.Secondary_Stack_Size
) +
1073 Storage_Offset
(SST
.Minimum_Secondary_Stack_Size
);
1075 end Secondary_Stack_Size
;
1077 Secondary_Stack
: aliased Storage_Elements
.Storage_Array
1078 (1 .. Secondary_Stack_Size
);
1079 for Secondary_Stack
'Alignment use Standard
'Maximum_Alignment;
1080 -- Actual area allocated for secondary stack. Note that it is critical
1081 -- that this have maximum alignment, since any kind of data can be
1084 Secondary_Stack_Address
: System
.Address
:= Secondary_Stack
'Address;
1085 -- Address of secondary stack. In the fixed secondary stack case, this
1086 -- value is not modified, causing a warning, hence the bracketing with
1087 -- Warnings (Off/On). But why is so much *more* bracketed???
1089 SEH_Table
: aliased SSE
.Storage_Array
(1 .. 8);
1090 -- Structured Exception Registration table (2 words)
1092 procedure Install_SEH_Handler
(Addr
: System
.Address
);
1093 pragma Import
(C
, Install_SEH_Handler
, "__gnat_install_SEH_handler");
1094 -- Install the SEH (Structured Exception Handling) handler
1096 Cause
: Cause_Of_Termination
:= Normal
;
1097 -- Indicates the reason why this task terminates. Normal corresponds to
1098 -- a task terminating due to completing the last statement of its body,
1099 -- or as a result of waiting on a terminate alternative. If the task
1100 -- terminates because it is being aborted then Cause will be set
1101 -- to Abnormal. If the task terminates because of an exception
1102 -- raised by the execution of its task body, then Cause is set
1103 -- to Unhandled_Exception.
1105 EO
: Exception_Occurrence
;
1106 -- If the task terminates because of an exception raised by the
1107 -- execution of its task body, then EO will contain the associated
1108 -- exception occurrence. Otherwise, it will contain Null_Occurrence.
1110 TH
: Termination_Handler
:= null;
1111 -- Pointer to the protected procedure to be executed upon task
1114 procedure Search_Fall_Back_Handler
(ID
: Task_Id
);
1115 -- Procedure that searches recursively a fall-back handler through the
1116 -- master relationship. If the handler is found, its pointer is stored
1117 -- in TH. It stops when the handler is found or when the ID is null.
1119 ------------------------------
1120 -- Search_Fall_Back_Handler --
1121 ------------------------------
1123 procedure Search_Fall_Back_Handler
(ID
: Task_Id
) is
1125 -- A null Task_Id indicates that we have reached the root of the
1126 -- task hierarchy and no handler has been found.
1131 -- If there is a fall back handler, store its pointer for later
1134 elsif ID
.Common
.Fall_Back_Handler
/= null then
1135 TH
:= ID
.Common
.Fall_Back_Handler
;
1137 -- Otherwise look for a fall back handler in the parent
1140 Search_Fall_Back_Handler
(ID
.Common
.Parent
);
1142 end Search_Fall_Back_Handler
;
1144 -- Start of processing for Task_Wrapper
1147 pragma Assert
(Self_ID
.Deferral_Level
= 1);
1150 (Self_ID
, Self_ID
.Common
.Parent
, Self_ID
.Master_of_Task
);
1152 -- Assume a size of the stack taken at this stage
1154 if not Parameters
.Sec_Stack_Dynamic
then
1155 Self_ID
.Common
.Compiler_Data
.Sec_Stack_Addr
:=
1156 Secondary_Stack
'Address;
1157 SST
.SS_Init
(Secondary_Stack_Address
, Integer (Secondary_Stack
'Last));
1160 if Use_Alternate_Stack
then
1161 Self_ID
.Common
.Task_Alternate_Stack
:= Task_Alternate_Stack
'Address;
1164 -- Set the guard page at the bottom of the stack. The call to unprotect
1165 -- the page is done in Terminate_Task
1167 Stack_Guard
(Self_ID
, True);
1169 -- Initialize low-level TCB components, that cannot be initialized by
1170 -- the creator. Enter_Task sets Self_ID.LL.Thread.
1172 Enter_Task
(Self_ID
);
1174 -- Initialize dynamic stack usage
1176 if System
.Stack_Usage
.Is_Enabled
then
1178 Guard_Page_Size
: constant := 16 * 1024;
1179 -- Part of the stack used as a guard page. This is an OS dependent
1180 -- value, so we need to use the maximum. This value is only used
1181 -- when the stack address is known, that is currently Windows.
1183 Small_Overflow_Guard
: constant := 12 * 1024;
1184 -- Note: this used to be 4K, but was changed to 12K, since
1185 -- smaller values resulted in segmentation faults from dynamic
1188 Big_Overflow_Guard
: constant := 64 * 1024 + 8 * 1024;
1189 Small_Stack_Limit
: constant := 64 * 1024;
1190 -- ??? These three values are experimental, and seem to work on
1191 -- most platforms. They still need to be analyzed further. They
1192 -- also need documentation, what are they and why does the logic
1193 -- differ depending on whether the stack is large or small???
1195 Pattern_Size
: Natural :=
1196 Natural (Self_ID
.Common
.
1197 Compiler_Data
.Pri_Stack_Info
.Size
);
1198 -- Size of the pattern
1200 Stack_Base
: Address
;
1201 -- Address of the base of the stack
1204 Stack_Base
:= Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Base
;
1206 if Stack_Base
= Null_Address
then
1208 -- On many platforms, we don't know the real stack base
1209 -- address. Estimate it using an address in the frame.
1211 Stack_Base
:= Bottom_Of_Stack
'Address;
1213 -- Also reduce the size of the stack to take into account the
1214 -- secondary stack array declared in this frame. This is for
1215 -- sure very conservative.
1217 if not Parameters
.Sec_Stack_Dynamic
then
1219 Pattern_Size
- Natural (Secondary_Stack_Size
);
1222 -- Adjustments for inner frames
1224 Pattern_Size
:= Pattern_Size
-
1225 (if Pattern_Size
< Small_Stack_Limit
1226 then Small_Overflow_Guard
1227 else Big_Overflow_Guard
);
1229 -- Reduce by the size of the final guard page
1231 Pattern_Size
:= Pattern_Size
- Guard_Page_Size
;
1236 (Self_ID
.Common
.Analyzer
,
1237 Self_ID
.Common
.Task_Image
(1 .. Self_ID
.Common
.Task_Image_Len
),
1238 Natural (Self_ID
.Common
.Compiler_Data
.Pri_Stack_Info
.Size
),
1239 SSE
.To_Integer
(Stack_Base
),
1242 Fill_Stack
(Self_ID
.Common
.Analyzer
);
1246 -- We setup the SEH (Structured Exception Handling) handler if supported
1249 Install_SEH_Handler
(SEH_Table
'Address);
1251 -- Initialize exception occurrence
1253 Save_Occurrence
(EO
, Ada
.Exceptions
.Null_Occurrence
);
1255 -- We lock RTS_Lock to wait for activator to finish activating the rest
1256 -- of the chain, so that everyone in the chain comes out in priority
1259 -- This also protects the value of
1260 -- Self_ID.Common.Activator.Common.Wait_Count.
1265 if not System
.Restrictions
.Abort_Allowed
then
1267 -- If Abort is not allowed, reset the deferral level since it will
1268 -- not get changed by the generated code. Keeping a default value
1269 -- of one would prevent some operations (e.g. select or delay) to
1270 -- proceed successfully.
1272 Self_ID
.Deferral_Level
:= 0;
1275 if Global_Task_Debug_Event_Set
then
1276 Debug
.Signal_Debug_Event
(Debug
.Debug_Event_Run
, Self_ID
);
1280 -- We are separating the following portion of the code in order to
1281 -- place the exception handlers in a different block. In this way,
1282 -- we do not call Set_Jmpbuf_Address (which needs Self) before we
1283 -- set Self in Enter_Task
1285 -- Call the task body procedure
1287 -- The task body is called with abort still deferred. That
1288 -- eliminates a dangerous window, for which we had to patch-up in
1291 -- During the expansion of the task body, we insert an RTS-call
1292 -- to Abort_Undefer, at the first point where abort should be
1295 Self_ID
.Common
.Task_Entry_Point
(Self_ID
.Common
.Task_Arg
);
1296 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1299 -- We can't call Terminate_Task in the exception handlers below,
1300 -- since there may be (e.g. in the case of GCC exception handling)
1301 -- clean ups associated with the exception handler that need to
1302 -- access task specific data.
1304 -- Defer abort so that this task can't be aborted while exiting
1306 when Standard
'Abort_Signal =>
1307 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1309 -- Update the cause that motivated the task termination so that
1310 -- the appropriate information is passed to the task termination
1311 -- procedure. Task termination as a result of waiting on a
1312 -- terminate alternative is a normal termination, although it is
1313 -- implemented using the abort mechanisms.
1315 if Self_ID
.Terminate_Alternative
then
1318 if Global_Task_Debug_Event_Set
then
1319 Debug
.Signal_Debug_Event
1320 (Debug
.Debug_Event_Terminated
, Self_ID
);
1325 if Global_Task_Debug_Event_Set
then
1326 Debug
.Signal_Debug_Event
1327 (Debug
.Debug_Event_Abort_Terminated
, Self_ID
);
1332 -- ??? Using an E : others here causes CD2C11A to fail on Tru64
1334 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1336 -- Perform the task specific exception tracing duty. We handle
1337 -- these outputs here and not in the common notification routine
1338 -- because we need access to tasking related data and we don't
1339 -- want to drag dependencies against tasking related units in the
1340 -- the common notification units. Additionally, no trace is ever
1341 -- triggered from the common routine for the Unhandled_Raise case
1342 -- in tasks, since an exception never appears unhandled in this
1343 -- context because of this handler.
1345 if Exception_Trace
= Unhandled_Raise
then
1346 Trace_Unhandled_Exception_In_Task
(Self_ID
);
1349 -- Update the cause that motivated the task termination so that
1350 -- the appropriate information is passed to the task termination
1351 -- procedure, as well as the associated Exception_Occurrence.
1353 Cause
:= Unhandled_Exception
;
1355 Save_Occurrence
(EO
, SSL
.Get_Current_Excep
.all.all);
1357 if Global_Task_Debug_Event_Set
then
1358 Debug
.Signal_Debug_Event
1359 (Debug
.Debug_Event_Exception_Terminated
, Self_ID
);
1363 -- Look for a task termination handler. This code is for all tasks but
1364 -- the environment task. The task termination code for the environment
1365 -- task is executed by SSL.Task_Termination_Handler.
1371 Write_Lock
(Self_ID
);
1373 if Self_ID
.Common
.Specific_Handler
/= null then
1374 TH
:= Self_ID
.Common
.Specific_Handler
;
1376 -- Independent tasks should not call the Fall_Back_Handler (of the
1377 -- environment task), because they are implementation artifacts that
1378 -- should be invisible to Ada programs.
1380 elsif Self_ID
.Master_of_Task
/= Independent_Task_Level
then
1382 -- Look for a fall-back handler following the master relationship
1383 -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back
1384 -- handler applies only to the dependent tasks of the task". Hence,
1385 -- if the terminating tasks (Self_ID) had a fall-back handler, it
1386 -- would not apply to itself, so we start the search with the parent.
1388 Search_Fall_Back_Handler
(Self_ID
.Common
.Parent
);
1397 -- Execute the task termination handler if we found it
1401 TH
.all (Cause
, Self_ID
, EO
);
1405 -- RM-C.7.3 requires all exceptions raised here to be ignored
1412 if System
.Stack_Usage
.Is_Enabled
then
1413 Compute_Result
(Self_ID
.Common
.Analyzer
);
1414 Report_Result
(Self_ID
.Common
.Analyzer
);
1417 Terminate_Task
(Self_ID
);
1420 --------------------
1421 -- Terminate_Task --
1422 --------------------
1424 -- Before we allow the thread to exit, we must clean up. This is a delicate
1425 -- job. We must wake up the task's master, who may immediately try to
1426 -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING.
1428 -- To avoid this, the parent task must be blocked up to the latest
1429 -- statement executed. The trouble is that we have another step that we
1430 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1431 -- We have to postpone that until the end because compiler-generated code
1432 -- is likely to try to access that data at just about any point.
1434 -- We can't call Destroy_TSD while we are holding any other locks, because
1435 -- it locks Global_Task_Lock, and our deadlock prevention rules require
1436 -- that to be the outermost lock. Our first "solution" was to just lock
1437 -- Global_Task_Lock in addition to the other locks, and force the parent to
1438 -- also lock this lock between its wakeup and its freeing of the ATCB. See
1439 -- Complete_Task for the parent-side of the code that has the matching
1440 -- calls to Task_Lock and Task_Unlock. That was not really a solution,
1441 -- since the operation Task_Unlock continued to access the ATCB after
1442 -- unlocking, after which the parent was observed to race ahead, deallocate
1443 -- the ATCB, and then reallocate it to another task. The call to
1444 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
1445 -- the data of the new task that reused the ATCB. To solve this problem, we
1446 -- introduced the new operation Final_Task_Unlock.
1448 procedure Terminate_Task
(Self_ID
: Task_Id
) is
1449 Environment_Task
: constant Task_Id
:= STPO
.Environment_Task
;
1450 Master_of_Task
: Integer;
1451 Deallocate
: Boolean;
1454 Debug
.Task_Termination_Hook
;
1456 if Runtime_Traces
then
1457 Send_Trace_Info
(T_Terminate
);
1460 -- Since GCC cannot allocate stack chunks efficiently without reordering
1461 -- some of the allocations, we have to handle this unexpected situation
1462 -- here. Normally we never have to call Vulnerable_Complete_Task here.
1464 if Self_ID
.Common
.Activator
/= null then
1465 Vulnerable_Complete_Task
(Self_ID
);
1468 Initialization
.Task_Lock
(Self_ID
);
1474 Master_of_Task
:= Self_ID
.Master_of_Task
;
1476 -- Check if the current task is an independent task If so, decrement
1477 -- the Independent_Task_Count value.
1479 if Master_of_Task
= Independent_Task_Level
then
1481 Utilities
.Independent_Task_Count
:=
1482 Utilities
.Independent_Task_Count
- 1;
1485 Write_Lock
(Environment_Task
);
1486 Utilities
.Independent_Task_Count
:=
1487 Utilities
.Independent_Task_Count
- 1;
1488 Unlock
(Environment_Task
);
1492 -- Unprotect the guard page if needed
1494 Stack_Guard
(Self_ID
, False);
1496 Utilities
.Make_Passive
(Self_ID
, Task_Completed
=> True);
1497 Deallocate
:= Self_ID
.Free_On_Termination
;
1503 pragma Assert
(Check_Exit
(Self_ID
));
1505 SSL
.Destroy_TSD
(Self_ID
.Common
.Compiler_Data
);
1506 Initialization
.Final_Task_Unlock
(Self_ID
);
1508 -- WARNING: past this point, this thread must assume that the ATCB has
1509 -- been deallocated, and can't access it anymore (which is why we have
1510 -- saved the Free_On_Termination flag in a temporary variable).
1513 Free_Task
(Self_ID
);
1516 if Master_of_Task
> 0 then
1525 function Terminated
(T
: Task_Id
) return Boolean is
1526 Self_ID
: constant Task_Id
:= STPO
.Self
;
1530 Initialization
.Defer_Abort_Nestable
(Self_ID
);
1537 Result
:= T
.Common
.State
= Terminated
;
1544 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
1548 ----------------------------------------
1549 -- Trace_Unhandled_Exception_In_Task --
1550 ----------------------------------------
1552 procedure Trace_Unhandled_Exception_In_Task
(Self_Id
: Task_Id
) is
1553 procedure To_Stderr
(S
: String);
1554 pragma Import
(Ada
, To_Stderr
, "__gnat_to_stderr");
1556 use System
.Soft_Links
;
1557 use System
.Standard_Library
;
1559 function To_Address
is new
1560 Ada
.Unchecked_Conversion
1561 (Task_Id
, System
.Task_Primitives
.Task_Address
);
1563 Excep
: constant Exception_Occurrence_Access
:=
1564 SSL
.Get_Current_Excep
.all;
1567 -- This procedure is called by the task outermost handler in
1568 -- Task_Wrapper below, so only once the task stack has been fully
1569 -- unwound. The common notification routine has been called at the
1570 -- raise point already.
1572 -- Lock to prevent unsynchronized output
1574 Initialization
.Task_Lock
(Self_Id
);
1575 To_Stderr
("task ");
1577 if Self_Id
.Common
.Task_Image_Len
/= 0 then
1579 (Self_Id
.Common
.Task_Image
(1 .. Self_Id
.Common
.Task_Image_Len
));
1583 To_Stderr
(System
.Address_Image
(To_Address
(Self_Id
)));
1584 To_Stderr
(" terminated by unhandled exception");
1585 To_Stderr
((1 => ASCII
.LF
));
1586 To_Stderr
(Exception_Information
(Excep
.all));
1587 Initialization
.Task_Unlock
(Self_Id
);
1588 end Trace_Unhandled_Exception_In_Task
;
1590 ------------------------------------
1591 -- Vulnerable_Complete_Activation --
1592 ------------------------------------
1594 -- As in several other places, the locks of the activator and activated
1595 -- task are both locked here. This follows our deadlock prevention lock
1596 -- ordering policy, since the activated task must be created after the
1599 procedure Vulnerable_Complete_Activation
(Self_ID
: Task_Id
) is
1600 Activator
: constant Task_Id
:= Self_ID
.Common
.Activator
;
1603 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Activation", 'C'));
1605 Write_Lock
(Activator
);
1606 Write_Lock
(Self_ID
);
1608 pragma Assert
(Self_ID
.Common
.Activator
/= null);
1610 -- Remove dangling reference to Activator, since a task may outlive its
1613 Self_ID
.Common
.Activator
:= null;
1615 -- Wake up the activator, if it is waiting for a chain of tasks to
1616 -- activate, and we are the last in the chain to complete activation.
1618 if Activator
.Common
.State
= Activator_Sleep
then
1619 Activator
.Common
.Wait_Count
:= Activator
.Common
.Wait_Count
- 1;
1621 if Activator
.Common
.Wait_Count
= 0 then
1622 Wakeup
(Activator
, Activator_Sleep
);
1626 -- The activator raises a Tasking_Error if any task it is activating
1627 -- is completed before the activation is done. However, if the reason
1628 -- for the task completion is an abort, we do not raise an exception.
1631 if not Self_ID
.Callable
and then Self_ID
.Pending_ATC_Level
/= 0 then
1632 Activator
.Common
.Activation_Failed
:= True;
1638 -- After the activation, active priority should be the same as base
1639 -- priority. We must unlock the Activator first, though, since it
1640 -- should not wait if we have lower priority.
1642 if Get_Priority
(Self_ID
) /= Self_ID
.Common
.Base_Priority
then
1643 Write_Lock
(Self_ID
);
1644 Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
1647 end Vulnerable_Complete_Activation
;
1649 --------------------------------
1650 -- Vulnerable_Complete_Master --
1651 --------------------------------
1653 procedure Vulnerable_Complete_Master
(Self_ID
: Task_Id
) is
1656 CM
: constant Master_Level
:= Self_ID
.Master_Within
;
1657 T
: aliased Task_Id
;
1659 To_Be_Freed
: Task_Id
;
1660 -- This is a list of ATCBs to be freed, after we have released all RTS
1661 -- locks. This is necessary because of the locking order rules, since
1662 -- the storage manager uses Global_Task_Lock.
1664 pragma Warnings
(Off
);
1665 function Check_Unactivated_Tasks
return Boolean;
1666 pragma Warnings
(On
);
1667 -- Temporary error-checking code below. This is part of the checks
1668 -- added in the new run time. Call it only inside a pragma Assert.
1670 -----------------------------
1671 -- Check_Unactivated_Tasks --
1672 -----------------------------
1674 function Check_Unactivated_Tasks
return Boolean is
1676 if not Single_Lock
then
1680 Write_Lock
(Self_ID
);
1682 C
:= All_Tasks_List
;
1683 while C
/= null loop
1684 if C
.Common
.Activator
= Self_ID
and then C
.Master_of_Task
= CM
then
1688 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1691 if C
.Common
.State
= Unactivated
then
1698 C
:= C
.Common
.All_Tasks_Link
;
1703 if not Single_Lock
then
1708 end Check_Unactivated_Tasks
;
1710 -- Start of processing for Vulnerable_Complete_Master
1714 (Debug
.Trace
(Self_ID
, "V_Complete_Master(" & CM
'Img & ")", 'C'));
1716 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1718 (Self_ID
.Deferral_Level
> 0
1719 or else not System
.Restrictions
.Abort_Allowed
);
1721 -- Count how many active dependent tasks this master currently has, and
1722 -- record this in Wait_Count.
1724 -- This count should start at zero, since it is initialized to zero for
1725 -- new tasks, and the task should not exit the sleep-loops that use this
1726 -- count until the count reaches zero.
1728 -- While we're counting, if we run across any unactivated tasks that
1729 -- belong to this master, we summarily terminate them as required by
1733 Write_Lock
(Self_ID
);
1735 C
:= All_Tasks_List
;
1736 while C
/= null loop
1738 -- Terminate unactivated (never-to-be activated) tasks
1740 if C
.Common
.Activator
= Self_ID
and then C
.Master_of_Task
= CM
then
1742 -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
1743 -- = CM. The only case where C is pending activation by this
1744 -- task, but the master of C is not CM is in Ada 2005, when C is
1745 -- part of a return object of a build-in-place function.
1747 pragma Assert
(C
.Common
.State
= Unactivated
);
1750 C
.Common
.Activator
:= null;
1751 C
.Common
.State
:= Terminated
;
1752 C
.Callable
:= False;
1753 Utilities
.Cancel_Queued_Entry_Calls
(C
);
1757 -- Count it if directly dependent on this master
1759 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1762 if C
.Awake_Count
/= 0 then
1763 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1769 C
:= C
.Common
.All_Tasks_Link
;
1772 Self_ID
.Common
.State
:= Master_Completion_Sleep
;
1775 if not Single_Lock
then
1779 -- Wait until dependent tasks are all terminated or ready to terminate.
1780 -- While waiting, the task may be awakened if the task's priority needs
1781 -- changing, or this master is aborted. In the latter case, we abort the
1782 -- dependents, and resume waiting until Wait_Count goes to zero.
1784 Write_Lock
(Self_ID
);
1787 exit when Self_ID
.Common
.Wait_Count
= 0;
1789 -- Here is a difference as compared to Complete_Master
1791 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
1792 and then not Self_ID
.Dependents_Aborted
1795 Abort_Dependents
(Self_ID
);
1799 Abort_Dependents
(Self_ID
);
1801 Write_Lock
(Self_ID
);
1805 (Debug
.Trace
(Self_ID
, "master_completion_sleep", 'C'));
1806 Sleep
(Self_ID
, Master_Completion_Sleep
);
1810 Self_ID
.Common
.State
:= Runnable
;
1813 -- Dependents are all terminated or on terminate alternatives. Now,
1814 -- force those on terminate alternatives to terminate, by aborting them.
1816 pragma Assert
(Check_Unactivated_Tasks
);
1818 if Self_ID
.Alive_Count
> 1 then
1820 -- Consider finding a way to skip the following extra steps if there
1821 -- are no dependents with terminate alternatives. This could be done
1822 -- by adding another count to the ATCB, similar to Awake_Count, but
1823 -- keeping track of tasks that are on terminate alternatives.
1825 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1827 -- Force any remaining dependents to terminate by aborting them
1829 if not Single_Lock
then
1833 Abort_Dependents
(Self_ID
);
1835 -- Above, when we "abort" the dependents we are simply using this
1836 -- operation for convenience. We are not required to support the full
1837 -- abort-statement semantics; in particular, we are not required to
1838 -- immediately cancel any queued or in-service entry calls. That is
1839 -- good, because if we tried to cancel a call we would need to lock
1840 -- the caller, in order to wake the caller up. Our anti-deadlock
1841 -- rules prevent us from doing that without releasing the locks on C
1842 -- and Self_ID. Releasing and retaking those locks would be wasteful
1843 -- at best, and should not be considered further without more
1844 -- detailed analysis of potential concurrent accesses to the ATCBs
1845 -- of C and Self_ID.
1847 -- Count how many "alive" dependent tasks this master currently has,
1848 -- and record this in Wait_Count. This count should start at zero,
1849 -- since it is initialized to zero for new tasks, and the task should
1850 -- not exit the sleep-loops that use this count until the count
1853 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
1855 Write_Lock
(Self_ID
);
1857 C
:= All_Tasks_List
;
1858 while C
/= null loop
1859 if C
.Common
.Parent
= Self_ID
and then C
.Master_of_Task
= CM
then
1862 pragma Assert
(C
.Awake_Count
= 0);
1864 if C
.Alive_Count
> 0 then
1865 pragma Assert
(C
.Terminate_Alternative
);
1866 Self_ID
.Common
.Wait_Count
:= Self_ID
.Common
.Wait_Count
+ 1;
1872 C
:= C
.Common
.All_Tasks_Link
;
1875 Self_ID
.Common
.State
:= Master_Phase_2_Sleep
;
1878 if not Single_Lock
then
1882 -- Wait for all counted tasks to finish terminating themselves
1884 Write_Lock
(Self_ID
);
1887 exit when Self_ID
.Common
.Wait_Count
= 0;
1888 Sleep
(Self_ID
, Master_Phase_2_Sleep
);
1891 Self_ID
.Common
.State
:= Runnable
;
1895 -- We don't wake up for abort here. We are already terminating just as
1896 -- fast as we can, so there is no point.
1898 -- Remove terminated tasks from the list of Self_ID's dependents, but
1899 -- don't free their ATCBs yet, because of lock order restrictions, which
1900 -- don't allow us to call "free" or "malloc" while holding any other
1901 -- locks. Instead, we put those ATCBs to be freed onto a temporary list,
1902 -- called To_Be_Freed.
1904 if not Single_Lock
then
1908 C
:= All_Tasks_List
;
1910 while C
/= null loop
1912 -- If Free_On_Termination is set, do nothing here, and let the
1913 -- task free itself if not already done, otherwise we risk a race
1914 -- condition where Vulnerable_Free_Task is called in the loop below,
1915 -- while the task calls Free_Task itself, in Terminate_Task.
1917 if C
.Common
.Parent
= Self_ID
1918 and then C
.Master_of_Task
>= CM
1919 and then not C
.Free_On_Termination
1922 P
.Common
.All_Tasks_Link
:= C
.Common
.All_Tasks_Link
;
1924 All_Tasks_List
:= C
.Common
.All_Tasks_Link
;
1927 T
:= C
.Common
.All_Tasks_Link
;
1928 C
.Common
.All_Tasks_Link
:= To_Be_Freed
;
1934 C
:= C
.Common
.All_Tasks_Link
;
1940 -- Free all the ATCBs on the list To_Be_Freed
1942 -- The ATCBs in the list are no longer in All_Tasks_List, and after
1943 -- any interrupt entries are detached from them they should no longer
1946 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1947 -- avoid a race between a terminating task and its parent. The parent
1948 -- might try to deallocate the ACTB out from underneath the exiting
1949 -- task. Note that Free will also lock Global_Task_Lock, but that is
1950 -- OK, since this is the *one* lock for which we have a mechanism to
1951 -- support nested locking. See Task_Wrapper and its finalizer for more
1955 -- The check "T.Common.Parent /= null ..." below is to prevent dangling
1956 -- references to terminated library-level tasks, which could otherwise
1957 -- occur during finalization of library-level objects. A better solution
1958 -- might be to hook task objects into the finalization chain and
1959 -- deallocate the ATCB when the task object is deallocated. However,
1960 -- this change is not likely to gain anything significant, since all
1961 -- this storage should be recovered en-masse when the process exits.
1963 while To_Be_Freed
/= null loop
1965 To_Be_Freed
:= T
.Common
.All_Tasks_Link
;
1967 -- ??? On SGI there is currently no Interrupt_Manager, that's why we
1968 -- need to check if the Interrupt_Manager_ID is null.
1970 if T
.Interrupt_Entry
and then Interrupt_Manager_ID
/= null then
1972 Detach_Interrupt_Entries_Index
: constant Task_Entry_Index
:= 1;
1973 -- Corresponds to the entry index of System.Interrupts.
1974 -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure
1975 -- to update this value when changing Interrupt_Manager specs.
1977 type Param_Type
is access all Task_Id
;
1979 Param
: aliased Param_Type
:= T
'Access;
1982 System
.Tasking
.Rendezvous
.Call_Simple
1983 (Interrupt_Manager_ID
, Detach_Interrupt_Entries_Index
,
1988 if (T
.Common
.Parent
/= null
1989 and then T
.Common
.Parent
.Common
.Parent
/= null)
1990 or else T
.Master_of_Task
> Library_Task_Level
1992 Initialization
.Task_Lock
(Self_ID
);
1994 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD
1995 -- has not been called yet (case of an unactivated task).
1997 if T
.Common
.Compiler_Data
.Sec_Stack_Addr
/= Null_Address
then
1998 SSL
.Destroy_TSD
(T
.Common
.Compiler_Data
);
2001 Vulnerable_Free_Task
(T
);
2002 Initialization
.Task_Unlock
(Self_ID
);
2006 -- It might seem nice to let the terminated task deallocate its own
2007 -- ATCB. That would not cover the case of unactivated tasks. It also
2008 -- would force us to keep the underlying thread around past termination,
2009 -- since references to the ATCB are possible past termination.
2011 -- Currently, we get rid of the thread as soon as the task terminates,
2012 -- and let the parent recover the ATCB later.
2014 -- Some day, if we want to recover the ATCB earlier, at task
2015 -- termination, we could consider using "fat task IDs", that include the
2016 -- serial number with the ATCB pointer, to catch references to tasks
2017 -- that no longer have ATCBs. It is not clear how much this would gain,
2018 -- since the user-level task object would still be occupying storage.
2020 -- Make next master level up active. We don't need to lock the ATCB,
2021 -- since the value is only updated by each task for itself.
2023 Self_ID
.Master_Within
:= CM
- 1;
2025 Debug
.Master_Completed_Hook
(Self_ID
, CM
);
2026 end Vulnerable_Complete_Master
;
2028 ------------------------------
2029 -- Vulnerable_Complete_Task --
2030 ------------------------------
2032 -- Complete the calling task
2034 -- This procedure must be called with abort deferred. It should only be
2035 -- called by Complete_Task and Finalize_Global_Tasks (for the environment
2038 -- The effect is similar to that of Complete_Master. Differences include
2039 -- the closing of entries here, and computation of the number of active
2040 -- dependent tasks in Complete_Master.
2042 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
2043 -- because that does its own locking, and because we do not need the lock
2044 -- to test Self_ID.Common.Activator. That value should only be read and
2045 -- modified by Self.
2047 procedure Vulnerable_Complete_Task
(Self_ID
: Task_Id
) is
2050 (Self_ID
.Deferral_Level
> 0
2051 or else not System
.Restrictions
.Abort_Allowed
);
2052 pragma Assert
(Self_ID
= Self
);
2054 (Self_ID
.Master_Within
in
2055 Self_ID
.Master_of_Task
+ 1 .. Self_ID
.Master_of_Task
+ 3);
2056 pragma Assert
(Self_ID
.Common
.Wait_Count
= 0);
2057 pragma Assert
(Self_ID
.Open_Accepts
= null);
2058 pragma Assert
(Self_ID
.ATC_Nesting_Level
= 1);
2060 pragma Debug
(Debug
.Trace
(Self_ID
, "V_Complete_Task", 'C'));
2066 Write_Lock
(Self_ID
);
2067 Self_ID
.Callable
:= False;
2069 -- In theory, Self should have no pending entry calls left on its
2070 -- call-stack. Each async. select statement should clean its own call,
2071 -- and blocking entry calls should defer abort until the calls are
2072 -- cancelled, then clean up.
2074 Utilities
.Cancel_Queued_Entry_Calls
(Self_ID
);
2077 if Self_ID
.Common
.Activator
/= null then
2078 Vulnerable_Complete_Activation
(Self_ID
);
2085 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have
2086 -- dependent tasks for which we need to wait. Otherwise we just exit.
2088 if Self_ID
.Master_Within
= Self_ID
.Master_of_Task
+ 2 then
2089 Vulnerable_Complete_Master
(Self_ID
);
2091 end Vulnerable_Complete_Task
;
2093 --------------------------
2094 -- Vulnerable_Free_Task --
2095 --------------------------
2097 -- Recover all runtime system storage associated with the task T. This
2098 -- should only be called after T has terminated and will no longer be
2101 -- For tasks created by an allocator that fails, due to an exception, it
2102 -- is called from Expunge_Unactivated_Tasks.
2104 -- For tasks created by elaboration of task object declarations it is
2105 -- called from the finalization code of the Task_Wrapper procedure.
2107 procedure Vulnerable_Free_Task
(T
: Task_Id
) is
2109 pragma Debug
(Debug
.Trace
(Self
, "Vulnerable_Free_Task", 'C', T
));
2116 Initialization
.Finalize_Attributes
(T
);
2123 System
.Task_Primitives
.Operations
.Finalize_TCB
(T
);
2124 end Vulnerable_Free_Task
;
2126 -- Package elaboration code
2129 -- Establish the Adafinal softlink
2131 -- This is not done inside the central RTS initialization routine
2132 -- to avoid with'ing this package from System.Tasking.Initialization.
2134 SSL
.Adafinal
:= Finalize_Global_Tasks
'Access;
2136 -- Establish soft links for subprograms that manipulate master_id's.
2137 -- This cannot be done when the RTS is initialized, because of various
2138 -- elaboration constraints.
2140 SSL
.Current_Master
:= Stages
.Current_Master
'Access;
2141 SSL
.Enter_Master
:= Stages
.Enter_Master
'Access;
2142 SSL
.Complete_Master
:= Stages
.Complete_Master
'Access;
2143 end System
.Tasking
.Stages
;