Subversion Repositories openrisc

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

--                                                                          --

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

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

with System.Restrictions;

with System.Standard_Library;

with System.Traces.Tasking;

with System.Stack_Usage;

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;

   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

     Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);

   procedure Free_Entry_Names (T : Task_Id);

   --  Deallocate all string names associated with task entries

   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;

   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

      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?

      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

          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;

      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;

      Build_Entry_Names : Boolean)

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

      if CPU /= Unspecified_CPU

        and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)

                    or else

                  CPU > Integer (System.Multiprocessors.CPU_Range'Last)

                    or else

                  CPU > Integer (System.Multiprocessors.Number_Of_CPUs))

      then

         raise Tasking_Error with "CPU not in range";

      --  Normal CPU affinity

      else

         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

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

      --  The task inherits the dispatching domain of the parent only if no

      --  specific domain has been defined in the spec of the task (using the

      --  dispatching domain pragma or aspect).

      if T.Common.Domain /= null then

         null;

      elsif T.Common.Activator /= null then

         T.Common.Domain := T.Common.Activator.Common.Domain;

      else

         T.Common.Domain := System.Tasking.System_Domain;

      end if;

      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;

      --  Note: we should not call 'new' while holding locks since new may use

      --  locks (e.g. RTS_Lock under Windows) itself and cause a deadlock.

      if Build_Entry_Names then

         T.Entry_Names :=

           new Entry_Names_Array (1 .. Entry_Index (Num_Entries));

      end if;

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