File : s-tassta.adb
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . S T A G E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.117 $
-- --
-- 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). --
-- --
------------------------------------------------------------------------------
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 Ada.Exceptions;
-- used for Raise_Exception
with System.Tasking.Debug;
pragma Warnings (Off, System.Tasking.Debug);
-- used for enabling tasking facilities with gdb
with System.Parameters;
-- used for Size_Type
with System.Task_Info;
-- used for Task_Info_Type
-- Task_Image_Type
with System.Task_Primitives.Operations;
-- used for Finalize_Lock
-- Enter_Task
-- Write_Lock
-- Unlock
-- Sleep
-- Wakeup
-- Get_Priority
-- Lock/Unlock_All_Tasks_List
-- New_ATCB
with System.Soft_Links;
-- These are procedure pointers to non-tasking routines that use
-- task specific data. In the absence of tasking, these routines
-- refer to global data. In the presense of tasking, they must be
-- replaced with pointers to task-specific versions.
-- Also used for Create_TSD, Destroy_TSD
with System.Tasking.Initialization;
-- Used for Remove_From_All_Tasks_List
-- Defer_Abort
-- Undefer_Abort
-- Initialization.Poll_Base_Priority_Change
-- Finalize_Attributes_Link
-- Initialize_Attributes_Link
pragma Elaborate_All (System.Tasking.Initialization);
-- This insures that tasking is initialized if any tasks are created.
with System.Tasking.Utilities;
-- Used for Make_Passive
-- Abort_One_Task
with System.Tasking.Queuing;
-- Used for Dequeue_Head
with System.Tasking.Rendezvous;
-- Used for Call_Simple
with System.OS_Primitives;
-- Used for Delay_Modes
with System.Finalization_Implementation;
-- Used for System.Finalization_Implementation.Finalize_Global_List
with Interfaces.C;
-- Used for type Unsigned.
with Unchecked_Deallocation;
package body System.Tasking.Stages is
package STPO renames System.Task_Primitives.Operations;
package TSL renames System.Soft_Links;
use Ada.Exceptions;
use System.Task_Primitives;
use System.Task_Primitives.Operations;
use System.Task_Info;
procedure Wakeup_Entry_Caller
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State) renames
Initialization.Wakeup_Entry_Caller;
procedure Cancel_Queued_Entry_Calls (T : Task_ID) renames
Utilities.Cancel_Queued_Entry_Calls;
procedure Defer_Abort (Self_ID : Task_ID) renames
Initialization.Defer_Abort;
procedure Undefer_Abort (Self_ID : Task_ID) renames
Initialization.Undefer_Abort;
procedure Undefer_Abort_Nestable (Self_ID : Task_ID) renames
Initialization.Undefer_Abort_Nestable;
-- The following local versions are introduced to defeat
-- assertion-checking for creation of the Timer_Server task,
-- which occurs with abort deferred.
procedure Local_Defer_Abort (Self_ID : Task_ID) renames
Initialization.Defer_Abort_Nestable;
procedure Local_Undefer_Abort (Self_ID : Task_ID) renames
Initialization.Undefer_Abort_Nestable;
procedure Abort_One_Task
(Self_ID : Task_ID;
T : Task_ID) renames
Utilities.Abort_One_Task;
-----------------------
-- Local Subprograms --
-----------------------
procedure Free is new Unchecked_Deallocation (String, Task_Image_Type);
procedure Task_Wrapper (Self_ID : Task_ID);
-- This is the procedure that is called by the GNULL from the
-- new context when a task is created. It waits for activation
-- and then calls the task body procedure. When the task body
-- procedure completes, it terminates the task.
procedure Vulnerable_Complete_Task (Self_ID : Task_ID);
-- Complete the calling task.
-- This procedure must be called with abort deferred.
-- It should only be called by Complete_Task and
-- Finalizate_Global_Tasks (for the environment task).
procedure Vulnerable_Complete_Master (Self_ID : Task_ID);
-- Complete the current master of the calling task.
-- This procedure must be called with abort deferred.
-- It should only be called by Vulnerable_Complete_Task and
-- Complete_Master.
procedure Vulnerable_Complete_Activation (Self_ID : Task_ID);
-- Signal to Self_ID's activator that Self_ID has
-- completed activation.
-- Does not defer abortion (unlike Complete_Activation).
procedure Abort_Dependents (Self_ID : Task_ID);
-- Abort all the dependents of Self at our current master
-- nesting level.
procedure Vulnerable_Free_Task (T : Task_ID);
-- Recover all runtime system storage associated with the task T.
-- This should only be called after T has terminated and will no
-- longer be referenced.
-- For tasks created by an allocator that fails, due to an exception,
-- it is called from Expunge_Unactivated_Tasks.
-- It is also called from Unchecked_Deallocation, for objects that
-- are or contain tasks.
-- Different code is used at master completion, in
-- Terminate_Dependents, due to a need for tighter synchronization
-- with the master.
procedure Terminate_Task (Self_ID : Task_ID);
-- Terminate the calling task.
-- This should only be called by the Task_Wrapper procedure.
---------------------------
-- Finalize_Global_Tasks --
---------------------------
-- Compiler interface only. Do not call from within the RTS.
-- This should be called to complete the execution of the
-- environment task and shut down the tasking runtime system.
-- It is the equivalent of Complete_Task, but for the
-- environment task.
-- The environment task must first call Complete_Master,
-- to wait for user tasks that depend on library-level packages
-- to terminate. It then calls Abort_Dependents to abort
-- the "independent" library-level server tasks that are
-- created implicitly by the RTS packages (signal and timer
-- server tasks), and then waits for them to terminate.
-- Then, it calls Vulnerable_Complete_Task.
-- It currently also executes the global finalization list,
-- and then resets the "soft links".
-- ????
-- We have a potential problem here if finalization of global
-- objects does anything with signals or the timer server, since
-- by that time those servers have terminated.
-- It is hard to see how that would occur.
-- However, a better solution might be to do all this finalization
-- using the global finalization chain.
-- ????
-- With some care, some of the this procedure's functionality
-- might be eliminated, or moved elsewhere.
-- In particular, procedures to do this work could be embedded
-- in the global finalization chain.
procedure Finalize_Global_Tasks is
Self_ID : constant Task_ID := STPO.Self;
Zero_Independent : Boolean;
begin
if Self_ID.Deferral_Level = 0 then
-- ??????
-- In principle, we should be able to predict whether
-- abort is already deferred here (and it should not be deferred
-- yet but in practice it seems Finalize_Global_Tasks is being
-- called sometimes, from RTS code for exceptions, with abort already
-- deferred.
Defer_Abort (Self_ID);
-- Never undefer again!!!
end if;
-- This code is only executed by the environment task
pragma Assert (Self_ID = Environment_Task);
-- Set Environment_Task'Callable to false to notify library-level tasks
-- that it is waiting for them (cf 5619-003).
Self_ID.Callable := False;
-- Exit level 2 master, for normal tasks in library-level packages.
Complete_Master;
-- Force termination of "independent" library-level server tasks.
Abort_Dependents (Self_ID);
-- We need to explicitely wait for the task to be
-- terminated here because on true concurrent system, we
-- may end this procedure before the tasks are really
-- terminated.
loop
Write_Lock (Self_ID);
Zero_Independent := Utilities.Independent_Task_Count = 0;
Unlock (Self_ID);
STPO.Yield;
exit when Zero_Independent;
end loop;
-- ??? On multi-processor environments, it seems that the above loop
-- isn't sufficient, so we need to add an additional delay.
Timed_Delay (Self_ID, 0.1, System.OS_Primitives.Relative);
-- Complete the environment task.
Vulnerable_Complete_Task (Self_ID);
System.Finalization_Implementation.Finalize_Global_List;
TSL.Abort_Defer := TSL.Abort_Defer_NT'Access;
TSL.Abort_Undefer := TSL.Abort_Undefer_NT'Access;
TSL.Lock_Task := TSL.Task_Lock_NT'Access;
TSL.Unlock_Task := TSL.Task_Unlock_NT'Access;
TSL.Get_Jmpbuf_Address := TSL.Get_Jmpbuf_Address_NT'Access;
TSL.Set_Jmpbuf_Address := TSL.Set_Jmpbuf_Address_NT'Access;
TSL.Get_Sec_Stack_Addr := TSL.Get_Sec_Stack_Addr_NT'Access;
TSL.Set_Sec_Stack_Addr := TSL.Set_Sec_Stack_Addr_NT'Access;
TSL.Get_Exc_Stack_Addr := TSL.Get_Exc_Stack_Addr_NT'Access;
TSL.Set_Exc_Stack_Addr := TSL.Set_Exc_Stack_Addr_NT'Access;
TSL.Check_Abort_Status := TSL.Check_Abort_Status_NT'Access;
TSL.Get_Stack_Info := TSL.Get_Stack_Info_NT'Access;
-- Don't bother trying to finalize Initialization.Global_Task_Lock
-- and System.Task_Primitives.All_Tasks_L.
end Finalize_Global_Tasks;
------------------
-- Task_Wrapper --
------------------
-- The task wrapper is a procedure that is called first for each task
-- task body, and which in turn calls the compiler-generated task body
-- procedure. The wrapper's main job is to do initialization for the task.
-- It also has some locally declared objects that server as per-task local
-- data. Task finalization is done by Complete_Task, which is called from
-- an at-end handler that the compiler generates.
-- The variable ID in the task wrapper is used to implement the Self
-- function on targets where there is a fast way to find the stack base
-- of the current thread, since it should be at a fixed offset from the
-- stack base.
-- The variable Magic_Number is also used in such implementations
-- of Self, to check whether the current task is an Ada task, as
-- compared to other-language threads.
-- Both act as constants, once initialized, but need to be marked as
-- volatile or aliased to prevent the compiler from optimizing away the
-- storage. See System.Task_Primitives.Operations.Self for more info.
procedure Task_Wrapper (Self_ID : Task_ID) is
ID : Task_ID := Self_ID;
pragma Volatile (ID);
-- Do not delete this variable.
-- In some targets, we need this variable to implement a fast Self.
Magic_Number : Interfaces.C.unsigned := 16#ADAADAAD#;
pragma Volatile (Magic_Number);
-- We use this to verify that we are looking at an Ada task,
-- inside of System.Task_Primitives.Operations.Self.
begin
pragma Assert (Self_ID.Deferral_Level = 1);
-- Set the guard page at the bottom of the stack.
-- The call to unprotect the page is done in Terminate_Task
Stack_Guard (Self_ID, True);
-- Initialize low-level TCB components, that
-- cannot be initialized by the creator.
-- Enter_Task sets Self_ID.Known_Tasks_Index
-- and Self_ID.LL.Thread
Enter_Task (Self_ID);
-- We lock All_Tasks_L to wait for activator to finish activating
-- the rest of the chain, so that everyone in the chain comes out
-- in priority order.
-- This also protects the value of Self_ID.Activator.Wait_Count.
Lock_All_Tasks_List;
Unlock_All_Tasks_List;
begin
-- We are separating the following portion of the code in order to
-- place the exception handlers in a different block.
-- In this way we do not call Set_Jmpbuf_Address (which needs
-- Self) before we set Self in Enter_Task
-- Call the task body procedure.
-- The task body is called with abort still deferred. That
-- eliminates a dangerous window, for which we had to patch-up in
-- Terminate_Task.
-- During the expansion of the task body, we insert an RTS-call
-- to Abort_Undefer, at the first point where abort should be
-- allowed.
Self_ID.Task_Entry_Point (Self_ID.Task_Arg);
Terminate_Task (Self_ID);
exception
when Standard'Abort_Signal =>
Terminate_Task (Self_ID);
when others =>
Terminate_Task (Self_ID);
end;
end Task_Wrapper;
-----------------
-- Create_Task --
-----------------
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
procedure Create_Task
(Priority : Integer;
Size : System.Parameters.Size_Type;
Task_Info : System.Task_Info.Task_Info_Type;
Num_Entries : Task_Entry_Index;
Master : Master_Level;
State : Task_Procedure_Access;
Discriminants : System.Address;
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : System.Task_Info.Task_Image_Type;
Created_Task : out Task_ID)
is
T, P : Task_ID;
Self_ID : constant Task_ID := STPO.Self;
Success : Boolean;
Base_Priority : System.Any_Priority;
begin
pragma Debug
(Debug.Trace (Self_ID, "Create_Task", 'C'));
if Priority = Unspecified_Priority then
Base_Priority := Self_ID.Base_Priority;
else
Base_Priority := System.Any_Priority (Priority);
end if;
-- Find parent P of new Task, via master level number.
P := Self_ID;
if P /= null then
while P.Master_of_Task >= Master loop
P := P.Parent;
exit when P = null;
end loop;
end if;
Local_Defer_Abort (Self_ID);
begin
T := New_ATCB (Num_Entries);
exception
when others =>
Local_Undefer_Abort (Self_ID);
Raise_Exception (Storage_Error'Identity, "Cannot allocate task");
end;
-- All_Tasks_L is used by Abort_Dependents and Abort_Tasks.
-- Up to this point, it is possible that we may be part of
-- a family of tasks that is being aborted.
Lock_All_Tasks_List;
Write_Lock (Self_ID);
-- Now, we must check that we have not been aborted.
-- If so, we should give up on creating this task,
-- and simply return.
if not Self_ID.Callable then
pragma Assert (Self_ID.Pending_ATC_Level = 0);
pragma Assert (Self_ID.Pending_Action);
pragma Assert (Chain.T_ID = null
or else Chain.T_ID.State = Unactivated);
Unlock (Self_ID);
Unlock_All_Tasks_List;
Local_Undefer_Abort (Self_ID);
-- ??? Should never get here
pragma Assert (False);
raise Standard'Abort_Signal;
end if;
Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
Base_Priority, Task_Info, Size, Master, T, Success);
if not Success then
Unlock (Self_ID);
Unlock_All_Tasks_List;
Local_Undefer_Abort (Self_ID);
Raise_Exception (Storage_Error'Identity,
"Failed to initialize task");
end if;
T.Task_Image := Task_Image;
Unlock (Self_ID);
Unlock_All_Tasks_List;
-- Create TSD as early as possible in the creation of a task, since it
-- may be used by the operation of Ada code within the task.
TSL.Create_TSD (T.Compiler_Data);
T.Activation_Link := Chain.T_ID;
Chain.T_ID := T;
Initialization.Initialize_Attributes_Link.all (T);
Created_Task := T;
Local_Undefer_Abort (Self_ID);
end Create_Task;
--------------------
-- Activate_Tasks --
--------------------
-- Compiler interface only. Do not call from within the RTS.
-- This must be called by the creator of a chain of one or more
-- new tasks, to activate them. The chain is a linked list that
-- up to this point is only known to the task that created them,
-- though the individual tasks are already in the All_Tasks_List.
-- The compiler builds the chain in LIFO order (as a stack).
-- Another version of this procedure had code to reverse the chain,
-- so as to activate the tasks in the order of declaration.
-- This might be nice, but it is not needed if priority-based
-- scheduling is supported, since all the activated tasks
-- synchronize on the activators lock before they start activating
-- (see Task_Wrapper, above), and so they should start activating
-- in priority order.
-- Note that locks of activator and activated task are both locked
-- here. This is necessary because C.State and Self.Wait_Count
-- have to be synchronized. This is safe from deadlock because
-- the activator is always created before the activated task.
-- That satisfies our in-order-of-creation ATCB locking policy.
-- At one point, we may also lock the parent, if the parent is
-- different from the activator. That is also consistent with the
-- lock ordering policy, since the activator cannot be created
-- before the parent.
-- Since we are holding both the activator's lock, and Task_Wrapper
-- locks that before it does anything more than initialize the
-- low-level ATCB components, it should be safe to wait to update
-- the counts until we see that the thread creation is successful.
-- If the thread creation fails, we do need to close the entries
-- of the task. The first phase, of dequeuing calls, only requires
-- locking the acceptor's ATCB, but the waking up of the callers
-- requires locking the caller's ATCB. We cannot safely do this
-- while we are holding other locks. Therefore, the queue-clearing
-- operation is done in a separate pass over the activation chain.
procedure Activate_Tasks
(Chain_Access : Activation_Chain_Access)
is
Self_ID : constant Task_ID := STPO.Self;
P : Task_ID;
C : Task_ID;
Next_C, Last_C : Task_ID;
Activate_Prio : System.Any_Priority;
Success : Boolean;
All_Elaborated : Boolean := True;
begin
pragma Debug
(Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
Local_Defer_Abort (Self_ID);
pragma Assert (Self_ID.Wait_Count = 0);
-- Lock All_Tasks_L, to prevent activated tasks
-- from racing ahead before we finish activating the chain.
-- ?????
-- Is there some less heavy-handed way?
-- In an earlier version, we used the activator's lock here,
-- but that violated the locking order rule when we had
-- to lock the parent later.
Lock_All_Tasks_List;
-- Check that all task bodies have been elaborated.
C := Chain_Access.T_ID;
Last_C := null;
while C /= null loop
if C.Elaborated /= null and then not C.Elaborated.all then
All_Elaborated := False;
end if;
-- Reverse the activation chain so that tasks are
-- activated in the same order they're declared.
Next_C := C.Activation_Link;
C.Activation_Link := Last_C;
Last_C := C;
C := Next_C;
end loop;
Chain_Access.T_ID := Last_C;
if not All_Elaborated then
Unlock_All_Tasks_List;
Local_Undefer_Abort (Self_ID);
Raise_Exception (Program_Error'Identity,
"Some tasks have not been elaborated");
end if;
-- Activate all the tasks in the chain.
-- Creation of the thread of control was deferred until
-- activation. So create it now.
C := Chain_Access.T_ID;
while C /= null loop
if C.State /= Terminated then
pragma Assert (C.State = Unactivated);
P := C.Parent;
Write_Lock (P);
Write_Lock (C);
if C.Base_Priority < Get_Priority (Self_ID) then
Activate_Prio := Get_Priority (Self_ID);
else
Activate_Prio := C.Base_Priority;
end if;
System.Task_Primitives.Operations.Create_Task
(C, Task_Wrapper'Address, C.Stack_Size, Activate_Prio, Success);
-- There would be a race between the created task and
-- the creator to do the following initialization,
-- if we did not have a Lock/Unlock_All_Tasks_List pair
-- in the task wrapper, to prevent it from racing ahead.
if Success then
C.State := Runnable;
C.Awake_Count := 1;
C.Alive_Count := 1;
P.Awake_Count := P.Awake_Count + 1;
P.Alive_Count := P.Alive_Count + 1;
if P.State = Master_Completion_Sleep and then
C.Master_of_Task = P.Master_Within
then
pragma Assert (Self_ID /= P);
P.Wait_Count := P.Wait_Count + 1;
end if;
Unlock (C);
Unlock (P);
else
-- No need to set Awake_Count, State, etc. here since the loop
-- below will do that for any Unactivated tasks.
Unlock (C);
Unlock (P);
Self_ID.Activation_Failed := True;
end if;
end if;
C := C.Activation_Link;
end loop;
Unlock_All_Tasks_List;
-- Close the entries of any tasks that failed thread creation,
-- and count those that have not finished activation.
Write_Lock (Self_ID);
Self_ID.State := Activator_Sleep;
C := Chain_Access.T_ID;
while C /= null loop
Write_Lock (C);
if C.State = Unactivated then
C.Activator := null;
C.State := Terminated;
C.Callable := False;
Cancel_Queued_Entry_Calls (C);
elsif C.Activator /= null then
Self_ID.Wait_Count := Self_ID.Wait_Count + 1;
end if;
Unlock (C);
P := C.Activation_Link;
C.Activation_Link := null;
C := P;
end loop;
-- Wait for the activated tasks to complete activation.
-- It is unsafe to abort any of these tasks until the count goes to
-- zero.
loop
Initialization.Poll_Base_Priority_Change (Self_ID);
exit when Self_ID.Wait_Count = 0;
Sleep (Self_ID, Activator_Sleep);
end loop;
Self_ID.State := Runnable;
Unlock (Self_ID);
-- Remove the tasks from the chain.
Chain_Access.T_ID := null;
Local_Undefer_Abort (Self_ID);
if Self_ID.Activation_Failed then
Self_ID.Activation_Failed := False;
Raise_Exception (Tasking_Error'Identity,
"Failure during activation");
end if;
end Activate_Tasks;
-------------------------------
-- Expunge_Unactivated_Tasks --
-------------------------------
-- Compiler interface only. Do not call from within the RTS.
-- This must be called by the compiler-generated code for an
-- allocator if the allocated object contains tasks, if the
-- allocator exits without calling Activate_Tasks for a given
-- activation chains, as can happend if an exception occurs
-- during initialization of the object.
-- This should be called ONLY for tasks created via an allocator.
-- Recovery of storage for unactivated local task declarations is
-- done by Complete_Master and Complete_Task.
-- We remove each task from Chain and All_Tasks_List before we
-- free the storage of its ATCB.
-- In other places where we recover the storage of unactivated
-- tasks, we need to clean out the entry queues, but here
-- that should not be necessary, since these tasks should not have
-- been visible to any other tasks, and so no task should be able to
-- queue a call on their entries.
-- Just in case somebody misuses this subprogram, there is a check
-- to verify this condition.
-- See procedure Close_Entries for the general case.
procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
Self_ID : constant Task_ID := STPO.Self;
C : Task_ID;
Call : Entry_Call_Link;
Temp : Task_ID;
begin
pragma Debug
(Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
Initialization.Defer_Abort_Nestable (Self_ID);
-- ????
-- Experimentation has shown that abort is sometimes (but not
-- always) already deferred when this is called.
-- That may indicate an error. Find out what is going on.
C := Chain.T_ID;
while C /= null loop
pragma Assert (C.State = Unactivated);
Temp := C.Activation_Link;
if C.State = Unactivated then
Write_Lock (C);
for J in 1 .. C.Entry_Num loop
Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
pragma Assert (Call = null);
end loop;
Unlock (C);
Initialization.Remove_From_All_Tasks_List (C);
Vulnerable_Free_Task (C);
C := Temp;
end if;
end loop;
Chain.T_ID := null;
Initialization.Undefer_Abort_Nestable (Self_ID);
end Expunge_Unactivated_Tasks;
--------------------
-- Current_Master --
--------------------
-- Compiler interface only.
-- This is called to obtain the current master nesting level.
function Current_Master return Master_Level is
Self_ID : constant Task_ID := STPO.Self;
begin
return Self_ID.Master_Within;
end Current_Master;
-------------------------
-- Complete_Activation --
-------------------------
-- Compiler interface only. Do not call from within the RTS.
-- This should be called from the task body at the end of
-- the elaboration code for its declarative part.
procedure Complete_Activation is
Self_ID : constant Task_ID := STPO.Self;
begin
Initialization.Defer_Abort_Nestable (Self_ID);
Vulnerable_Complete_Activation (Self_ID);
Initialization.Undefer_Abort_Nestable (Self_ID);
-- ?????
-- Why do we need to allow for nested deferral here?
end Complete_Activation;
------------------------------------
-- Vulnerable_Complete_Activation --
------------------------------------
-- Decrement the count of tasks to be activated by the activator and
-- wake it up so it can check to see if all tasks have been activated.
-- Only call this procedure with abortion deferred.
-- As in several other places, the locks of the activator and activated
-- task are both locked here. This follows our deadlock prevention lock
-- ordering policy, since the activated task must be created after the
-- activator.
-- Except for the environment task, which should never call this
-- procedure, T.Activator should only be null iff T has completed
-- activation.
procedure Vulnerable_Complete_Activation (Self_ID : Task_ID) is
Activator : Task_ID := Self_ID.Activator;
begin
pragma Debug
(Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
Write_Lock (Activator);
Write_Lock (Self_ID);
pragma Assert (Self_ID.Activator /= null);
-- Remove dangling reference to Activator,
-- since a task may outlive its activator.
Self_ID.Activator := null;
-- Wake up the activator, if it is waiting for a chain
-- of tasks to activate, and we are the last in the chain
-- to complete activation
if Activator.State = Activator_Sleep then
Activator.Wait_Count := Activator.Wait_Count - 1;
if Activator.Wait_Count = 0 then
Wakeup (Activator, Activator_Sleep);
end if;
end if;
-- The activator raises a Tasking_Error if any task
-- it is activating is completed before the activation is
-- done. However, if the reason for the task completion is
-- an abortion, we do not raise an exception. ARM 9.2(5).
if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
Activator.Activation_Failed := True;
end if;
Unlock (Self_ID);
Unlock (Activator);
-- After the activation, active priority should be the same
-- as base priority. We must unlock the Activator first,
-- though, since it should not wait if we have lower priority.
if Get_Priority (Self_ID) /= Self_ID.Base_Priority then
Write_Lock (Self_ID);
Set_Priority (Self_ID, Self_ID.Base_Priority);
Unlock (Self_ID);
end if;
end Vulnerable_Complete_Activation;
-------------------
-- Complete_Task --
-------------------
-- Compiler interface only.
-- This should be called from an implicit at-end handler
-- associated with the task body, when it completes.
-- source code:
-- task body A is
-- ...declarations, possible some controlled...
-- begin
-- ...B...
-- end A;
-- code expansion:
-- procedure aTB (_task : access aTV) is
-- procedure _clean is
-- begin
-- abort_defer;
-- complete_task;
-- finalize_list (F14b);
-- abort_undefer;
-- return;
-- end _clean;
-- begin
-- abort_undefer;
-- ...declarations, possible some controlled...
-- complete_activation;
-- ...B...
-- return;
-- at end
-- _clean;
-- end aTB;
-- Note: the abort defer/undefer calls in _clean protect the finalization.
-- See comments on Vulnerable_Complete_Task for details.
procedure Complete_Task is
Self_ID : constant Task_ID := STPO.Self;
begin
pragma Assert (Self_ID.Deferral_Level > 0);
Vulnerable_Complete_Task (Self_ID);
-- All of our dependents have terminated.
-- Never undefer abort again!
end Complete_Task;
------------------------------
-- Vulnerable_Complete_Task --
------------------------------
-- Complete the calling task.
-- This procedure must be called with abort deferred. (That's why the
-- name has "Vulnerable" in it.) It should only be called by Complete_Task
-- and Finalizate_Global_Tasks (for the environment task).
-- The effect is similar to that of Complete_Master. Differences include
-- the closing of entries here, and computation of the number of active
-- dependent tasks in Complete_Master.
-- We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
-- because that does its own locking, and because we do not need the lock
-- to test Self_ID.Activator. That value should only be read and modified
-- by Self.
procedure Vulnerable_Complete_Task (Self_ID : Task_ID) is
begin
pragma Assert (Self_ID.Deferral_Level > 0);
pragma Assert (Self_ID = Self);
pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1
or else
Self_ID.Master_Within = Self_ID.Master_of_Task + 2);
pragma Assert (Self_ID.Wait_Count = 0);
pragma Assert (Self_ID.Open_Accepts = null);
pragma Assert (Self_ID.ATC_Nesting_Level = 1);
pragma Debug
(Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
Write_Lock (Self_ID);
Self_ID.Callable := False;
-- In theory, Self should have no pending entry calls
-- left on its call-stack. Each async. select statement should
-- clean its own call, and blocking entry calls should
-- defer abort until the calls are cancelled, then clean up.
Cancel_Queued_Entry_Calls (Self_ID);
Unlock (Self_ID);
if Self_ID.Activator /= null then
Vulnerable_Complete_Activation (Self_ID);
end if;
-- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
-- we may have dependent tasks for which we need to wait.
-- Otherwise, we can just exit.
if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
Vulnerable_Complete_Master (Self_ID);
end if;
end Vulnerable_Complete_Task;
--------------------
-- Terminate_Task --
--------------------
-- Before we allow the thread to exit, we must clean up. This is a
-- a delicate job. We must wake up the task's master, who may immediately
-- try to deallocate the ATCB out from under the current task WHILE IT IS
-- STILL EXECUTING.
-- To avoid this, the parent task must be blocked up to the last thing
-- done before the call to Exit_Task. The trouble is that we have another
-- step that we also want to postpone to the very end, i.e., calling
-- TSL.Destroy_TSD. We have to postpone that until the end because
-- compiler-generated code is likely to try to access that data at just
-- about any point.
-- We can't call Destroy_TSD while we are holding any other locks, because
-- it locks Global_Task_Lock, and our deadlock prevention rules require
-- that to be the outermost lock. Our first "solution" was to just lock
-- Global_Task_Lock in addition to the other locks, and force the parent
-- to also lock this lock between its wakeup and its freeing of the ATCB.
-- See Complete_Task for the parent-side of the code that has the matching
-- calls to Task_Lock and Task_Unlock. That was not really a solution,
-- since the operation Task_Unlock continued to access the ATCB after
-- unlocking, after which the parent was observed to race ahead,
-- deallocate the ATCB, and then reallocate it to another task. The
-- call to Undefer_Abortion in Task_Unlock by the "terminated" task was
-- overwriting the data of the new task that reused the ATCB! To solve
-- this problem, we introduced the new operation Final_Task_Unlock.
procedure Terminate_Task (Self_ID : Task_ID) is
Environment_Task : constant Task_ID := STPO.Environment_Task;
begin
pragma Assert (Self_ID.Activator = null);
-- ??? [assert 3]
-- The following assertion looks bogus: what about the tasks created
-- by tasks other than the Environment_Task ?
-- See 1724-016
-- pragma Assert (Self_ID.Parent = Environment_Task);
-- Check if the current task is an independent task
-- If so, decrement the Independent_Task_Count value.
if Self_ID.Master_of_Task = 2 then
Write_Lock (Environment_Task);
Utilities.Independent_Task_Count :=
Utilities.Independent_Task_Count - 1;
Unlock (Environment_Task);
end if;
-- Unprotect the guard page if needed.
Stack_Guard (Self_ID, False);
Initialization.Task_Lock (Self_ID);
Utilities.Make_Passive (Self_ID, Task_Completed => True);
pragma Assert (Check_Exit (Self_ID));
Initialization.Final_Task_Unlock (Self_ID);
-- WARNING
-- past this point, this thread must assume that the ATCB
-- has been deallocated. It should not be accessed again.
STPO.Exit_Task;
end Terminate_Task;
------------------
-- Enter_Master --
------------------
-- Compiler interface only. Do not call from within the RTS.
-- This must be called on entry to any "master" where a task,
-- or access type designating objects containing tasks, may be
-- declared.
procedure Enter_Master is
Self_ID : constant Task_ID := STPO.Self;
begin
Self_ID.Master_Within := Self_ID.Master_Within + 1;
end Enter_Master;
---------------------
-- Complete_Master --
---------------------
-- Compiler interface only. Do not call from within the RTS. This must
-- be called on exit from any master where Enter_Master was called.
-- Assume abort is deferred at this point.
procedure Complete_Master is
Self_ID : Task_ID := STPO.Self;
begin
pragma Assert (Self_ID.Deferral_Level > 0);
Vulnerable_Complete_Master (Self_ID);
end Complete_Master;
--------------------------------
-- Vulnerable_Complete_Master --
--------------------------------
procedure Vulnerable_Complete_Master (Self_ID : Task_ID) is
C : Task_ID;
P : Task_ID;
CM : Master_Level := Self_ID.Master_Within;
T : aliased Task_ID;
To_Be_Freed : Task_ID;
-- This is a list of ATCBs to be freed, after we have released
-- all RTS locks. This is necessary because of the locking order
-- rules, since the storage manager uses Global_Task_Lock.
pragma Warnings (Off);
function Check_Unactivated_Tasks return Boolean;
pragma Warnings (On);
-- Temporary error-checking code below. This is part of the checks
-- added in the new run time. Call it only inside a pragma Assert.
function Check_Unactivated_Tasks return Boolean is
begin
Lock_All_Tasks_List;
Write_Lock (Self_ID);
C := All_Tasks_List;
while C /= null loop
if C.Activator = Self_ID then
return False;
end if;
if C.Parent = Self_ID and then C.Master_of_Task = CM then
Write_Lock (C);
if C.State = Unactivated then
return False;
end if;
Unlock (C);
end if;
C := C.All_Tasks_Link;
end loop;
Unlock (Self_ID);
Unlock_All_Tasks_List;
return True;
end Check_Unactivated_Tasks;
-- Start of processing for Vulnerable_Complete_Master
begin
pragma Debug
(Debug.Trace (Self_ID, "V_Complete_Master", 'C'));
pragma Assert (Self_ID.Wait_Count = 0);
pragma Assert (Self_ID.Deferral_Level > 0);
-- Count how many active dependent tasks this master currently
-- has, and record this in Wait_Count.
-- This count should start at zero, since it is initialized to
-- zero for new tasks, and the task should not exit the
-- sleep-loops that use this count until the count reaches zero.
Lock_All_Tasks_List;
Write_Lock (Self_ID);
C := All_Tasks_List;
while C /= null loop
if C.Activator = Self_ID then
pragma Assert (C.State = Unactivated);
Write_Lock (C);
C.Activator := null;
C.State := Terminated;
C.Callable := False;
Cancel_Queued_Entry_Calls (C);
Unlock (C);
end if;
if C.Parent = Self_ID and then C.Master_of_Task = CM then
Write_Lock (C);
if C.Awake_Count /= 0 then
Self_ID.Wait_Count := Self_ID.Wait_Count + 1;
end if;
Unlock (C);
end if;
C := C.All_Tasks_Link;
end loop;
Self_ID.State := Master_Completion_Sleep;
Unlock (Self_ID);
Unlock_All_Tasks_List;
-- Wait until dependent tasks are all terminated or ready to terminate.
-- While waiting, the task may be awakened if the task's priority needs
-- changing, or this master is aborted. In the latter case, we want
-- to abort the dependents, and resume waiting until Wait_Count goes
-- to zero.
Write_Lock (Self_ID);
loop
Initialization.Poll_Base_Priority_Change (Self_ID);
exit when Self_ID.Wait_Count = 0;
-- Here is a difference as compared to Complete_Master
if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
and then not Self_ID.Dependents_Aborted
then
Unlock (Self_ID);
Abort_Dependents (Self_ID);
Write_Lock (Self_ID);
else
Sleep (Self_ID, Master_Completion_Sleep);
end if;
end loop;
Self_ID.State := Runnable;
Unlock (Self_ID);
-- Dependents are all terminated or on terminate alternatives.
-- Now, force those on terminate alternatives to terminate, by
-- aborting them.
pragma Assert (Check_Unactivated_Tasks);
if Self_ID.Alive_Count > 1 then
-- ?????
-- Consider finding a way to skip the following extra steps if
-- there are no dependents with terminate alternatives. This
-- could be done by adding another count to the ATCB, similar to
-- Awake_Count, but keeping track of count of tasks that are on
-- terminate alternatives.
pragma Assert (Self_ID.Wait_Count = 0);
-- Force any remaining dependents to terminate, by aborting them.
Abort_Dependents (Self_ID);
-- Above, when we "abort" the dependents we are simply using this
-- operation for convenience. We are not required to support the full
-- abort-statement semantics; in particular, we are not required to
-- immediately cancel any queued or in-service entry calls. That is
-- good, because if we tried to cancel a call we would need to lock
-- the caller, in order to wake the caller up. Our anti-deadlock
-- rules prevent us from doing that without releasing the locks on C
-- and Self_ID. Releasing and retaking those locks would be
-- wasteful, at best, and should not be considered further without
-- more detailed analysis of potential concurrent accesses to the
-- ATCBs of C and Self_ID.
-- Count how many "alive" dependent tasks this master currently
-- has, and record this in Wait_Count.
-- This count should start at zero, since it is initialized to
-- zero for new tasks, and the task should not exit the
-- sleep-loops that use this count until the count reaches zero.
pragma Assert (Self_ID.Wait_Count = 0);
Lock_All_Tasks_List;
Write_Lock (Self_ID);
C := All_Tasks_List;
while C /= null loop
if C.Parent = Self_ID and then C.Master_of_Task = CM then
Write_Lock (C);
pragma Assert (C.Awake_Count = 0);
if C.Alive_Count > 0 then
pragma Assert (C.Terminate_Alternative);
Self_ID.Wait_Count := Self_ID.Wait_Count + 1;
end if;
Unlock (C);
end if;
C := C.All_Tasks_Link;
end loop;
Self_ID.State := Master_Phase_2_Sleep;
Unlock (Self_ID);
Unlock_All_Tasks_List;
-- Wait for all counted tasks to finish terminating themselves.
Write_Lock (Self_ID);
loop
Initialization.Poll_Base_Priority_Change (Self_ID);
exit when Self_ID.Wait_Count = 0;
Sleep (Self_ID, Master_Phase_2_Sleep);
end loop;
Self_ID.State := Runnable;
Unlock (Self_ID);
end if;
-- We don't wake up for abortion here. We are already terminating
-- just as fast as we can, so there is no point.
-- ????
-- Consider whether we want to bother checking for priority
-- changes in the loop above, though.
-- Remove terminated tasks from the list of Self_ID's dependents, but
-- don't free their ATCBs yet, because of lock order restrictions,
-- which don't allow us to call "free" or "malloc" while holding any
-- other locks. Instead, we put those ATCBs to be freed onto a
-- temporary list, called To_Be_Freed.
Lock_All_Tasks_List;
C := All_Tasks_List;
P := null;
while C /= null loop
if C.Parent = Self_ID and then C.Master_of_Task >= CM then
if P /= null then
P.All_Tasks_Link := C.All_Tasks_Link;
else
All_Tasks_List := C.All_Tasks_Link;
end if;
T := C.All_Tasks_Link;
C.All_Tasks_Link := To_Be_Freed;
To_Be_Freed := C;
C := T;
else
P := C;
C := C.All_Tasks_Link;
end if;
end loop;
Unlock_All_Tasks_List;
-- Free all the ATCBs on the list To_Be_Freed.
-- The ATCBs in the list are no longer in All_Tasks_List, and after
-- any interrupt entries are detached from them they should no longer
-- be referenced.
-- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
-- avoid a race between a terminating task and its parent. The parent
-- might try to deallocate the ACTB out from underneath the exiting
-- task. Note that Free will also lock Global_Task_Lock, but that is
-- OK, since this is the *one* lock for which we have a mechanism to
-- support nested locking. See Task_Wrapper and its finalizer for more
-- explanation.
-- ???
-- The check "T.Parent /= null ..." below is to prevent dangling
-- references to terminated library-level tasks, which could
-- otherwise occur during finalization of library-level objects.
-- A better solution might be to hook task objects into the
-- finalization chain and deallocate the ATCB when the task
-- object is deallocated. However, this change is not likely
-- to gain anything significant, since all this storage should
-- be recovered en-masse when the process exits.
while To_Be_Freed /= null loop
T := To_Be_Freed;
To_Be_Freed := T.All_Tasks_Link;
-- ??? On SGI there is currently no Interrupt_Manager, that's
-- why we need to check if the Interrupt_Manager_ID is null
if T.Interrupt_Entry and Interrupt_Manager_ID /= null then
declare
Detach_Interrupt_Entries_Index : Task_Entry_Index := 6;
-- Corresponds to the entry index of System.Interrupts.
-- Interrupt_Manager.Detach_Interrupt_Entries.
-- Be sure to update this value when changing
-- Interrupt_Manager specs.
type Param_Type is access all Task_ID;
Param : aliased Param_Type := T'Access;
begin
System.Tasking.Rendezvous.Call_Simple
(Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
Param'Address);
end;
end if;
if (T.Parent /= null and then T.Parent.Parent /= null)
or else T.Master_of_Task > 3
then
Initialization.Task_Lock (Self_ID);
TSL.Destroy_TSD (T.Compiler_Data);
Vulnerable_Free_Task (T);
Initialization.Task_Unlock (Self_ID);
end if;
end loop;
-- It might seem nice to let the terminated task deallocate
-- its own ATCB. That would not cover the case of unactivated
-- tasks. It also would force us to keep the underlying thread
-- around past termination, since references to the ATCB are
-- possible past termination. Currently, we get rid of the
-- thread as soon as the task terminates, and let the parent
-- recover the ATCB later.
-- ????
-- Some day, if we want to recover the ATCB earlier, at task
-- termination, we could consider using "fat task IDs", that
-- include the serial number with the ATCB pointer, to catch
-- references to tasks that no longer have ATCBs. It is not
-- clear how much this would gain, since the user-level task
-- object would still be occupying storage.
-- Make next master level up active.
-- We don't need to lock the ATCB, since the value is only
-- updated by each task for itself.
Self_ID.Master_Within := CM - 1;
end Vulnerable_Complete_Master;
--------------------------
-- Vulnerable_Free_Task --
--------------------------
-- Recover all runtime system storage associated with the task T.
-- This should only be called after T has terminated and will no
-- longer be referenced.
-- For tasks created by an allocator that fails, due to an exception,
-- it is called from Expunge_Unactivated_Tasks.
-- For tasks created by elaboration of task object declarations it
-- is called from the finalization code of the Task_Wrapper procedure.
-- It is also called from Unchecked_Deallocation, for objects that
-- are or contain tasks.
-- This procedure is called by the compiler when performing an
-- Unchecked_Deallocation for a task pointer.
procedure Vulnerable_Free_Task (T : Task_ID) is
begin
pragma Debug
(Debug.Trace ("Vulnerable_Free_Task", T, 'C'));
Write_Lock (T);
Initialization.Finalize_Attributes_Link.all (T);
Unlock (T);
if T.Task_Image /= null then
Free (T.Task_Image);
end if;
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
---------------
-- Free_Task --
---------------
-- Compiler interface only. Do not call from within the RTS.
procedure Free_Task (T : Task_ID) is
Self_Id : constant Task_ID := Self;
begin
if T.State = Terminated then
-- It is not safe to call Abort_Defer or Write_Lock at this stage
Initialization.Task_Lock (Self_Id);
if T.Task_Image /= null then
Free (T.Task_Image);
end if;
TSL.Destroy_TSD (T.Compiler_Data);
Initialization.Remove_From_All_Tasks_List (T);
Initialization.Task_Unlock (Self_Id);
System.Task_Primitives.Operations.Finalize_TCB (T);
-- If the task is not terminated, then we simply ignore the call. This
-- happens when a user program attempts an unchecked deallocation on
-- a non-terminated task.
else
null;
end if;
end Free_Task;
----------------
-- Terminated --
----------------
-- Compiler interface only. Do not call from within the RTS.
-- This should be called to implement the 'Terminated attribute.
-- Though is not required to be so by the ARM, we choose to
-- synchronize with the task's ATCB, so that this is more useful
-- for polling the state of a task, and so that it becomes an
-- abort completion point for the calling task (via Undefer_Abort).
function Terminated (T : Task_ID) return Boolean is
Result : Boolean;
Self_ID : Task_ID := STPO.Self;
begin
Initialization.Defer_Abort_Nestable (Self_ID);
Write_Lock (T);
Result := T.State = Terminated;
Unlock (T);
Initialization.Undefer_Abort_Nestable (Self_ID);
return Result;
end Terminated;
----------------------
-- Abort_Dependents --
----------------------
-- Abort all the direct dependents of Self at its current master
-- nesting level, plus all of their dependents, transitively.
-- No locks should be held when this routine is called.
procedure Abort_Dependents (Self_ID : Task_ID) is
C : Task_ID;
P : Task_ID;
begin
Lock_All_Tasks_List;
C := All_Tasks_List;
while C /= null loop
P := C.Parent;
while P /= null loop
if P = Self_ID then
-- ??? C is supposed to take care of its own dependents, so
-- there should be no need to take worry about them. Need to
-- double check this.
if C.Master_of_Task = Self_ID.Master_Within then
Abort_One_Task (Self_ID, C);
C.Dependents_Aborted := True;
end if;
exit;
end if;
P := P.Parent;
end loop;
C := C.All_Tasks_Link;
end loop;
Self_ID.Dependents_Aborted := True;
Unlock_All_Tasks_List;
end Abort_Dependents;
begin
-- Establish soft links for subprograms that manipulate master_id's.
-- This cannot be done when the RTS is initialized, because of various
-- elaboration constraints.
TSL.Current_Master := Stages.Current_Master'Access;
TSL.Enter_Master := Stages.Enter_Master'Access;
TSL.Complete_Master := Stages.Complete_Master'Access;
end System.Tasking.Stages;