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