+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA 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 --
--- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 1991-2001, Florida State University --
--- --
--- 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 2, or (at your option) any later ver- --
--- sion. GNARL 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This package provides RTS Internal Declarations.
--- These declarations are not part of the GNARLI
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with System.Tasking.Debug;
--- used for Known_Tasks
-
-with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Set_Priority
--- Wakeup
--- Unlock
--- Sleep
--- Abort_Task
--- Lock/Unlock_All_Tasks_List
-
-with System.Tasking.Initialization;
--- Used for Defer_Abort
--- Undefer_Abort
--- Locked_Abort_To_Level
-
-with System.Tasking.Queuing;
--- used for Dequeue_Call
--- Dequeue_Head
-
-with System.Tasking.Debug;
--- used for Trace
-
-with Unchecked_Conversion;
-
-package body System.Tasking.Utilities is
-
- package STPO renames System.Task_Primitives.Operations;
-
- use System.Tasking.Debug;
- use System.Task_Primitives;
- use System.Task_Primitives.Operations;
-
- procedure Locked_Abort_To_Level
- (Self_Id : Task_ID;
- T : Task_ID;
- L : ATC_Level)
- renames
- Initialization.Locked_Abort_To_Level;
-
- procedure Defer_Abort (Self_Id : Task_ID) renames
- System.Tasking.Initialization.Defer_Abort;
-
- procedure Defer_Abort_Nestable (Self_Id : Task_ID) renames
- System.Tasking.Initialization.Defer_Abort_Nestable;
-
- procedure Undefer_Abort (Self_Id : Task_ID) renames
- System.Tasking.Initialization.Undefer_Abort;
-
- procedure Undefer_Abort_Nestable (Self_Id : Task_ID) renames
- System.Tasking.Initialization.Undefer_Abort_Nestable;
-
- procedure Wakeup_Entry_Caller
- (Self_Id : Task_ID;
- Entry_Call : Entry_Call_Link;
- New_State : Entry_Call_State)
- renames
- Initialization.Wakeup_Entry_Caller;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), 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
- Locked_Abort_To_Level (Self_ID, T, 0);
- end if;
-
- Unlock (T);
- end Abort_One_Task;
-
- -----------------
- -- Abort_Tasks --
- -----------------
-
- -- Compiler interface only: Do not call from within the RTS,
-
- -- except in the implementation of Ada.Task_Identification.
- -- 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
- -- ????
- -- Since this is a "potentially blocking operation", we should
- -- add a separate check here that we are not inside a protected
- -- operation.
-
- 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.
-
- for J in Tasks'Range loop
- C := Tasks (J);
- Abort_One_Task (Self_Id, C);
- end loop;
-
- Lock_All_Tasks_List;
- C := All_Tasks_List;
-
- while C /= null loop
- if C.Pending_ATC_Level > 0 then
- P := C.Common.Parent;
-
- while P /= null loop
- if P.Pending_ATC_Level = 0 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_All_Tasks_List;
- Undefer_Abort_Nestable (Self_Id);
- end Abort_Tasks;
-
- -------------------------------
- -- Cancel_Queued_Entry_Calls --
- -------------------------------
-
- -- Cancel any entry calls queued on target task. Call this only while
- -- holding T locked, and nothing more. 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;
- Caller : Task_ID;
- Level : Integer;
- Self_Id : constant Task_ID := STPO.Self;
-
- 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);
- 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
- 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'));
-
- pragma Assert (Self_ID.ATC_Nesting_Level >= 1);
-
- if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then
- if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then
- Self_ID.Pending_ATC_Level := ATC_Level_Infinity;
- 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 --
- ----------------------
-
- -- Move the current task to the outermost level (level 2) of the master
- -- hierarchy of the environment task. That is one level further out
- -- than normal tasks defined in library-level packages (level 3). The
- -- environment task will wait for level 3 tasks to terminate normally,
- -- then it will abort all the level 2 tasks. See Finalize_Global_Tasks
- -- procedure for more information.
-
- -- This is a dangerous operation, and should only be used on nested tasks
- -- or tasks that depend on any objects that might be finalized earlier than
- -- the termination of the environment task. It is for internal use by the
- -- GNARL, to prevent such internal server tasks from preventing a partition
- -- from terminating.
-
- -- Also note that the run time assumes that the parent of an independent
- -- task is the environment task. If this is not the case, Make_Independent
- -- will change the task's parent. This assumption is particularly
- -- important for master level completion and for the computation of
- -- Independent_Task_Count.
-
- -- See procedures Init_RTS and Finalize_Global_Tasks for related code.
-
- procedure Make_Independent is
- Self_Id : constant Task_ID := STPO.Self;
- Environment_Task : constant Task_ID := STPO.Environment_Task;
- Parent : constant Task_ID := Self_Id.Common.Parent;
- Parent_Needs_Updating : Boolean := False;
-
- begin
- if Self_Id.Known_Tasks_Index /= -1 then
- Known_Tasks (Self_Id.Known_Tasks_Index) := null;
- end if;
-
- Defer_Abort (Self_Id);
- Write_Lock (Environment_Task);
- Write_Lock (Self_Id);
-
- pragma Assert (Parent = Environment_Task
- or else Self_Id.Master_of_Task = Library_Task_Level);
-
- Self_Id.Master_of_Task := Independent_Task_Level;
-
- -- The run time assumes that the parent of an independent task is the
- -- environment task.
-
- if Parent /= Environment_Task then
-
- -- We can not lock three tasks at the same time, so defer the
- -- operations on the parent.
-
- Parent_Needs_Updating := True;
- Self_Id.Common.Parent := Environment_Task;
- end if;
-
- -- 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;
-
- Unlock (Self_Id);
-
- -- Changing the parent after creation is not trivial. Do not forget
- -- to update the old parent counts, and the new parent (i.e. the
- -- Environment_Task) counts.
-
- if Parent_Needs_Updating then
- Write_Lock (Parent);
- Parent.Awake_Count := Parent.Awake_Count - 1;
- Parent.Alive_Count := Parent.Alive_Count - 1;
- Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1;
- Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1;
- Unlock (Parent);
- end if;
-
- Unlock (Environment_Task);
- Undefer_Abort (Self_Id);
- end Make_Independent;
-
- ------------------
- -- Make_Passive --
- ------------------
-
- -- Update counts to indicate current task is either terminated
- -- or accepting on a terminate alternative. Call holding no locks.
-
- 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;
-
- pragma Assert (P.Awake_Count /= 0);
-
- 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
- pragma Assert (Self_ID.Awake_Count = 0);
- 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.
-
- P.Awake_Count := P.Awake_Count - 1;
-
- 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 Awake_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;
projects / msp430-gcc.git / blobdiff