blob: 8ba852e67077de4418215d2570562477acb9b0e7 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT 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 --
-- --
-- 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. --
-- --
------------------------------------------------------------------------------
pragma Partition_Elaboration_Policy (Concurrent);
-- This package only implements the concurrent elaboration policy. This pragma
-- will enforce it (and detect conflicts with user specified policy).
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;
with Ada.Task_Initialization;
with System.Interrupt_Management;
with System.Tasking.Debug;
with System.Address_Image;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Tasking.Utilities;
with System.Tasking.Queuing;
with System.Tasking.Rendezvous;
with System.OS_Primitives;
with System.Secondary_Stack;
with System.Restrictions;
with System.Standard_Library;
with System.Stack_Usage;
with System.Storage_Elements;
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 presence of tasking, they must be replaced with pointers to
-- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current
-- _Excep, Finalize_Library_Objects, Task_Termination, Handler.
with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
-- This insures that tasking is initialized if any tasks are created
package body System.Tasking.Stages is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
package SSE renames System.Storage_Elements;
use Ada.Exceptions;
use Secondary_Stack;
use Task_Primitives;
use Task_Primitives.Operations;
-----------------------
-- Local Subprograms --
-----------------------
procedure Free is new
Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
-- This procedure outputs the task specific message for exception
-- tracing purposes.
procedure Task_Wrapper (Self_ID : Task_Id);
pragma Convention (C, Task_Wrapper);
-- 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.
--
-- The Task_Wrapper's address will be provided to the underlying threads
-- library as the task entry point. Convention C is what makes most sense
-- for that purpose (Export C would make the function globally visible,
-- and affect the link name on which GDB depends). This will in addition
-- trigger an automatic stack alignment suitable for GCC's assumptions if
-- need be.
-- "Vulnerable_..." in the procedure names below means they must be called
-- with abort deferred.
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
-- Finalize_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.
-- This procedure must be called with abort deferred.
procedure Abort_Dependents (Self_ID : Task_Id);
-- Abort all the direct dependents of Self at its current master nesting
-- level, plus all of their dependents, transitively. RTS_Lock should be
-- locked by the caller.
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.
--
-- Different code is used at master completion, in Terminate_Dependents,
-- due to a need for tighter synchronization with the master.
----------------------
-- Abort_Dependents --
----------------------
procedure Abort_Dependents (Self_ID : Task_Id) is
C : Task_Id;
P : Task_Id;
-- Each task C will take care of its own dependents, so there is no
-- need to worry about them here. In fact, it would be wrong to abort
-- indirect dependents here, because we can't distinguish between
-- duplicate master ids. For example, suppose we have three nested
-- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and
-- both P and Q are task masters). Q will have the same master id as
-- Master_Of_Task of T3. Previous versions of this would abort T3 when
-- Q calls Complete_Master, which was completely wrong.
begin
C := All_Tasks_List;
while C /= null loop
P := C.Common.Parent;
if P = Self_ID then
if C.Master_Of_Task = Self_ID.Master_Within then
pragma Debug
(Debug.Trace (Self_ID, "Aborting", 'X', C));
Utilities.Abort_One_Task (Self_ID, C);
C.Dependents_Aborted := True;
end if;
end if;
C := C.Common.All_Tasks_Link;
end loop;
Self_ID.Dependents_Aborted := True;
end Abort_Dependents;
-----------------
-- Abort_Tasks --
-----------------
procedure Abort_Tasks (Tasks : Task_List) is
begin
Utilities.Abort_Tasks (Tasks);
end Abort_Tasks;
--------------------
-- Activate_Tasks --
--------------------
-- Note that locks of activator and activated task are both locked here.
-- This is necessary because C.Common.State and Self.Common.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
-- If pragma Detect_Blocking is active, then we must check whether 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;
pragma Debug
(Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
Initialization.Defer_Abort_Nestable (Self_ID);
pragma Assert (Self_ID.Common.Wait_Count = 0);
-- Lock RTS_Lock, to prevent activated tasks from racing ahead before
-- we finish activating the chain.
Lock_RTS;
-- Check that all task bodies have been elaborated
C := Chain_Access.T_ID;
Last_C := null;
while C /= null loop
if C.Common.Elaborated /= null
and then not C.Common.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.Common.Activation_Link;
C.Common.Activation_Link := Last_C;
Last_C := C;
C := Next_C;
end loop;
Chain_Access.T_ID := Last_C;
if not All_Elaborated then
Unlock_RTS;
Initialization.Undefer_Abort_Nestable (Self_ID);
raise Program_Error with "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.Common.State /= Terminated then
pragma Assert (C.Common.State = Unactivated);
P := C.Common.Parent;
Write_Lock (P);
Write_Lock (C);
Activate_Prio :=
(if C.Common.Base_Priority < Get_Priority (Self_ID)
then Get_Priority (Self_ID)
else C.Common.Base_Priority);
System.Task_Primitives.Operations.Create_Task
(C, Task_Wrapper'Address,
Parameters.Size_Type
(C.Common.Compiler_Data.Pri_Stack_Info.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_RTS pair in the task wrapper to prevent it from
-- racing ahead.
if Success then
C.Common.State := Activating;
C.Awake_Count := 1;
C.Alive_Count := 1;
P.Awake_Count := P.Awake_Count + 1;
P.Alive_Count := P.Alive_Count + 1;
if P.Common.State = Master_Completion_Sleep and then
C.Master_Of_Task = P.Master_Within
then
pragma Assert (Self_ID /= P);
P.Common.Wait_Count := P.Common.Wait_Count + 1;
end if;
for J in System.Tasking.Debug.Known_Tasks'Range loop
if System.Tasking.Debug.Known_Tasks (J) = null then
System.Tasking.Debug.Known_Tasks (J) := C;
C.Known_Tasks_Index := J;
exit;
end if;
end loop;
if Global_Task_Debug_Event_Set then
Debug.Signal_Debug_Event
(Debug.Debug_Event_Activating, C);
end if;
C.Common.State := Runnable;
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.Common.Activation_Failed := True;
end if;
end if;
C := C.Common.Activation_Link;
end loop;
Unlock_RTS;
-- Close the entries of any tasks that failed thread creation, and count
-- those that have not finished activation.
Write_Lock (Self_ID);
Self_ID.Common.State := Activator_Sleep;
C := Chain_Access.T_ID;
while C /= null loop
Write_Lock (C);
if C.Common.State = Unactivated then
C.Common.Activator := null;
C.Common.State := Terminated;
C.Callable := False;
Utilities.Cancel_Queued_Entry_Calls (C);
elsif C.Common.Activator /= null then
Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
end if;
Unlock (C);
P := C.Common.Activation_Link;
C.Common.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
exit when Self_ID.Common.Wait_Count = 0;
Sleep (Self_ID, Activator_Sleep);
end loop;
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
-- Remove the tasks from the chain
Chain_Access.T_ID := null;
Initialization.Undefer_Abort_Nestable (Self_ID);
if Self_ID.Common.Activation_Failed then
Self_ID.Common.Activation_Failed := False;
raise Tasking_Error with "Failure during activation";
end if;
end Activate_Tasks;
-------------------------
-- Complete_Activation --
-------------------------
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;
---------------------
-- Complete_Master --
---------------------
procedure Complete_Master is
Self_ID : constant Task_Id := STPO.Self;
begin
pragma Assert
(Self_ID.Deferral_Level > 0
or else not System.Restrictions.Abort_Allowed);
Vulnerable_Complete_Master (Self_ID);
end Complete_Master;
-------------------
-- Complete_Task --
-------------------
-- 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
or else not System.Restrictions.Abort_Allowed);
Vulnerable_Complete_Task (Self_ID);
-- All of our dependents have terminated, never undefer abort again
end Complete_Task;
-----------------
-- 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;
Stack_Size : System.Parameters.Size_Type;
Secondary_Stack_Size : System.Parameters.Size_Type;
Task_Info : System.Task_Info.Task_Info_Type;
CPU : Integer;
Relative_Deadline : Ada.Real_Time.Time_Span;
Domain : Dispatching_Domain_Access;
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 : String;
Created_Task : out Task_Id)
is
T, P : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
Success : Boolean;
Base_Priority : System.Any_Priority;
Len : Natural;
Base_CPU : System.Multiprocessors.CPU_Range;
use type System.Multiprocessors.CPU_Range;
pragma Unreferenced (Relative_Deadline);
-- EDF scheduling is not supported by any of the target platforms so
-- this parameter is not passed any further.
begin
-- If Master is greater than the current master, it means that Master
-- has already awaited its dependent tasks. This raises Program_Error,
-- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
if Self_ID.Master_Of_Task /= Foreign_Task_Level
and then Master > Self_ID.Master_Within
then
raise Program_Error with
"create task after awaiting termination";
end if;
-- If pragma Detect_Blocking is active must be checked whether 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;
pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C'));
Base_Priority :=
(if Priority = Unspecified_Priority
then Self_ID.Common.Base_Priority
else System.Any_Priority (Priority));
-- Legal values of CPU are the special Unspecified_CPU value which is
-- inserted by the compiler for tasks without CPU aspect, and those in
-- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
-- the task is defined to have failed, and it becomes a completed task
-- (RM D.16(14/3)).
if CPU /= Unspecified_CPU
and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
or else
CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
then
raise Tasking_Error with "CPU not in range";
-- Normal CPU affinity
else
-- When the application code says nothing about the task affinity
-- (task without CPU aspect) then the compiler inserts the value
-- Unspecified_CPU which indicates to the run-time library that
-- the task will activate and execute on the same processor as its
-- activating task if the activating task is assigned a processor
-- (RM D.16(14/3)).
Base_CPU :=
(if CPU = Unspecified_CPU
then Self_ID.Common.Base_CPU
else System.Multiprocessors.CPU_Range (CPU));
end if;
-- Find parent P of new Task, via master level number. Independent
-- tasks should have Parent = Environment_Task, and all tasks created
-- by independent tasks are also independent. See, for example,
-- s-interr.adb, where Interrupt_Manager does "new Server_Task". The
-- access type is at library level, so the parent of the Server_Task
-- is Environment_Task.
P := Self_ID;
if P.Master_Of_Task <= Independent_Task_Level then
P := Environment_Task;
else
while P /= null and then P.Master_Of_Task >= Master loop
P := P.Common.Parent;
end loop;
end if;
Initialization.Defer_Abort_Nestable (Self_ID);
begin
T := New_ATCB (Num_Entries);
exception
when others =>
Initialization.Undefer_Abort_Nestable (Self_ID);
raise Storage_Error with "Cannot allocate task";
end;
-- RTS_Lock 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_RTS;
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 = Level_Completed_Task);
pragma Assert (Self_ID.Pending_Action);
pragma Assert
(Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
Unlock (Self_ID);
Unlock_RTS;
Initialization.Undefer_Abort_Nestable (Self_ID);
-- ??? Should never get here
pragma Assert (Standard.False);
raise Standard'Abort_Signal;
end if;
Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
Base_Priority, Base_CPU, Domain, Task_Info, Stack_Size, T, Success);
if not Success then
Free (T);
Unlock (Self_ID);
Unlock_RTS;
Initialization.Undefer_Abort_Nestable (Self_ID);
raise Storage_Error with "Failed to initialize task";
end if;
if Master = Foreign_Task_Level + 2 then
-- This should not happen, except when a foreign task creates non
-- library-level Ada tasks. In this case, we pretend the master is
-- a regular library level task, otherwise the run-time will get
-- confused when waiting for these tasks to terminate.
T.Master_Of_Task := Library_Task_Level;
else
T.Master_Of_Task := Master;
end if;
T.Master_Within := T.Master_Of_Task + 1;
for L in T.Entry_Calls'Range loop
T.Entry_Calls (L).Self := T;
T.Entry_Calls (L).Level := L;
end loop;
if Task_Image'Length = 0 then
T.Common.Task_Image_Len := 0;
else
Len := 1;
T.Common.Task_Image (1) := Task_Image (Task_Image'First);
-- Remove unwanted blank space generated by 'Image
for J in Task_Image'First + 1 .. Task_Image'Last loop
if Task_Image (J) /= ' '
or else Task_Image (J - 1) /= '('
then
Len := Len + 1;
T.Common.Task_Image (Len) := Task_Image (J);
exit when Len = T.Common.Task_Image'Last;
end if;
end loop;
T.Common.Task_Image_Len := Len;
end if;
-- Note: we used to have code here to initialize T.Common.Domain, but
-- that is not needed, since this is initialized in System.Tasking.
Unlock (Self_ID);
Unlock_RTS;
-- The CPU associated to the task (if any) must belong to the
-- dispatching domain.
if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
and then
(Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (Base_CPU))
then
Initialization.Undefer_Abort_Nestable (Self_ID);
raise Tasking_Error with "CPU not in dispatching domain";
end if;
-- To handle the interaction between pragma CPU and dispatching domains
-- we need to signal that this task is being allocated to a processor.
-- This is needed only for tasks belonging to the system domain (the
-- creation of new dispatching domains can only take processors from the
-- system domain) and only before the environment task calls the main
-- procedure (dispatching domains cannot be created after this).
if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
and then T.Common.Domain = System.Tasking.System_Domain
and then not System.Tasking.Dispatching_Domains_Frozen
then
-- Increase the number of tasks attached to the CPU to which this
-- task is being moved.
Dispatching_Domain_Tasks (Base_CPU) :=
Dispatching_Domain_Tasks (Base_CPU) + 1;
end if;
-- Create the secondary stack for the task as early as possible during
-- in the creation of a task, since it may be used by the operation of
-- Ada code within the task.
begin
SSL.Create_TSD (T.Common.Compiler_Data, null, Secondary_Stack_Size);
exception
when others =>
Initialization.Undefer_Abort_Nestable (Self_ID);
raise Storage_Error with "Secondary stack could not be allocated";
end;
T.Common.Activation_Link := Chain.T_ID;
Chain.T_ID := T;
Created_Task := T;
Initialization.Undefer_Abort_Nestable (Self_ID);
pragma Debug
(Debug.Trace
(Self_ID, "Created task in " & T.Master_Of_Task'Img, 'C', T));
end Create_Task;
--------------------
-- Current_Master --
--------------------
function Current_Master return Master_Level is
begin
return STPO.Self.Master_Within;
end Current_Master;
------------------
-- Enter_Master --
------------------
procedure Enter_Master is
Self_ID : constant Task_Id := STPO.Self;
begin
Self_ID.Master_Within := Self_ID.Master_Within + 1;
pragma Debug
(Debug.Trace
(Self_ID, "Enter_Master ->" & Self_ID.Master_Within'Img, 'M'));
end Enter_Master;
-------------------------------
-- Expunge_Unactivated_Tasks --
-------------------------------
-- 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.Common.State = Unactivated);
Temp := C.Common.Activation_Link;
if C.Common.State = Unactivated then
Lock_RTS;
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);
Unlock_RTS;
Vulnerable_Free_Task (C);
C := Temp;
end if;
end loop;
Chain.T_ID := null;
Initialization.Undefer_Abort_Nestable (Self_ID);
end Expunge_Unactivated_Tasks;
---------------------------
-- Finalize_Global_Tasks --
---------------------------
-- ???
-- 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.
procedure Finalize_Global_Tasks is
Self_ID : constant Task_Id := STPO.Self;
Ignore_1 : Boolean;
Ignore_2 : Boolean;
function State
(Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state for interrupt number Int. Defined in init.c
Default : constant Character := 's';
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
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.
Initialization.Defer_Abort_Nestable (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.
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
Lock_RTS;
Abort_Dependents (Self_ID);
Unlock_RTS;
-- We need to explicitly wait for the task to be terminated here
-- because on true concurrent system, we may end this procedure before
-- the tasks are really terminated.
Write_Lock (Self_ID);
-- If the Abort_Task signal is set to system, it means that we may
-- not have been able to abort all independent tasks (in particular,
-- Server_Task may be blocked, waiting for a signal), in which case, do
-- not wait for Independent_Task_Count to go down to 0. We arbitrarily
-- limit the number of loop iterations; if an independent task does not
-- terminate, we do not want to hang here. In that case, the thread will
-- be terminated when the process exits.
if State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then
for J in 1 .. 10 loop
exit when Utilities.Independent_Task_Count = 0;
-- We used to yield here, but this did not take into account low
-- priority tasks that would cause dead lock in some cases (true
-- FIFO scheduling).
Timed_Sleep
(Self_ID, 0.01, System.OS_Primitives.Relative,
Self_ID.Common.State, Ignore_1, Ignore_2);
end loop;
end if;
-- ??? On multi-processor environments, it seems that the above loop
-- isn't sufficient, so we need to add an additional delay.
Timed_Sleep
(Self_ID, 0.01, System.OS_Primitives.Relative,
Self_ID.Common.State, Ignore_1, Ignore_2);
Unlock (Self_ID);
-- Complete the environment task
Vulnerable_Complete_Task (Self_ID);
-- Handle normal task termination by the environment task, but only
-- for the normal task termination. In the case of Abnormal and
-- Unhandled_Exception they must have been handled before, and the
-- task termination soft link must have been changed so the task
-- termination routine is not executed twice.
SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
-- Finalize all library-level controlled objects
if not SSL."=" (SSL.Finalize_Library_Objects, null) then
SSL.Finalize_Library_Objects.all;
end if;
-- Reset the soft links to non-tasking
SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
SSL.Lock_Task := SSL.Task_Lock_NT'Access;
SSL.Unlock_Task := SSL.Task_Unlock_NT'Access;
SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
SSL.Get_Sec_Stack := SSL.Get_Sec_Stack_NT'Access;
SSL.Set_Sec_Stack := SSL.Set_Sec_Stack_NT'Access;
SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access;
-- Don't bother trying to finalize Initialization.Global_Task_Lock
-- and System.Task_Primitives.RTS_Lock.
end Finalize_Global_Tasks;
---------------
-- Free_Task --
---------------
procedure Free_Task (T : Task_Id) is
Self_Id : constant Task_Id := Self;
begin
Initialization.Task_Lock (Self_Id);
if T.Common.State = Terminated then
-- It is not safe to call Abort_Defer or Write_Lock at this stage
Lock_RTS;
Initialization.Finalize_Attributes (T);
Initialization.Remove_From_All_Tasks_List (T);
Unlock_RTS;
Initialization.Task_Unlock (Self_Id);
System.Task_Primitives.Operations.Finalize_TCB (T);
else
-- If the task is not terminated, then mark the task as to be freed
-- upon termination.
T.Free_On_Termination := True;
Initialization.Task_Unlock (Self_Id);
end if;
end Free_Task;
---------------------------
-- Move_Activation_Chain --
---------------------------
procedure Move_Activation_Chain
(From, To : Activation_Chain_Access;
New_Master : Master_ID)
is
Self_ID : constant Task_Id := STPO.Self;
C : Task_Id;
begin
pragma Debug
(Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
-- Nothing to do if From is empty, and we can check that without
-- deferring aborts.
C := From.all.T_ID;
if C = null then
return;
end if;
Initialization.Defer_Abort_Nestable (Self_ID);
-- Loop through the From chain, changing their Master_Of_Task fields,
-- and to find the end of the chain.
loop
C.Master_Of_Task := New_Master;
exit when C.Common.Activation_Link = null;
C := C.Common.Activation_Link;
end loop;
-- Hook From in at the start of To
C.Common.Activation_Link := To.all.T_ID;
To.all.T_ID := From.all.T_ID;
-- Set From to empty
From.all.T_ID := null;
Initialization.Undefer_Abort_Nestable (Self_ID);
end Move_Activation_Chain;
------------------
-- Task_Wrapper --
------------------
-- The task wrapper is a procedure that is called first for each 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 serve as per-task local data.
-- Task finalization is done by Complete_Task, which is called from an
-- at-end handler that the compiler generates.
procedure Task_Wrapper (Self_ID : Task_Id) is
use System.Standard_Library;
use System.Stack_Usage;
Bottom_Of_Stack : aliased Integer;
Task_Alternate_Stack :
aliased SSE.Storage_Array (1 .. Alternate_Stack_Size);
-- The alternate signal stack for this task, if any
Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
-- Whether to use above alternate signal stack for stack overflows
SEH_Table : aliased SSE.Storage_Array (1 .. 8);
-- Structured Exception Registration table (2 words)
procedure Install_SEH_Handler (Addr : System.Address);
pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
-- Install the SEH (Structured Exception Handling) handler
Cause : Cause_Of_Termination := Normal;
-- Indicates the reason why this task terminates. Normal corresponds to
-- a task terminating due to completing the last statement of its body,
-- or as a result of waiting on a terminate alternative. If the task
-- terminates because it is being aborted then Cause will be set
-- to Abnormal. If the task terminates because of an exception
-- raised by the execution of its task body, then Cause is set
-- to Unhandled_Exception.
EO : Exception_Occurrence;
-- If the task terminates because of an exception raised by the
-- execution of its task body, then EO will contain the associated
-- exception occurrence. Otherwise, it will contain Null_Occurrence.
TH : Termination_Handler := null;
-- Pointer to the protected procedure to be executed upon task
-- termination.
procedure Search_Fall_Back_Handler (ID : Task_Id);
-- Procedure that searches recursively a fall-back handler through the
-- master relationship. If the handler is found, its pointer is stored
-- in TH. It stops when the handler is found or when the ID is null.
------------------------------
-- Search_Fall_Back_Handler --
------------------------------
procedure Search_Fall_Back_Handler (ID : Task_Id) is
begin
-- A null Task_Id indicates that we have reached the root of the
-- task hierarchy and no handler has been found.
if ID = null then
return;
-- If there is a fall back handler, store its pointer for later
-- execution.
elsif ID.Common.Fall_Back_Handler /= null then
TH := ID.Common.Fall_Back_Handler;
-- Otherwise look for a fall back handler in the parent
else
Search_Fall_Back_Handler (ID.Common.Parent);
end if;
end Search_Fall_Back_Handler;
-- Start of processing for Task_Wrapper
begin
pragma Assert (Self_ID.Deferral_Level = 1);
Debug.Master_Hook
(Self_ID, Self_ID.Common.Parent, Self_ID.Master_Of_Task);
if Use_Alternate_Stack then
Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address;
end if;
-- 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.LL.Thread.
Enter_Task (Self_ID);
-- Initialize dynamic stack usage
if System.Stack_Usage.Is_Enabled then
declare
Guard_Page_Size : constant := 16 * 1024;
-- Part of the stack used as a guard page. This is an OS dependent
-- value, so we need to use the maximum. This value is only used
-- when the stack address is known, that is currently Windows.
Small_Overflow_Guard : constant := 12 * 1024;
-- Note: this used to be 4K, but was changed to 12K, since
-- smaller values resulted in segmentation faults from dynamic
-- stack analysis.
Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024;
-- These two values are experimental, and seem to work on most
-- platforms. They still need to be analyzed further. They also
-- need documentation, what are they and why does the logic differ
-- depending on whether the stack is large or small???
Pattern_Size : Natural :=
Natural (Self_ID.Common.
Compiler_Data.Pri_Stack_Info.Size);
-- Size of the pattern
Stack_Base : Address;
-- Address of the base of the stack
begin
Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base;
if Stack_Base = Null_Address then
-- On many platforms, we don't know the real stack base
-- address. Estimate it using an address in the frame.
Stack_Base := Bottom_Of_Stack'Address;
-- Adjustments for inner frames
Pattern_Size := Pattern_Size -
(if Pattern_Size < Big_Overflow_Guard
then Small_Overflow_Guard
else Big_Overflow_Guard);
else
-- Reduce by the size of the final guard page
Pattern_Size := Pattern_Size - Guard_Page_Size;
end if;
STPO.Lock_RTS;
Initialize_Analyzer
(Self_ID.Common.Analyzer,
Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len),
Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size),
SSE.To_Integer (Stack_Base),
Pattern_Size);
STPO.Unlock_RTS;
Fill_Stack (Self_ID.Common.Analyzer);
end;
end if;
-- We setup the SEH (Structured Exception Handling) handler if supported
-- on the target.
Install_SEH_Handler (SEH_Table'Address);
-- Initialize exception occurrence
Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
-- We lock RTS_Lock 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.Common.Activator.Common.Wait_Count.
Lock_RTS;
Unlock_RTS;
if not System.Restrictions.Abort_Allowed then
-- If Abort is not allowed, reset the deferral level since it will
-- not get changed by the generated code. Keeping a default value
-- of one would prevent some operations (e.g. select or delay) to
-- proceed successfully.
Self_ID.Deferral_Level := 0;
end if;
if Global_Task_Debug_Event_Set then
Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID);
end if;
declare
use Ada.Task_Initialization;
Global_Initialization_Handler : Initialization_Handler;
pragma Atomic (Global_Initialization_Handler);
pragma Import (Ada, Global_Initialization_Handler,
"__gnat_global_initialization_handler");
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 initialization hook if any
if Global_Initialization_Handler /= null then
Global_Initialization_Handler.all;
end if;
-- 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.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
Initialization.Defer_Abort_Nestable (Self_ID);
exception
-- We can't call Terminate_Task in the exception handlers below,
-- since there may be (e.g. in the case of GCC exception handling)
-- clean ups associated with the exception handler that need to
-- access task specific data.
-- Defer abort so that this task can't be aborted while exiting
when Standard'Abort_Signal =>
Initialization.Defer_Abort_Nestable (Self_ID);
-- Update the cause that motivated the task termination so that
-- the appropriate information is passed to the task termination
-- procedure. Task termination as a result of waiting on a
-- terminate alternative is a normal termination, although it is
-- implemented using the abort mechanisms.
if Self_ID.Terminate_Alternative then
Cause := Normal;
if Global_Task_Debug_Event_Set then
Debug.Signal_Debug_Event
(Debug.Debug_Event_Terminated, Self_ID);
end if;
else
Cause := Abnormal;
if Global_Task_Debug_Event_Set then
Debug.Signal_Debug_Event
(Debug.Debug_Event_Abort_Terminated, Self_ID);
end if;
end if;
when others =>
-- ??? Using an E : others here causes CD2C11A to fail on Tru64
Initialization.Defer_Abort_Nestable (Self_ID);
-- Perform the task specific exception tracing duty. We handle
-- these outputs here and not in the common notification routine
-- because we need access to tasking related data and we don't
-- want to drag dependencies against tasking related units in the
-- the common notification units. Additionally, no trace is ever
-- triggered from the common routine for the Unhandled_Raise case
-- in tasks, since an exception never appears unhandled in this
-- context because of this handler.
if Exception_Trace = Unhandled_Raise then
Trace_Unhandled_Exception_In_Task (Self_ID);
end if;
-- Update the cause that motivated the task termination so that
-- the appropriate information is passed to the task termination
-- procedure, as well as the associated Exception_Occurrence.
Cause := Unhandled_Exception;
Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
if Global_Task_Debug_Event_Set then
Debug.Signal_Debug_Event
(Debug.Debug_Event_Exception_Terminated, Self_ID);
end if;
end;
-- Look for a task termination handler. This code is for all tasks but
-- the environment task. The task termination code for the environment
-- task is executed by SSL.Task_Termination_Handler.
Write_Lock (Self_ID);
if Self_ID.Common.Specific_Handler /= null then
TH := Self_ID.Common.Specific_Handler;
-- Independent tasks should not call the Fall_Back_Handler (of the
-- environment task), because they are implementation artifacts that
-- should be invisible to Ada programs.
elsif Self_ID.Master_Of_Task /= Independent_Task_Level then
-- Look for a fall-back handler following the master relationship
-- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back
-- handler applies only to the dependent tasks of the task". Hence,
-- if the terminating tasks (Self_ID) had a fall-back handler, it
-- would not apply to itself, so we start the search with the parent.
Search_Fall_Back_Handler (Self_ID.Common.Parent);
end if;
Unlock (Self_ID);
-- Execute the task termination handler if we found it
if TH /= null then
begin
TH.all (Cause, Self_ID, EO);
exception
-- RM-C.7.3(16) requires all exceptions raised here to be ignored
when others =>
null;
end;
end if;
if System.Stack_Usage.Is_Enabled then
Compute_Result (Self_ID.Common.Analyzer);
Report_Result (Self_ID.Common.Analyzer);
end if;
Terminate_Task (Self_ID);
end Task_Wrapper;
--------------------
-- Terminate_Task --
--------------------
-- Before we allow the thread to exit, we must clean up. This is a delicate
-- job. We must wake up the task's master, who may immediately try to
-- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING.
-- To avoid this, the parent task must be blocked up to the latest
-- statement executed. The trouble is that we have another step that we
-- also want to postpone to the very end, i.e., calling SSL.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_Abort 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;
Master_Of_Task : Integer;
Deallocate : Boolean;
begin
Debug.Task_Termination_Hook;
-- Since GCC cannot allocate stack chunks efficiently without reordering
-- some of the allocations, we have to handle this unexpected situation
-- here. Normally we never have to call Vulnerable_Complete_Task here.
if Self_ID.Common.Activator /= null then
Vulnerable_Complete_Task (Self_ID);
end if;
Initialization.Task_Lock (Self_ID);
Master_Of_Task := Self_ID.Master_Of_Task;
-- Check if the current task is an independent task If so, decrement
-- the Independent_Task_Count value.
if Master_Of_Task = Independent_Task_Level 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);
Utilities.Make_Passive (Self_ID, Task_Completed => True);
Deallocate := Self_ID.Free_On_Termination;
pragma Assert (Check_Exit (Self_ID));
SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
Initialization.Final_Task_Unlock (Self_ID);
-- WARNING: past this point, this thread must assume that the ATCB has
-- been deallocated, and can't access it anymore (which is why we have
-- saved the Free_On_Termination flag in a temporary variable).
if Deallocate then
Free_Task (Self_ID);
end if;
if Master_Of_Task > 0 then
STPO.Exit_Task;
end if;
end Terminate_Task;
----------------
-- Terminated --
----------------
function Terminated (T : Task_Id) return Boolean is
Self_ID : constant Task_Id := STPO.Self;
Result : Boolean;
begin
Initialization.Defer_Abort_Nestable (Self_ID);
Write_Lock (T);
Result := T.Common.State = Terminated;
Unlock (T);
Initialization.Undefer_Abort_Nestable (Self_ID);
return Result;
end Terminated;
----------------------------------------
-- Trace_Unhandled_Exception_In_Task --
----------------------------------------
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
procedure To_Stderr (S : String);
pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
use System.Soft_Links;
function To_Address is new
Ada.Unchecked_Conversion
(Task_Id, System.Task_Primitives.Task_Address);
Excep : constant Exception_Occurrence_Access :=
SSL.Get_Current_Excep.all;
begin
-- This procedure is called by the task outermost handler in
-- Task_Wrapper below, so only once the task stack has been fully
-- unwound. The common notification routine has been called at the
-- raise point already.
-- Lock to prevent unsynchronized output
Initialization.Task_Lock (Self_Id);
To_Stderr ("task ");
if Self_Id.Common.Task_Image_Len /= 0 then
To_Stderr
(Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
To_Stderr ("_");
end if;
To_Stderr (System.Address_Image (To_Address (Self_Id)));
To_Stderr (" terminated by unhandled exception");
To_Stderr ([ASCII.LF]);
To_Stderr (Exception_Information (Excep.all));
Initialization.Task_Unlock (Self_Id);
end Trace_Unhandled_Exception_In_Task;
------------------------------------
-- Vulnerable_Complete_Activation --
------------------------------------
-- 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.
procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
Activator : constant Task_Id := Self_ID.Common.Activator;
begin
pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
Write_Lock (Activator);
Write_Lock (Self_ID);
pragma Assert (Self_ID.Common.Activator /= null);
-- Remove dangling reference to Activator, since a task may outlive its
-- activator.
Self_ID.Common.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.Common.State = Activator_Sleep then
Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
if Activator.Common.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 abort, we do not raise an exception.
-- See RM 9.2(5).
if not Self_ID.Callable
and then Self_ID.Pending_ATC_Level /= Level_Completed_Task
then
Activator.Common.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.Common.Base_Priority then
Write_Lock (Self_ID);
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
Unlock (Self_ID);
end if;
end Vulnerable_Complete_Activation;
--------------------------------
-- Vulnerable_Complete_Master --
--------------------------------
procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
C : Task_Id;
P : Task_Id;
CM : constant 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.
-----------------------------
-- Check_Unactivated_Tasks --
-----------------------------
function Check_Unactivated_Tasks return Boolean is
begin
Lock_RTS;
Write_Lock (Self_ID);
C := All_Tasks_List;
while C /= null loop
if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then
return False;
end if;
if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
Write_Lock (C);
if C.Common.State = Unactivated then
return False;
end if;
Unlock (C);
end if;
C := C.Common.All_Tasks_Link;
end loop;
Unlock (Self_ID);
Unlock_RTS;
return True;
end Check_Unactivated_Tasks;
-- Start of processing for Vulnerable_Complete_Master
begin
pragma Debug
(Debug.Trace (Self_ID, "V_Complete_Master(" & CM'Img & ")", 'C'));
pragma Assert (Self_ID.Common.Wait_Count = 0);
pragma Assert
(Self_ID.Deferral_Level > 0
or else not System.Restrictions.Abort_Allowed);
-- 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.
-- While we're counting, if we run across any unactivated tasks that
-- belong to this master, we summarily terminate them as required by
-- RM-9.2(6).
Lock_RTS;
Write_Lock (Self_ID);
C := All_Tasks_List;
while C /= null loop
-- Terminate unactivated (never-to-be activated) tasks
if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then
-- Usually, C.Common.Activator = Self_ID implies C.Master_Of_Task
-- = CM. The only case where C is pending activation by this
-- task, but the master of C is not CM is in Ada 2005, when C is
-- part of a return object of a build-in-place function.
pragma Assert (C.Common.State = Unactivated);
Write_Lock (C);
C.Common.Activator := null;
C.Common.State := Terminated;
C.Callable := False;
Utilities.Cancel_Queued_Entry_Calls (C);
Unlock (C);
end if;
-- Count it if directly dependent on this master
if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
Write_Lock (C);
if C.Awake_Count /= 0 then
Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
end if;
Unlock (C);
end if;
C := C.Common.All_Tasks_Link;
end loop;
Self_ID.Common.State := Master_Completion_Sleep;
Unlock (Self_ID);
Unlock_RTS;
-- 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 abort the
-- dependents, and resume waiting until Wait_Count goes to zero.
Write_Lock (Self_ID);
loop
exit when Self_ID.Common.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);
Lock_RTS;
Abort_Dependents (Self_ID);
Unlock_RTS;
Write_Lock (Self_ID);
else
pragma Debug
(Debug.Trace (Self_ID, "master_completion_sleep", 'C'));
Sleep (Self_ID, Master_Completion_Sleep);
end if;
end loop;
Self_ID.Common.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 tasks that are on terminate alternatives.
pragma Assert (Self_ID.Common.Wait_Count = 0);
-- Force any remaining dependents to terminate by aborting them
Lock_RTS;
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.Common.Wait_Count = 0);
Write_Lock (Self_ID);
C := All_Tasks_List;
while C /= null loop
if C.Common.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.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
end if;
Unlock (C);
end if;
C := C.Common.All_Tasks_Link;
end loop;
Self_ID.Common.State := Master_Phase_2_Sleep;
Unlock (Self_ID);
Unlock_RTS;
-- Wait for all counted tasks to finish terminating themselves
Write_Lock (Self_ID);
loop
exit when Self_ID.Common.Wait_Count = 0;
Sleep (Self_ID, Master_Phase_2_Sleep);
end loop;
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
end if;
-- We don't wake up for abort here. We are already terminating just as
-- fast as we can, so there is no point.
-- 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_RTS;
C := All_Tasks_List;
P := null;
while C /= null loop
-- If Free_On_Termination is set, do nothing here, and let the
-- task free itself if not already done, otherwise we risk a race
-- condition where Vulnerable_Free_Task is called in the loop below,
-- while the task calls Free_Task itself, in Terminate_Task.
if C.Common.Parent = Self_ID
and then C.Master_Of_Task >= CM
and then not C.Free_On_Termination
then
if P /= null then
P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
else
All_Tasks_List := C.Common.All_Tasks_Link;
end if;
T := C.Common.All_Tasks_Link;
C.Common.All_Tasks_Link := To_Be_Freed;
To_Be_Freed := C;
C := T;
else
P := C;
C := C.Common.All_Tasks_Link;
end if;
end loop;
Unlock_RTS;
-- 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.Common.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.Common.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 then Interrupt_Manager_ID /= null then
declare
Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
-- 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.Common.Parent /= null
and then T.Common.Parent.Common.Parent /= null)
or else T.Master_Of_Task > Library_Task_Level
then
Initialization.Task_Lock (Self_ID);
-- If Sec_Stack_Ptr is not null, it means that Destroy_TSD
-- has not been called yet (case of an unactivated task).
if T.Common.Compiler_Data.Sec_Stack_Ptr /= null then
SSL.Destroy_TSD (T.Common.Compiler_Data);
end if;
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;
Debug.Master_Completed_Hook (Self_ID, CM);
end Vulnerable_Complete_Master;
------------------------------
-- Vulnerable_Complete_Task --
------------------------------
-- Complete the calling task
-- This procedure must be called with abort deferred. It should only be
-- called by Complete_Task and Finalize_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.Common.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
or else not System.Restrictions.Abort_Allowed);
pragma Assert (Self_ID = Self);
pragma Assert
(Self_ID.Master_Within in
Self_ID.Master_Of_Task .. Self_ID.Master_Of_Task + 3);
pragma Assert (Self_ID.Common.Wait_Count = 0);
pragma Assert (Self_ID.Open_Accepts = null);
pragma Assert (Self_ID.ATC_Nesting_Level = Level_No_ATC_Occurring);
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.
Utilities.Cancel_Queued_Entry_Calls (Self_ID);
Unlock (Self_ID);
if Self_ID.Common.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 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;
--------------------------
-- 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.
procedure Vulnerable_Free_Task (T : Task_Id) is
begin
pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
Write_Lock (T);
Initialization.Finalize_Attributes (T);
Unlock (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
-- Package elaboration code
begin
-- Establish the Adafinal softlink
-- This is not done inside the central RTS initialization routine
-- to avoid with'ing this package from System.Tasking.Initialization.
SSL.Adafinal := Finalize_Global_Tasks'Access;
-- Establish soft links for subprograms that manipulate master_id's.
-- This cannot be done when the RTS is initialized, because of various
-- elaboration constraints.
SSL.Current_Master := Stages.Current_Master'Access;
SSL.Enter_Master := Stages.Enter_Master'Access;
SSL.Complete_Master := Stages.Complete_Master'Access;
end System.Tasking.Stages;