File : s-tasuti.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K I N G . U T I L I T I E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This package provides RTS Internal Declarations
33
34 -- These declarations are not part of the GNARLI
35
36 pragma Polling (Off);
37 -- Turn off polling, we do not want ATC polling to take place during tasking
38 -- operations. It causes infinite loops and other problems.
39
40 with System.Tasking.Debug;
41 with System.Task_Primitives.Operations;
42 with System.Tasking.Initialization;
43 with System.Tasking.Queuing;
44 with System.Parameters;
45 with System.Traces.Tasking;
46
47 package body System.Tasking.Utilities is
48
49 package STPO renames System.Task_Primitives.Operations;
50
51 use Parameters;
52 use Tasking.Debug;
53 use Task_Primitives;
54 use Task_Primitives.Operations;
55
56 use System.Traces;
57 use System.Traces.Tasking;
58
59 --------------------
60 -- Abort_One_Task --
61 --------------------
62
63 -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:
64 -- (1) caller should be holding no locks except RTS_Lock when Single_Lock
65 -- (2) may be called for tasks that have not yet been activated
66 -- (3) always aborts whole task
67
68 procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is
69 begin
70 if Parameters.Runtime_Traces then
71 Send_Trace_Info (T_Abort, Self_ID, T);
72 end if;
73
74 Write_Lock (T);
75
76 if T.Common.State = Unactivated then
77 T.Common.Activator := null;
78 T.Common.State := Terminated;
79 T.Callable := False;
80 Cancel_Queued_Entry_Calls (T);
81
82 elsif T.Common.State /= Terminated then
83 Initialization.Locked_Abort_To_Level (Self_ID, T, 0);
84 end if;
85
86 Unlock (T);
87 end Abort_One_Task;
88
89 -----------------
90 -- Abort_Tasks --
91 -----------------
92
93 -- This must be called to implement the abort statement.
94 -- Much of the actual work of the abort is done by the abortee,
95 -- via the Abort_Handler signal handler, and propagation of the
96 -- Abort_Signal special exception.
97
98 procedure Abort_Tasks (Tasks : Task_List) is
99 Self_Id : constant Task_Id := STPO.Self;
100 C : Task_Id;
101 P : Task_Id;
102
103 begin
104 -- If pragma Detect_Blocking is active then Program_Error must be
105 -- raised if this potentially blocking operation is called from a
106 -- protected action.
107
108 if System.Tasking.Detect_Blocking
109 and then Self_Id.Common.Protected_Action_Nesting > 0
110 then
111 raise Program_Error with "potentially blocking operation";
112 end if;
113
114 Initialization.Defer_Abort_Nestable (Self_Id);
115
116 -- ?????
117 -- Really should not be nested deferral here.
118 -- Patch for code generation error that defers abort before
119 -- evaluating parameters of an entry call (at least, timed entry
120 -- calls), and so may propagate an exception that causes abort
121 -- to remain undeferred indefinitely. See C97404B. When all
122 -- such bugs are fixed, this patch can be removed.
123
124 Lock_RTS;
125
126 for J in Tasks'Range loop
127 C := Tasks (J);
128 Abort_One_Task (Self_Id, C);
129 end loop;
130
131 C := All_Tasks_List;
132
133 while C /= null loop
134 if C.Pending_ATC_Level > 0 then
135 P := C.Common.Parent;
136
137 while P /= null loop
138 if P.Pending_ATC_Level = 0 then
139 Abort_One_Task (Self_Id, C);
140 exit;
141 end if;
142
143 P := P.Common.Parent;
144 end loop;
145 end if;
146
147 C := C.Common.All_Tasks_Link;
148 end loop;
149
150 Unlock_RTS;
151 Initialization.Undefer_Abort_Nestable (Self_Id);
152 end Abort_Tasks;
153
154 -------------------------------
155 -- Cancel_Queued_Entry_Calls --
156 -------------------------------
157
158 -- This should only be called by T, unless T is a terminated previously
159 -- unactivated task.
160
161 procedure Cancel_Queued_Entry_Calls (T : Task_Id) is
162 Next_Entry_Call : Entry_Call_Link;
163 Entry_Call : Entry_Call_Link;
164 Self_Id : constant Task_Id := STPO.Self;
165
166 Caller : Task_Id;
167 pragma Unreferenced (Caller);
168 -- Should this be removed ???
169
170 Level : Integer;
171 pragma Unreferenced (Level);
172 -- Should this be removed ???
173
174 begin
175 pragma Assert (T = Self or else T.Common.State = Terminated);
176
177 for J in 1 .. T.Entry_Num loop
178 Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call);
179
180 while Entry_Call /= null loop
181
182 -- Leave Entry_Call.Done = False, since this is cancelled
183
184 Caller := Entry_Call.Self;
185 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
186 Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call);
187 Level := Entry_Call.Level - 1;
188 Unlock (T);
189 Write_Lock (Entry_Call.Self);
190 Initialization.Wakeup_Entry_Caller
191 (Self_Id, Entry_Call, Cancelled);
192 Unlock (Entry_Call.Self);
193 Write_Lock (T);
194 Entry_Call.State := Done;
195 Entry_Call := Next_Entry_Call;
196 end loop;
197 end loop;
198 end Cancel_Queued_Entry_Calls;
199
200 ------------------------
201 -- Exit_One_ATC_Level --
202 ------------------------
203
204 -- Call only with abort deferred and holding lock of Self_Id.
205 -- This is a bit of common code for all entry calls.
206 -- The effect is to exit one level of ATC nesting.
207
208 -- If we have reached the desired ATC nesting level, reset the
209 -- requested level to effective infinity, to allow further calls.
210 -- In any case, reset Self_Id.Aborting, to allow re-raising of
211 -- Abort_Signal.
212
213 procedure Exit_One_ATC_Level (Self_ID : Task_Id) is
214 begin
215 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
216
217 pragma Debug
218 (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " &
219 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
220
221 pragma Assert (Self_ID.ATC_Nesting_Level >= 1);
222
223 if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then
224 if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then
225 Self_ID.Pending_ATC_Level := ATC_Level_Infinity;
226 Self_ID.Aborting := False;
227 else
228 -- Force the next Undefer_Abort to re-raise Abort_Signal
229
230 pragma Assert
231 (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level);
232
233 if Self_ID.Aborting then
234 Self_ID.ATC_Hack := True;
235 Self_ID.Pending_Action := True;
236 end if;
237 end if;
238 end if;
239 end Exit_One_ATC_Level;
240
241 ----------------------
242 -- Make_Independent --
243 ----------------------
244
245 function Make_Independent return Boolean is
246 Self_Id : constant Task_Id := STPO.Self;
247 Environment_Task : constant Task_Id := STPO.Environment_Task;
248 Parent : constant Task_Id := Self_Id.Common.Parent;
249
250 begin
251 if Self_Id.Known_Tasks_Index /= -1 then
252 Known_Tasks (Self_Id.Known_Tasks_Index) := null;
253 end if;
254
255 Initialization.Defer_Abort (Self_Id);
256
257 if Single_Lock then
258 Lock_RTS;
259 end if;
260
261 Write_Lock (Environment_Task);
262 Write_Lock (Self_Id);
263
264 -- The run time assumes that the parent of an independent task is the
265 -- environment task.
266
267 pragma Assert (Parent = Environment_Task);
268
269 Self_Id.Master_of_Task := Independent_Task_Level;
270
271 -- Update Independent_Task_Count that is needed for the GLADE
272 -- termination rule. See also pending update in
273 -- System.Tasking.Stages.Check_Independent
274
275 Independent_Task_Count := Independent_Task_Count + 1;
276
277 -- This should be called before the task reaches its "begin" (see spec),
278 -- which ensures that the environment task cannot race ahead and be
279 -- already waiting for children to complete.
280
281 Unlock (Self_Id);
282 pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep);
283
284 Unlock (Environment_Task);
285
286 if Single_Lock then
287 Unlock_RTS;
288 end if;
289
290 Initialization.Undefer_Abort (Self_Id);
291
292 -- Return True. Actually the return value is junk, since we expect it
293 -- always to be ignored (see spec), but we have to return something!
294
295 return True;
296 end Make_Independent;
297
298 ------------------
299 -- Make_Passive --
300 ------------------
301
302 procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is
303 C : Task_Id := Self_ID;
304 P : Task_Id := C.Common.Parent;
305
306 Master_Completion_Phase : Integer;
307
308 begin
309 if P /= null then
310 Write_Lock (P);
311 end if;
312
313 Write_Lock (C);
314
315 if Task_Completed then
316 Self_ID.Common.State := Terminated;
317
318 if Self_ID.Awake_Count = 0 then
319
320 -- We are completing via a terminate alternative.
321 -- Our parent should wait in Phase 2 of Complete_Master.
322
323 Master_Completion_Phase := 2;
324
325 pragma Assert (Task_Completed);
326 pragma Assert (Self_ID.Terminate_Alternative);
327 pragma Assert (Self_ID.Alive_Count = 1);
328
329 else
330 -- We are NOT on a terminate alternative.
331 -- Our parent should wait in Phase 1 of Complete_Master.
332
333 Master_Completion_Phase := 1;
334 pragma Assert (Self_ID.Awake_Count >= 1);
335 end if;
336
337 -- We are accepting with a terminate alternative
338
339 else
340 if Self_ID.Open_Accepts = null then
341
342 -- Somebody started a rendezvous while we had our lock open.
343 -- Skip the terminate alternative.
344
345 Unlock (C);
346
347 if P /= null then
348 Unlock (P);
349 end if;
350
351 return;
352 end if;
353
354 Self_ID.Terminate_Alternative := True;
355 Master_Completion_Phase := 0;
356
357 pragma Assert (Self_ID.Terminate_Alternative);
358 pragma Assert (Self_ID.Awake_Count >= 1);
359 end if;
360
361 if Master_Completion_Phase = 2 then
362
363 -- Since our Awake_Count is zero but our Alive_Count
364 -- is nonzero, we have been accepting with a terminate
365 -- alternative, and we now have been told to terminate
366 -- by a completed master (in some ancestor task) that
367 -- is waiting (with zero Awake_Count) in Phase 2 of
368 -- Complete_Master.
369
370 pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M'));
371
372 pragma Assert (P /= null);
373
374 C.Alive_Count := C.Alive_Count - 1;
375
376 if C.Alive_Count > 0 then
377 Unlock (C);
378 Unlock (P);
379 return;
380 end if;
381
382 -- C's count just went to zero, indicating that
383 -- all of C's dependents are terminated.
384 -- C has a parent, P.
385
386 loop
387 -- C's count just went to zero, indicating that all of C's
388 -- dependents are terminated. C has a parent, P. Notify P that
389 -- C and its dependents have all terminated.
390
391 P.Alive_Count := P.Alive_Count - 1;
392 exit when P.Alive_Count > 0;
393 Unlock (C);
394 Unlock (P);
395 C := P;
396 P := C.Common.Parent;
397
398 -- Environment task cannot have terminated yet
399
400 pragma Assert (P /= null);
401
402 Write_Lock (P);
403 Write_Lock (C);
404 end loop;
405
406 if P.Common.State = Master_Phase_2_Sleep
407 and then C.Master_of_Task = P.Master_Within
408 then
409 pragma Assert (P.Common.Wait_Count > 0);
410 P.Common.Wait_Count := P.Common.Wait_Count - 1;
411
412 if P.Common.Wait_Count = 0 then
413 Wakeup (P, Master_Phase_2_Sleep);
414 end if;
415 end if;
416
417 Unlock (C);
418 Unlock (P);
419 return;
420 end if;
421
422 -- We are terminating in Phase 1 or Complete_Master,
423 -- or are accepting on a terminate alternative.
424
425 C.Awake_Count := C.Awake_Count - 1;
426
427 if Task_Completed then
428 C.Alive_Count := C.Alive_Count - 1;
429 end if;
430
431 if C.Awake_Count > 0 or else P = null then
432 Unlock (C);
433
434 if P /= null then
435 Unlock (P);
436 end if;
437
438 return;
439 end if;
440
441 -- C's count just went to zero, indicating that all of C's
442 -- dependents are terminated or accepting with terminate alt.
443 -- C has a parent, P.
444
445 loop
446 -- Notify P that C has gone passive
447
448 if P.Awake_Count > 0 then
449 P.Awake_Count := P.Awake_Count - 1;
450 end if;
451
452 if Task_Completed and then C.Alive_Count = 0 then
453 P.Alive_Count := P.Alive_Count - 1;
454 end if;
455
456 exit when P.Awake_Count > 0;
457 Unlock (C);
458 Unlock (P);
459 C := P;
460 P := C.Common.Parent;
461
462 if P = null then
463 return;
464 end if;
465
466 Write_Lock (P);
467 Write_Lock (C);
468 end loop;
469
470 -- P has non-passive dependents
471
472 if P.Common.State = Master_Completion_Sleep
473 and then C.Master_of_Task = P.Master_Within
474 then
475 pragma Debug
476 (Debug.Trace
477 (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M'));
478
479 -- If parent is in Master_Completion_Sleep, it cannot be on a
480 -- terminate alternative, hence it cannot have Wait_Count of zero.
481
482 pragma Assert (P.Common.Wait_Count > 0);
483 P.Common.Wait_Count := P.Common.Wait_Count - 1;
484
485 if P.Common.Wait_Count = 0 then
486 Wakeup (P, Master_Completion_Sleep);
487 end if;
488
489 else
490 pragma Debug
491 (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
492 null;
493 end if;
494
495 Unlock (C);
496 Unlock (P);
497 end Make_Passive;
498
499 end System.Tasking.Utilities;