| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
| -- -- |
| -- S Y S T E M . T A S K I N G . U T I L I T I E S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNARL is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNARL was developed by the GNARL team at Florida State University. -- |
| -- Extensive contributions were provided by Ada Core Technologies, Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- This package provides RTS Internal Declarations |
| |
| -- These declarations are not part of the GNARLI |
| |
| with System.Tasking.Debug; |
| with System.Task_Primitives.Operations; |
| with System.Tasking.Initialization; |
| with System.Tasking.Queuing; |
| |
| package body System.Tasking.Utilities is |
| |
| package STPO renames System.Task_Primitives.Operations; |
| |
| use Tasking.Debug; |
| use Task_Primitives; |
| use Task_Primitives.Operations; |
| |
| -------------------- |
| -- Abort_One_Task -- |
| -------------------- |
| |
| -- Similar to Locked_Abort_To_Level (Self_ID, T, Level_Completed_Task), |
| -- but: |
| -- (1) caller should be holding no locks |
| -- (2) may be called for tasks that have not yet been activated |
| -- (3) always aborts whole task |
| |
| procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is |
| begin |
| Write_Lock (T); |
| |
| if T.Common.State = Unactivated then |
| T.Common.Activator := null; |
| T.Common.State := Terminated; |
| T.Callable := False; |
| Cancel_Queued_Entry_Calls (T); |
| |
| elsif T.Common.State /= Terminated then |
| Initialization.Locked_Abort_To_Level |
| (Self_ID, T, Level_Completed_Task); |
| end if; |
| |
| Unlock (T); |
| end Abort_One_Task; |
| |
| ----------------- |
| -- Abort_Tasks -- |
| ----------------- |
| |
| -- This must be called to implement the abort statement. |
| -- Much of the actual work of the abort is done by the abortee, |
| -- via the Abort_Handler signal handler, and propagation of the |
| -- Abort_Signal special exception. |
| |
| procedure Abort_Tasks (Tasks : Task_List) is |
| Self_Id : constant Task_Id := STPO.Self; |
| C : Task_Id; |
| P : Task_Id; |
| |
| begin |
| -- If pragma Detect_Blocking is active then Program_Error must be |
| -- raised if this potentially blocking operation is called from a |
| -- protected action. |
| |
| if System.Tasking.Detect_Blocking |
| and then Self_Id.Common.Protected_Action_Nesting > 0 |
| then |
| raise Program_Error with "potentially blocking operation"; |
| end if; |
| |
| Initialization.Defer_Abort_Nestable (Self_Id); |
| |
| -- ????? |
| -- Really should not be nested deferral here. |
| -- Patch for code generation error that defers abort before |
| -- evaluating parameters of an entry call (at least, timed entry |
| -- calls), and so may propagate an exception that causes abort |
| -- to remain undeferred indefinitely. See C97404B. When all |
| -- such bugs are fixed, this patch can be removed. |
| |
| Lock_RTS; |
| |
| for J in Tasks'Range loop |
| C := Tasks (J); |
| Abort_One_Task (Self_Id, C); |
| end loop; |
| |
| C := All_Tasks_List; |
| |
| while C /= null loop |
| if C.Pending_ATC_Level > Level_Completed_Task then |
| P := C.Common.Parent; |
| |
| while P /= null loop |
| if P.Pending_ATC_Level = Level_Completed_Task then |
| Abort_One_Task (Self_Id, C); |
| exit; |
| end if; |
| |
| P := P.Common.Parent; |
| end loop; |
| end if; |
| |
| C := C.Common.All_Tasks_Link; |
| end loop; |
| |
| Unlock_RTS; |
| Initialization.Undefer_Abort_Nestable (Self_Id); |
| end Abort_Tasks; |
| |
| ------------------------------- |
| -- Cancel_Queued_Entry_Calls -- |
| ------------------------------- |
| |
| -- This should only be called by T, unless T is a terminated previously |
| -- unactivated task. |
| |
| procedure Cancel_Queued_Entry_Calls (T : Task_Id) is |
| Next_Entry_Call : Entry_Call_Link; |
| Entry_Call : Entry_Call_Link; |
| Self_Id : constant Task_Id := STPO.Self; |
| |
| Caller : Task_Id; |
| pragma Unreferenced (Caller); |
| -- Should this be removed ??? |
| |
| Level : Integer; |
| pragma Unreferenced (Level); |
| -- Should this be removed ??? |
| |
| begin |
| pragma Assert (T = Self or else T.Common.State = Terminated); |
| |
| for J in 1 .. T.Entry_Num loop |
| Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call); |
| |
| while Entry_Call /= null loop |
| |
| -- Leave Entry_Call.Done = False, since this is cancelled |
| |
| Caller := Entry_Call.Self; |
| Entry_Call.Exception_To_Raise := Tasking_Error'Identity; |
| Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call); |
| Level := Entry_Call.Level - 1; |
| Unlock (T); |
| Write_Lock (Entry_Call.Self); |
| Initialization.Wakeup_Entry_Caller |
| (Self_Id, Entry_Call, Cancelled); |
| Unlock (Entry_Call.Self); |
| Write_Lock (T); |
| Entry_Call.State := Done; |
| Entry_Call := Next_Entry_Call; |
| end loop; |
| end loop; |
| end Cancel_Queued_Entry_Calls; |
| |
| ------------------------ |
| -- Exit_One_ATC_Level -- |
| ------------------------ |
| |
| -- Call only with abort deferred and holding lock of Self_Id. |
| -- This is a bit of common code for all entry calls. |
| -- The effect is to exit one level of ATC nesting. |
| |
| -- If we have reached the desired ATC nesting level, reset the |
| -- requested level to effective infinity, to allow further calls. |
| -- In any case, reset Self_Id.Aborting, to allow re-raising of |
| -- Abort_Signal. |
| |
| procedure Exit_One_ATC_Level (Self_ID : Task_Id) is |
| begin |
| pragma Assert (Self_ID.ATC_Nesting_Level > Level_No_ATC_Occurring); |
| |
| Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; |
| |
| pragma Debug |
| (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " & |
| ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); |
| |
| if Self_ID.Pending_ATC_Level < Level_No_Pending_Abort then |
| |
| if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then |
| Self_ID.Pending_ATC_Level := Level_No_Pending_Abort; |
| Self_ID.Aborting := False; |
| else |
| -- Force the next Undefer_Abort to re-raise Abort_Signal |
| |
| pragma Assert |
| (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level); |
| |
| if Self_ID.Aborting then |
| Self_ID.ATC_Hack := True; |
| Self_ID.Pending_Action := True; |
| end if; |
| end if; |
| end if; |
| end Exit_One_ATC_Level; |
| |
| ---------------------- |
| -- Make_Independent -- |
| ---------------------- |
| |
| function Make_Independent return Boolean is |
| Self_Id : constant Task_Id := STPO.Self; |
| Environment_Task : constant Task_Id := STPO.Environment_Task; |
| Parent : constant Task_Id := Self_Id.Common.Parent; |
| |
| begin |
| if Self_Id.Known_Tasks_Index /= -1 then |
| Known_Tasks (Self_Id.Known_Tasks_Index) := null; |
| end if; |
| |
| Initialization.Defer_Abort (Self_Id); |
| Write_Lock (Environment_Task); |
| Write_Lock (Self_Id); |
| |
| -- The run time assumes that the parent of an independent task is the |
| -- environment task. |
| |
| pragma Assert (Parent = Environment_Task); |
| |
| Self_Id.Master_Of_Task := Independent_Task_Level; |
| |
| -- Update Independent_Task_Count that is needed for the GLADE |
| -- termination rule. See also pending update in |
| -- System.Tasking.Stages.Check_Independent |
| |
| Independent_Task_Count := Independent_Task_Count + 1; |
| |
| -- This should be called before the task reaches its "begin" (see spec), |
| -- which ensures that the environment task cannot race ahead and be |
| -- already waiting for children to complete. |
| |
| Unlock (Self_Id); |
| pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep); |
| |
| Unlock (Environment_Task); |
| Initialization.Undefer_Abort (Self_Id); |
| |
| -- Return True. Actually the return value is junk, since we expect it |
| -- always to be ignored (see spec), but we have to return something! |
| |
| return True; |
| end Make_Independent; |
| |
| ------------------ |
| -- Make_Passive -- |
| ------------------ |
| |
| procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is |
| C : Task_Id := Self_ID; |
| P : Task_Id := C.Common.Parent; |
| |
| Master_Completion_Phase : Integer; |
| |
| begin |
| if P /= null then |
| Write_Lock (P); |
| end if; |
| |
| Write_Lock (C); |
| |
| if Task_Completed then |
| Self_ID.Common.State := Terminated; |
| |
| if Self_ID.Awake_Count = 0 then |
| |
| -- We are completing via a terminate alternative. |
| -- Our parent should wait in Phase 2 of Complete_Master. |
| |
| Master_Completion_Phase := 2; |
| |
| pragma Assert (Task_Completed); |
| pragma Assert (Self_ID.Terminate_Alternative); |
| pragma Assert (Self_ID.Alive_Count = 1); |
| |
| else |
| -- We are NOT on a terminate alternative. |
| -- Our parent should wait in Phase 1 of Complete_Master. |
| |
| Master_Completion_Phase := 1; |
| pragma Assert (Self_ID.Awake_Count >= 1); |
| end if; |
| |
| -- We are accepting with a terminate alternative |
| |
| else |
| if Self_ID.Open_Accepts = null then |
| |
| -- Somebody started a rendezvous while we had our lock open. |
| -- Skip the terminate alternative. |
| |
| Unlock (C); |
| |
| if P /= null then |
| Unlock (P); |
| end if; |
| |
| return; |
| end if; |
| |
| Self_ID.Terminate_Alternative := True; |
| Master_Completion_Phase := 0; |
| |
| pragma Assert (Self_ID.Terminate_Alternative); |
| pragma Assert (Self_ID.Awake_Count >= 1); |
| end if; |
| |
| if Master_Completion_Phase = 2 then |
| |
| -- Since our Awake_Count is zero but our Alive_Count |
| -- is nonzero, we have been accepting with a terminate |
| -- alternative, and we now have been told to terminate |
| -- by a completed master (in some ancestor task) that |
| -- is waiting (with zero Awake_Count) in Phase 2 of |
| -- Complete_Master. |
| |
| pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); |
| |
| pragma Assert (P /= null); |
| |
| C.Alive_Count := C.Alive_Count - 1; |
| |
| if C.Alive_Count > 0 then |
| Unlock (C); |
| Unlock (P); |
| return; |
| end if; |
| |
| -- C's count just went to zero, indicating that |
| -- all of C's dependents are terminated. |
| -- C has a parent, P. |
| |
| loop |
| -- C's count just went to zero, indicating that all of C's |
| -- dependents are terminated. C has a parent, P. Notify P that |
| -- C and its dependents have all terminated. |
| |
| P.Alive_Count := P.Alive_Count - 1; |
| exit when P.Alive_Count > 0; |
| Unlock (C); |
| Unlock (P); |
| C := P; |
| P := C.Common.Parent; |
| |
| -- Environment task cannot have terminated yet |
| |
| pragma Assert (P /= null); |
| |
| Write_Lock (P); |
| Write_Lock (C); |
| end loop; |
| |
| if P.Common.State = Master_Phase_2_Sleep |
| and then C.Master_Of_Task = P.Master_Within |
| then |
| pragma Assert (P.Common.Wait_Count > 0); |
| P.Common.Wait_Count := P.Common.Wait_Count - 1; |
| |
| if P.Common.Wait_Count = 0 then |
| Wakeup (P, Master_Phase_2_Sleep); |
| end if; |
| end if; |
| |
| Unlock (C); |
| Unlock (P); |
| return; |
| end if; |
| |
| -- We are terminating in Phase 1 or Complete_Master, |
| -- or are accepting on a terminate alternative. |
| |
| C.Awake_Count := C.Awake_Count - 1; |
| |
| if Task_Completed then |
| C.Alive_Count := C.Alive_Count - 1; |
| end if; |
| |
| if C.Awake_Count > 0 or else P = null then |
| Unlock (C); |
| |
| if P /= null then |
| Unlock (P); |
| end if; |
| |
| return; |
| end if; |
| |
| -- C's count just went to zero, indicating that all of C's |
| -- dependents are terminated or accepting with terminate alt. |
| -- C has a parent, P. |
| |
| loop |
| -- Notify P that C has gone passive |
| |
| if P.Awake_Count > 0 then |
| P.Awake_Count := P.Awake_Count - 1; |
| end if; |
| |
| if Task_Completed and then C.Alive_Count = 0 then |
| P.Alive_Count := P.Alive_Count - 1; |
| end if; |
| |
| exit when P.Awake_Count > 0; |
| Unlock (C); |
| Unlock (P); |
| C := P; |
| P := C.Common.Parent; |
| |
| if P = null then |
| return; |
| end if; |
| |
| Write_Lock (P); |
| Write_Lock (C); |
| end loop; |
| |
| -- P has non-passive dependents |
| |
| if P.Common.State = Master_Completion_Sleep |
| and then C.Master_Of_Task = P.Master_Within |
| then |
| pragma Debug |
| (Debug.Trace |
| (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); |
| |
| -- If parent is in Master_Completion_Sleep, it cannot be on a |
| -- terminate alternative, hence it cannot have Wait_Count of zero. |
| |
| pragma Assert (P.Common.Wait_Count > 0); |
| P.Common.Wait_Count := P.Common.Wait_Count - 1; |
| |
| if P.Common.Wait_Count = 0 then |
| Wakeup (P, Master_Completion_Sleep); |
| end if; |
| |
| else |
| pragma Debug |
| (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); |
| null; |
| end if; |
| |
| Unlock (C); |
| Unlock (P); |
| end Make_Passive; |
| |
| end System.Tasking.Utilities; |
