home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
adav313.zip
/
gnat-3_13p-os2-bin-20010916.zip
/
emx
/
gnatlib
/
s-tasuti.adb
< prev
next >
Wrap
Text File
|
2000-07-19
|
19KB
|
571 lines
------------------------------------------------------------------------------
-- --
-- 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.66 $
-- --
-- Copyright (C) 1991-1999, 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;
----------------------
-- 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;
------------------------
-- 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;
----------------
-- 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;
------------------
-- 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;
-------------------------------
-- 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;
end System.Tasking.Utilities;
