1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . U T I L I T I E S --
9 -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This package provides RTS Internal Declarations.
35 -- These declarations are not part of the GNARLI
38 -- Turn off polling, we do not want ATC polling to take place during
39 -- tasking operations. It causes infinite loops and other problems.
41 with System
.Tasking
.Debug
;
42 -- used for Known_Tasks
44 with System
.Task_Primitives
.Operations
;
45 -- used for Write_Lock
53 with System
.Tasking
.Initialization
;
54 -- Used for Defer_Abort
56 -- Locked_Abort_To_Level
58 with System
.Tasking
.Queuing
;
59 -- used for Dequeue_Call
62 with System
.Tasking
.Debug
;
65 with System
.Parameters
;
66 -- used for Single_Lock
69 with System
.Traces
.Tasking
;
70 -- used for Send_Trace_Info
72 with Unchecked_Conversion
;
74 package body System
.Tasking
.Utilities
is
76 package STPO
renames System
.Task_Primitives
.Operations
;
81 use Task_Primitives
.Operations
;
84 use System
.Traces
.Tasking
;
90 -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:
91 -- (1) caller should be holding no locks except RTS_Lock when Single_Lock
92 -- (2) may be called for tasks that have not yet been activated
93 -- (3) always aborts whole task
95 procedure Abort_One_Task
(Self_ID
: Task_Id
; T
: Task_Id
) is
97 if Parameters
.Runtime_Traces
then
98 Send_Trace_Info
(T_Abort
, Self_ID
, T
);
103 if T
.Common
.State
= Unactivated
then
104 T
.Common
.Activator
:= null;
105 T
.Common
.State
:= Terminated
;
107 Cancel_Queued_Entry_Calls
(T
);
109 elsif T
.Common
.State
/= Terminated
then
110 Initialization
.Locked_Abort_To_Level
(Self_ID
, T
, 0);
120 -- This must be called to implement the abort statement.
121 -- Much of the actual work of the abort is done by the abortee,
122 -- via the Abort_Handler signal handler, and propagation of the
123 -- Abort_Signal special exception.
125 procedure Abort_Tasks
(Tasks
: Task_List
) is
126 Self_Id
: constant Task_Id
:= STPO
.Self
;
131 -- If pragma Detect_Blocking is active then Program_Error must be
132 -- raised if this potentially blocking operation is called from a
135 if System
.Tasking
.Detect_Blocking
136 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
138 Ada
.Exceptions
.Raise_Exception
139 (Program_Error
'Identity, "potentially blocking operation");
142 Initialization
.Defer_Abort_Nestable
(Self_Id
);
145 -- Really should not be nested deferral here.
146 -- Patch for code generation error that defers abort before
147 -- evaluating parameters of an entry call (at least, timed entry
148 -- calls), and so may propagate an exception that causes abort
149 -- to remain undeferred indefinitely. See C97404B. When all
150 -- such bugs are fixed, this patch can be removed.
154 for J
in Tasks
'Range loop
156 Abort_One_Task
(Self_Id
, C
);
162 if C
.Pending_ATC_Level
> 0 then
163 P
:= C
.Common
.Parent
;
166 if P
.Pending_ATC_Level
= 0 then
167 Abort_One_Task
(Self_Id
, C
);
171 P
:= P
.Common
.Parent
;
175 C
:= C
.Common
.All_Tasks_Link
;
179 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
182 -------------------------------
183 -- Cancel_Queued_Entry_Calls --
184 -------------------------------
186 -- This should only be called by T, unless T is a terminated previously
189 procedure Cancel_Queued_Entry_Calls
(T
: Task_Id
) is
190 Next_Entry_Call
: Entry_Call_Link
;
191 Entry_Call
: Entry_Call_Link
;
192 Self_Id
: constant Task_Id
:= STPO
.Self
;
195 pragma Unreferenced
(Caller
);
196 -- Should this be removed ???
199 pragma Unreferenced
(Level
);
200 -- Should this be removed ???
203 pragma Assert
(T
= Self
or else T
.Common
.State
= Terminated
);
205 for J
in 1 .. T
.Entry_Num
loop
206 Queuing
.Dequeue_Head
(T
.Entry_Queues
(J
), Entry_Call
);
208 while Entry_Call
/= null loop
210 -- Leave Entry_Call.Done = False, since this is cancelled
212 Caller
:= Entry_Call
.Self
;
213 Entry_Call
.Exception_To_Raise
:= Tasking_Error
'Identity;
214 Queuing
.Dequeue_Head
(T
.Entry_Queues
(J
), Next_Entry_Call
);
215 Level
:= Entry_Call
.Level
- 1;
217 Write_Lock
(Entry_Call
.Self
);
218 Initialization
.Wakeup_Entry_Caller
219 (Self_Id
, Entry_Call
, Cancelled
);
220 Unlock
(Entry_Call
.Self
);
222 Entry_Call
.State
:= Done
;
223 Entry_Call
:= Next_Entry_Call
;
226 end Cancel_Queued_Entry_Calls
;
228 ------------------------
229 -- Exit_One_ATC_Level --
230 ------------------------
232 -- Call only with abort deferred and holding lock of Self_Id.
233 -- This is a bit of common code for all entry calls.
234 -- The effect is to exit one level of ATC nesting.
236 -- If we have reached the desired ATC nesting level, reset the
237 -- requested level to effective infinity, to allow further calls.
238 -- In any case, reset Self_Id.Aborting, to allow re-raising of
241 procedure Exit_One_ATC_Level
(Self_ID
: Task_Id
) is
243 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
- 1;
246 (Debug
.Trace
(Self_ID
, "EOAL: exited to ATC level: " &
247 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
249 pragma Assert
(Self_ID
.ATC_Nesting_Level
>= 1);
251 if Self_ID
.Pending_ATC_Level
< ATC_Level_Infinity
then
252 if Self_ID
.Pending_ATC_Level
= Self_ID
.ATC_Nesting_Level
then
253 Self_ID
.Pending_ATC_Level
:= ATC_Level_Infinity
;
254 Self_ID
.Aborting
:= False;
256 -- Force the next Undefer_Abort to re-raise Abort_Signal
259 (Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
);
261 if Self_ID
.Aborting
then
262 Self_ID
.ATC_Hack
:= True;
263 Self_ID
.Pending_Action
:= True;
267 end Exit_One_ATC_Level
;
269 ----------------------
270 -- Make_Independent --
271 ----------------------
273 procedure Make_Independent
is
274 Self_Id
: constant Task_Id
:= STPO
.Self
;
275 Environment_Task
: constant Task_Id
:= STPO
.Environment_Task
;
276 Parent
: constant Task_Id
:= Self_Id
.Common
.Parent
;
277 Parent_Needs_Updating
: Boolean := False;
278 Master_of_Task
: Integer;
281 if Self_Id
.Known_Tasks_Index
/= -1 then
282 Known_Tasks
(Self_Id
.Known_Tasks_Index
) := null;
285 Initialization
.Defer_Abort
(Self_Id
);
291 Write_Lock
(Environment_Task
);
292 Write_Lock
(Self_Id
);
294 pragma Assert
(Parent
= Environment_Task
295 or else Self_Id
.Master_of_Task
= Library_Task_Level
);
297 Master_of_Task
:= Self_Id
.Master_of_Task
;
298 Self_Id
.Master_of_Task
:= Independent_Task_Level
;
300 -- The run time assumes that the parent of an independent task is the
303 if Parent
/= Environment_Task
then
305 -- We cannot lock three tasks at the same time, so defer the
306 -- operations on the parent.
308 Parent_Needs_Updating
:= True;
309 Self_Id
.Common
.Parent
:= Environment_Task
;
312 -- Update Independent_Task_Count that is needed for the GLADE
313 -- termination rule. See also pending update in
314 -- System.Tasking.Stages.Check_Independent
316 Independent_Task_Count
:= Independent_Task_Count
+ 1;
320 -- Changing the parent after creation is not trivial. Do not forget
321 -- to update the old parent counts, and the new parent (i.e. the
322 -- Environment_Task) counts.
324 if Parent_Needs_Updating
then
326 Parent
.Awake_Count
:= Parent
.Awake_Count
- 1;
327 Parent
.Alive_Count
:= Parent
.Alive_Count
- 1;
328 Environment_Task
.Awake_Count
:= Environment_Task
.Awake_Count
+ 1;
329 Environment_Task
.Alive_Count
:= Environment_Task
.Alive_Count
+ 1;
333 -- In case the environment task is already waiting for children to
335 -- ??? There may be a race condition if the environment task was not in
336 -- master completion sleep when this task was created, but now is
338 if Environment_Task
.Common
.State
= Master_Completion_Sleep
and then
339 Master_of_Task
= Environment_Task
.Master_Within
341 Environment_Task
.Common
.Wait_Count
:=
342 Environment_Task
.Common
.Wait_Count
- 1;
345 Unlock
(Environment_Task
);
351 Initialization
.Undefer_Abort
(Self_Id
);
352 end Make_Independent
;
358 procedure Make_Passive
(Self_ID
: Task_Id
; Task_Completed
: Boolean) is
359 C
: Task_Id
:= Self_ID
;
360 P
: Task_Id
:= C
.Common
.Parent
;
362 Master_Completion_Phase
: Integer;
371 if Task_Completed
then
372 Self_ID
.Common
.State
:= Terminated
;
374 if Self_ID
.Awake_Count
= 0 then
376 -- We are completing via a terminate alternative.
377 -- Our parent should wait in Phase 2 of Complete_Master.
379 Master_Completion_Phase
:= 2;
381 pragma Assert
(Task_Completed
);
382 pragma Assert
(Self_ID
.Terminate_Alternative
);
383 pragma Assert
(Self_ID
.Alive_Count
= 1);
386 -- We are NOT on a terminate alternative.
387 -- Our parent should wait in Phase 1 of Complete_Master.
389 Master_Completion_Phase
:= 1;
390 pragma Assert
(Self_ID
.Awake_Count
= 1);
393 -- We are accepting with a terminate alternative
396 if Self_ID
.Open_Accepts
= null then
398 -- Somebody started a rendezvous while we had our lock open.
399 -- Skip the terminate alternative.
410 Self_ID
.Terminate_Alternative
:= True;
411 Master_Completion_Phase
:= 0;
413 pragma Assert
(Self_ID
.Terminate_Alternative
);
414 pragma Assert
(Self_ID
.Awake_Count
>= 1);
417 if Master_Completion_Phase
= 2 then
419 -- Since our Awake_Count is zero but our Alive_Count
420 -- is nonzero, we have been accepting with a terminate
421 -- alternative, and we now have been told to terminate
422 -- by a completed master (in some ancestor task) that
423 -- is waiting (with zero Awake_Count) in Phase 2 of
426 pragma Debug
(Debug
.Trace
(Self_ID
, "Make_Passive: Phase 2", 'M'));
428 pragma Assert
(P
/= null);
430 C
.Alive_Count
:= C
.Alive_Count
- 1;
432 if C
.Alive_Count
> 0 then
438 -- C's count just went to zero, indicating that
439 -- all of C's dependents are terminated.
440 -- C has a parent, P.
443 -- C's count just went to zero, indicating that all of C's
444 -- dependents are terminated. C has a parent, P. Notify P that
445 -- C and its dependents have all terminated.
447 P
.Alive_Count
:= P
.Alive_Count
- 1;
448 exit when P
.Alive_Count
> 0;
452 P
:= C
.Common
.Parent
;
454 -- Environment task cannot have terminated yet
456 pragma Assert
(P
/= null);
462 pragma Assert
(P
.Awake_Count
/= 0);
464 if P
.Common
.State
= Master_Phase_2_Sleep
465 and then C
.Master_of_Task
= P
.Master_Within
467 pragma Assert
(P
.Common
.Wait_Count
> 0);
468 P
.Common
.Wait_Count
:= P
.Common
.Wait_Count
- 1;
470 if P
.Common
.Wait_Count
= 0 then
471 Wakeup
(P
, Master_Phase_2_Sleep
);
480 -- We are terminating in Phase 1 or Complete_Master,
481 -- or are accepting on a terminate alternative.
483 C
.Awake_Count
:= C
.Awake_Count
- 1;
485 if Task_Completed
then
486 pragma Assert
(Self_ID
.Awake_Count
= 0);
487 C
.Alive_Count
:= C
.Alive_Count
- 1;
490 if C
.Awake_Count
> 0 or else P
= null then
500 -- C's count just went to zero, indicating that all of C's
501 -- dependents are terminated or accepting with terminate alt.
502 -- C has a parent, P.
505 -- Notify P that C has gone passive
507 P
.Awake_Count
:= P
.Awake_Count
- 1;
509 if Task_Completed
and then C
.Alive_Count
= 0 then
510 P
.Alive_Count
:= P
.Alive_Count
- 1;
513 exit when P
.Awake_Count
> 0;
517 P
:= C
.Common
.Parent
;
527 -- P has non-passive dependents
529 if P
.Common
.State
= Master_Completion_Sleep
530 and then C
.Master_of_Task
= P
.Master_Within
534 (Self_ID
, "Make_Passive: Phase 1, parent waiting", 'M'));
536 -- If parent is in Master_Completion_Sleep, it
537 -- cannot be on a terminate alternative, hence
538 -- it cannot have Awake_Count of zero.
540 pragma Assert
(P
.Common
.Wait_Count
> 0);
541 P
.Common
.Wait_Count
:= P
.Common
.Wait_Count
- 1;
543 if P
.Common
.Wait_Count
= 0 then
544 Wakeup
(P
, Master_Completion_Sleep
);
550 (Self_ID
, "Make_Passive: Phase 1, parent awake", 'M'));
558 end System
.Tasking
.Utilities
;