Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                 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-2005, 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 2,  or (at your option) any later ver- --

-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNARL; see file COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- As a special exception,  if other files  instantiate  generics from this --

-- unit, or you link  this unit with other files  to produce an executable, --

-- this  unit  does not  by itself cause  the resulting  executable  to  be --

-- covered  by the  GNU  General  Public  License.  This exception does not --

-- however invalidate  any other reasons why  the executable file  might be --

-- covered by the  GNU Public License.                                      --

--                                                                          --

-- GNARL was developed by the GNARL team at Florida State University.       --

-- 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.

with Ada.Exceptions;

--  Used for Raise_Exception

with System.Tasking.Debug;

--  Used for enabling tasking facilities with gdb

with System.Address_Image;

--  Used for the function itself

with System.Parameters;

--  Used for Size_Type

--           Single_Lock

--           Runtime_Traces

with System.Task_Info;

--  Used for Task_Info_Type

with System.Task_Primitives.Operations;

--  Used for Finalize_Lock

--           Enter_Task

--           Write_Lock

--           Unlock

--           Sleep

--           Wakeup

--           Get_Priority

--           Lock/Unlock_RTS

--           New_ATCB

with System.Soft_Links;

--  These are procedure pointers to non-tasking routines that use task

--  specific data. In the absence of tasking, these routines refer to global

--  data. In the presense of tasking, they must be replaced with pointers to

--  task-specific versions. Also used for Create_TSD, Destroy_TSD,

--  Get_Current_Excep

with System.Tasking.Initialization;

--  Used for Remove_From_All_Tasks_List

--           Defer_Abort

--           Undefer_Abort

--           Initialization.Poll_Base_Priority_Change

--           Finalize_Attributes_Link

--           Initialize_Attributes_Link

pragma Elaborate_All (System.Tasking.Initialization);

--  This insures that tasking is initialized if any tasks are created

with System.Tasking.Utilities;

--  Used for Make_Passive

--           Abort_One_Task

with System.Tasking.Queuing;

--  Used for Dequeue_Head

with System.Tasking.Rendezvous;

--  Used for Call_Simple

with System.OS_Primitives;

--  Used for Delay_Modes

with System.Finalization_Implementation;

--  Used for System.Finalization_Implementation.Finalize_Global_List

with System.Secondary_Stack;

--  Used for SS_Init

with System.Storage_Elements;

--  Used for Storage_Array

with System.Restrictions;

--  Used for Abort_Allowed

with System.Standard_Library;

--  Used for Exception_Trace

with System.Traces.Tasking;

--  Used for Send_Trace_Info

with Unchecked_Deallocation;

