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