CbC/CbC_gcc: gcc/ada/libgnarl/s-tassta.adb comparison

comparison gcc/ada/libgnarl/s-tassta.adb @ 111:04ced10e8804

gcc 7

author	kono
date	Fri, 27 Oct 2017 22:46:09 +0900
parents
children	84e7813d76e9

comparison

equal deleted inserted replaced

-:561a7518be6b
+:04ced10e8804
+------------------------------------------------------------------------------
+--                                                                          --
+--                 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-2017, 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 Polling (Off);
+--  Turn off polling, we do not want ATC polling to take place during tasking
+--  operations. It causes infinite loops and other problems.
+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 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 Parameters;
+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;
+if not Single_Lock then
+Unlock_RTS;
+end if;
+--  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);
+if Single_Lock then
+Unlock_RTS;
+end if;
+--  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);
+if Single_Lock then
+Lock_RTS;
+end if;
+Vulnerable_Complete_Activation (Self_ID);
+if Single_Lock then
+Unlock_RTS;
+end if;
+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 = 0);
+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 (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.Commmon.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);
+if not Single_Lock then
+Unlock_RTS;
+end if;
+--  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);
+if Single_Lock then
+Unlock_RTS;
+end if;
+--  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
+if T.Common.State = Terminated then
+--  It is not safe to call Abort_Defer or Write_Lock at this stage
+Initialization.Task_Lock (Self_Id);
+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;
+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;
+Small_Stack_Limit  : constant := 64 * 1024;
+--  ??? These three 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 < Small_Stack_Limit
+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;
+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.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.
+if Single_Lock then
+Lock_RTS;
+end if;
+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);
+if Single_Lock then
+Unlock_RTS;
+end if;
+--  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 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);
+if Single_Lock then
+Lock_RTS;
+end if;
+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
+if Single_Lock then
+Utilities.Independent_Task_Count :=
+Utilities.Independent_Task_Count - 1;
+else
+Write_Lock (Environment_Task);
+Utilities.Independent_Task_Count :=
+Utilities.Independent_Task_Count - 1;
+Unlock (Environment_Task);
+end if;
+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;
+if Single_Lock then
+Unlock_RTS;
+end if;
+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);
+if Single_Lock then
+Lock_RTS;
+end if;
+Write_Lock (T);
+Result := T.Common.State = Terminated;
+Unlock (T);
+if Single_Lock then
+Unlock_RTS;
+end if;
+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 ((1 => 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 /= 0 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
+if not Single_Lock then
+Lock_RTS;
+end if;
+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);
+if not Single_Lock then
+Unlock_RTS;
+end if;
+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);
+if not Single_Lock then
+Unlock_RTS;
+end if;
+--  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
+if Single_Lock then
+Abort_Dependents (Self_ID);
+else
+Unlock (Self_ID);
+Lock_RTS;
+Abort_Dependents (Self_ID);
+Unlock_RTS;
+Write_Lock (Self_ID);
+end if;
+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
+if not Single_Lock then
+Lock_RTS;
+end if;
+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);
+if not Single_Lock then
+Unlock_RTS;
+end if;
+--  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.
+if not Single_Lock then
+Lock_RTS;
+end if;
+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 + 1 ..  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 = 1);
+pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
+if Single_Lock then
+Lock_RTS;
+end if;
+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 Single_Lock then
+Unlock_RTS;
+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));
+if Single_Lock then
+Lock_RTS;
+end if;
+Write_Lock (T);
+Initialization.Finalize_Attributes (T);
+Unlock (T);
+if Single_Lock then
+Unlock_RTS;
+end if;
+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;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnarl/s-tassta.adb @ 111:04ced10e8804