--  To recover from failure of ATCB initialization

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;

   package SST  renames System.Secondary_Stack;

   use Ada.Exceptions;

   use Parameters;

   use Task_Primitives;

   use Task_Primitives.Operations;

   use Task_Info;

   use System.Traces;

   use System.Traces.Tasking;

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Free is new

     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.

   procedure Vulnerable_Complete_Task (Self_ID : Task_Id);

   --  Complete the calling task. This procedure must be called with

   --  abort deferred. It should only be called by Complete_Task and

   --  Finalizate_Global_Tasks (for the environment task).

   procedure Vulnerable_Complete_Master (Self_ID : Task_Id);

   --  Complete the current master of the calling task. This procedure

   --  must be called with abort deferred. It should only be called by

   --  Vulnerable_Complete_Task and Complete_Master.

   procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);

   --  Signal to Self_ID's activator that Self_ID has completed activation.

   --  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.

   --

   --  It is also called from Unchecked_Deallocation, for objects that

   --  are or contain tasks.

   --

   --  Different code is used at master completion, in Terminate_Dependents,

   --  due to a need for tighter synchronization with the master.

   ----------------------

   -- Abort_Dependents --

   ----------------------

   procedure Abort_Dependents (Self_ID : Task_Id) is

      C : Task_Id;

      P : Task_Id;

   begin

      C := All_Tasks_List;

      while C /= null loop

         P := C.Common.Parent;

         while P /= null loop

            if P = Self_ID then

               --  ??? C is supposed to take care of its own dependents, so

               --  there should be no need to worry about them. Need to double

               --  check this.

               if C.Master_of_Task = Self_ID.Master_Within then

                  Utilities.Abort_One_Task (Self_ID, C);

                  C.Dependents_Aborted := True;

               end if;

               exit;

            end if;

            P := P.Common.Parent;

         end loop;

         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

      --  If pragma Detect_Blocking is active then Program_Error must be

      --  raised if this potentially blocking operation is called from a

      --  protected action.

      if System.Tasking.Detect_Blocking

        and then STPO.Self.Common.Protected_Action_Nesting > 0

      then

         Ada.Exceptions.Raise_Exception

           (Program_Error'Identity, "potentially blocking operation");

      end if;

      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

         Ada.Exceptions.Raise_Exception

           (Program_Error'Identity, "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_Exception

           (Program_Error'Identity, "Some tasks have not been elaborated");

      end if;

      --  Activate all the tasks in the chain. Creation of the thread of

      --  control was deferred until activation. So create it now.

      C := Chain_Access.T_ID;

      while C /= null loop

         if C.Common.State /= Terminated then

            pragma Assert (C.Common.State = Unactivated);

            P := C.Common.Parent;

            Write_Lock (P);

            Write_Lock (C);

            if C.Common.Base_Priority < Get_Priority (Self_ID) then

               Activate_Prio := Get_Priority (Self_ID);

            else

               Activate_Prio := C.Common.Base_Priority;

            end if;

            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 := Runnable;

               C.Awake_Count := 1;

               C.Alive_Count := 1;

               P.Awake_Count := P.Awake_Count + 1;

               P.Alive_Count := P.Alive_Count + 1;

               if P.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;

               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

         Initialization.Poll_Base_Priority_Change (Self_ID);

         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_Exception (Tasking_Error'Identity,

           "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?

      if Runtime_Traces then

         Send_Trace_Info (T_Activate);

      end if;

   end Complete_Activation;

   ---------------------

   -- Complete_Master --

   ---------------------

   procedure Complete_Master is

      Self_ID : constant Task_Id := STPO.Self;

   begin

      pragma Assert (Self_ID.Deferral_Level > 0);

      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);

      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;

      Size          : System.Parameters.Size_Type;

      Task_Info     : System.Task_Info.Task_Info_Type;

      Num_Entries   : Task_Entry_Index;

      Master        : Master_Level;

      State         : Task_Procedure_Access;

      Discriminants : System.Address;

      Elaborated    : Access_Boolean;

      Chain         : in out Activation_Chain;

      Task_Image    : 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;

   begin

      --  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

         Ada.Exceptions.Raise_Exception

           (Program_Error'Identity, "potentially blocking operation");

      end if;

      pragma Debug

        (Debug.Trace (Self_ID, "Create_Task", 'C'));

      if Priority = Unspecified_Priority then

         Base_Priority := Self_ID.Common.Base_Priority;

      else

         Base_Priority := System.Any_Priority (Priority);

      end if;

      --  Find parent P of new Task, via master level number

      P := Self_ID;

      if P /= null then

         while P.Master_of_Task >= Master loop

            P := P.Common.Parent;

            exit when P = null;

         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_Exception (Storage_Error'Identity, "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, Task_Info, Size, T, Success);

      if not Success then

         Free (T);

         Unlock (Self_ID);

         Unlock_RTS;

         Initialization.Undefer_Abort_Nestable (Self_ID);

         Raise_Exception

           (Storage_Error'Identity, "Failed to initialize task");

      end if;

      T.Master_of_Task := Master;

      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;

      Unlock (Self_ID);

      Unlock_RTS;

      --  Create TSD as early as possible in the creation of a task, since it

      --  may be used by the operation of Ada code within the task.

      SSL.Create_TSD (T.Common.Compiler_Data);

      T.Common.Activation_Link := Chain.T_ID;

      Chain.T_ID := T;

      Initialization.Initialize_Attributes_Link.all (T);

      Created_Task := T;

      Initialization.Undefer_Abort_Nestable (Self_ID);

      if Runtime_Traces then

         Send_Trace_Info (T_Create, T);

      end if;

   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;

   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  : Boolean;

   begin

      if Self_ID.Deferral_Level = 0 then

         --  ???

         --  In principle, we should be able to predict whether

         --  abort is already deferred here (and it should not be deferred

         --  yet but in practice it seems Finalize_Global_Tasks is being

         --  called sometimes, from RTS code for exceptions, with abort already

         --  deferred.

         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 (cf 5619-003).

      Self_ID.Callable := False;

      --  Exit level 2 master, for normal tasks in library-level packages

      Complete_Master;

      --  Force termination of "independent" library-level server tasks

      Lock_RTS;

      Abort_Dependents (Self_ID);