Subversion Repositories openrisc_me

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

--                                                                          --

--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --

--                                                                          --

--              S Y S T E M . T A S K I N G . U T I L I T I E S             --

--                                                                          --

--                                  B o d y                                 --

--                                                                          --

--         Copyright (C) 1992-2009, 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.     --

--                                                                          --

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

--  This package provides RTS Internal Declarations

--  These declarations are not part of the GNARLI

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 System.Tasking.Debug;

with System.Task_Primitives.Operations;

with System.Tasking.Initialization;

with System.Tasking.Queuing;

with System.Parameters;

with System.Traces.Tasking;

package body System.Tasking.Utilities is

   package STPO renames System.Task_Primitives.Operations;

   use Parameters;

   use Tasking.Debug;

   use Task_Primitives;

   use Task_Primitives.Operations;

   use System.Traces;

   use System.Traces.Tasking;

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

   -- Abort_One_Task --

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

   --  Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:

   --    (1) caller should be holding no locks except RTS_Lock when Single_Lock

   --    (2) may be called for tasks that have not yet been activated

   --    (3) always aborts whole task

   procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is

   begin

      if Parameters.Runtime_Traces then

         Send_Trace_Info (T_Abort, Self_ID, T);

      end if;

      Write_Lock (T);

      if T.Common.State = Unactivated then

         T.Common.Activator := null;

         T.Common.State := Terminated;

         T.Callable := False;

         Cancel_Queued_Entry_Calls (T);

      elsif T.Common.State /= Terminated then

         Initialization.Locked_Abort_To_Level (Self_ID, T, 0);

      end if;

      Unlock (T);

   end Abort_One_Task;

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

   -- Abort_Tasks --

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

   --  This must be called to implement the abort statement.

   --  Much of the actual work of the abort is done by the abortee,

   --  via the Abort_Handler signal handler, and propagation of the

   --  Abort_Signal special exception.

   procedure Abort_Tasks (Tasks : Task_List) is

      Self_Id : constant Task_Id := STPO.Self;

      C       : Task_Id;

      P       : Task_Id;

   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 Self_Id.Common.Protected_Action_Nesting > 0

      then

         raise Program_Error with "potentially blocking operation";

      end if;

      Initialization.Defer_Abort_Nestable (Self_Id);

      --  ?????

      --  Really should not be nested deferral here.

      --  Patch for code generation error that defers abort before

      --  evaluating parameters of an entry call (at least, timed entry

      --  calls), and so may propagate an exception that causes abort

      --  to remain undeferred indefinitely. See C97404B. When all

      --  such bugs are fixed, this patch can be removed.

      Lock_RTS;

      for J in Tasks'Range loop

         C := Tasks (J);

         Abort_One_Task (Self_Id, C);

      end loop;

      C := All_Tasks_List;

      while C /= null loop

         if C.Pending_ATC_Level > 0 then

            P := C.Common.Parent;

            while P /= null loop

               if P.Pending_ATC_Level = 0 then

                  Abort_One_Task (Self_Id, C);

                  exit;

               end if;

               P := P.Common.Parent;

            end loop;

         end if;

         C := C.Common.All_Tasks_Link;

      end loop;

      Unlock_RTS;

      Initialization.Undefer_Abort_Nestable (Self_Id);

   end Abort_Tasks;

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

   -- Cancel_Queued_Entry_Calls --

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

   --  This should only be called by T, unless T is a terminated previously

   --  unactivated task.

   procedure Cancel_Queued_Entry_Calls (T : Task_Id) is

      Next_Entry_Call : Entry_Call_Link;

      Entry_Call      : Entry_Call_Link;

      Self_Id         : constant Task_Id := STPO.Self;

      Caller : Task_Id;

      pragma Unreferenced (Caller);

      --  Should this be removed ???

      Level : Integer;

      pragma Unreferenced (Level);

      --  Should this be removed ???

   begin

      pragma Assert (T = Self or else T.Common.State = Terminated);

      for J in 1 .. T.Entry_Num loop

         Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call);

         while Entry_Call /= null loop

            --  Leave Entry_Call.Done = False, since this is cancelled

            Caller := Entry_Call.Self;

            Entry_Call.Exception_To_Raise := Tasking_Error'Identity;

            Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call);

            Level := Entry_Call.Level - 1;

            Unlock (T);

            Write_Lock (Entry_Call.Self);

            Initialization.Wakeup_Entry_Caller

              (Self_Id, Entry_Call, Cancelled);

            Unlock (Entry_Call.Self);

            Write_Lock (T);

            Entry_Call.State := Done;

            Entry_Call := Next_Entry_Call;

         end loop;

      end loop;

   end Cancel_Queued_Entry_Calls;

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

   -- Exit_One_ATC_Level --

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

   --  Call only with abort deferred and holding lock of Self_Id.

   --  This is a bit of common code for all entry calls.

   --  The effect is to exit one level of ATC nesting.

   --  If we have reached the desired ATC nesting level, reset the

   --  requested level to effective infinity, to allow further calls.

   --  In any case, reset Self_Id.Aborting, to allow re-raising of

   --  Abort_Signal.

   procedure Exit_One_ATC_Level (Self_ID : Task_Id) is

   begin

      Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;

      pragma Debug

        (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " &

         ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));

      pragma Assert (Self_ID.ATC_Nesting_Level >= 1);

      if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then

         if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then

            Self_ID.Pending_ATC_Level := ATC_Level_Infinity;

            Self_ID.Aborting := False;

         else

            --  Force the next Undefer_Abort to re-raise Abort_Signal

            pragma Assert

             (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level);

            if Self_ID.Aborting then

               Self_ID.ATC_Hack := True;

               Self_ID.Pending_Action := True;

            end if;

         end if;

      end if;

   end Exit_One_ATC_Level;

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

   -- Make_Independent --

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

   procedure Make_Independent is

      Self_Id               : constant Task_Id := STPO.Self;

      Environment_Task      : constant Task_Id := STPO.Environment_Task;

      Parent                : constant Task_Id := Self_Id.Common.Parent;

      Parent_Needs_Updating : Boolean := False;

      Master_of_Task        : Integer;

   begin

      if Self_Id.Known_Tasks_Index /= -1 then

         Known_Tasks (Self_Id.Known_Tasks_Index) := null;

      end if;

      Initialization.Defer_Abort (Self_Id);

      if Single_Lock then

         Lock_RTS;

      end if;

      Write_Lock (Environment_Task);

      Write_Lock (Self_Id);

      pragma Assert (Parent = Environment_Task

        or else Self_Id.Master_of_Task = Library_Task_Level);

      Master_of_Task := Self_Id.Master_of_Task;

      Self_Id.Master_of_Task := Independent_Task_Level;

      --  The run time assumes that the parent of an independent task is the

      --  environment task.

      if Parent /= Environment_Task then

         --  We cannot lock three tasks at the same time, so defer the

         --  operations on the parent.

         Parent_Needs_Updating := True;

         Self_Id.Common.Parent := Environment_Task;

      end if;

      --  Update Independent_Task_Count that is needed for the GLADE

      --  termination rule. See also pending update in

      --  System.Tasking.Stages.Check_Independent

      Independent_Task_Count := Independent_Task_Count + 1;

      Unlock (Self_Id);

      --  Changing the parent after creation is not trivial. Do not forget

      --  to update the old parent counts, and the new parent (i.e. the

      --  Environment_Task) counts.

      if Parent_Needs_Updating then

         Write_Lock (Parent);

         Parent.Awake_Count := Parent.Awake_Count - 1;

         Parent.Alive_Count := Parent.Alive_Count - 1;

         Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1;

         Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1;

         Unlock (Parent);

      end if;

      --  In case the environment task is already waiting for children to

      --  complete.

      --  ??? There may be a race condition if the environment task was not in

      --  master completion sleep when this task was created, but now is

      if Environment_Task.Common.State = Master_Completion_Sleep and then

        Master_of_Task = Environment_Task.Master_Within

      then

         Environment_Task.Common.Wait_Count :=

           Environment_Task.Common.Wait_Count - 1;

      end if;

      Unlock (Environment_Task);

      if Single_Lock then

         Unlock_RTS;

      end if;

      Initialization.Undefer_Abort (Self_Id);

   end Make_Independent;

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

   -- Make_Passive --

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

   procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is

      C : Task_Id := Self_ID;

      P : Task_Id := C.Common.Parent;

      Master_Completion_Phase : Integer;

   begin

      if P /= null then

         Write_Lock (P);

      end if;

      Write_Lock (C);

      if Task_Completed then

         Self_ID.Common.State := Terminated;

         if Self_ID.Awake_Count = 0 then

            --  We are completing via a terminate alternative.

            --  Our parent should wait in Phase 2 of Complete_Master.

            Master_Completion_Phase := 2;

            pragma Assert (Task_Completed);

            pragma Assert (Self_ID.Terminate_Alternative);

            pragma Assert (Self_ID.Alive_Count = 1);

         else

            --  We are NOT on a terminate alternative.

            --  Our parent should wait in Phase 1 of Complete_Master.

            Master_Completion_Phase := 1;

            pragma Assert (Self_ID.Awake_Count >= 1);

         end if;

      --  We are accepting with a terminate alternative

      else

         if Self_ID.Open_Accepts = null then

            --  Somebody started a rendezvous while we had our lock open.

            --  Skip the terminate alternative.

            Unlock (C);

            if P /= null then

               Unlock (P);

            end if;

            return;

         end if;

         Self_ID.Terminate_Alternative := True;

         Master_Completion_Phase := 0;

         pragma Assert (Self_ID.Terminate_Alternative);

         pragma Assert (Self_ID.Awake_Count >= 1);

      end if;

      if Master_Completion_Phase = 2 then

         --  Since our Awake_Count is zero but our Alive_Count

         --  is nonzero, we have been accepting with a terminate

         --  alternative, and we now have been told to terminate

         --  by a completed master (in some ancestor task) that

         --  is waiting (with zero Awake_Count) in Phase 2 of

         --  Complete_Master.

         pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M'));

         pragma Assert (P /= null);

         C.Alive_Count := C.Alive_Count - 1;

         if C.Alive_Count > 0 then

            Unlock (C);

            Unlock (P);

            return;

         end if;

         --  C's count just went to zero, indicating that

         --  all of C's dependents are terminated.

         --  C has a parent, P.

         loop

            --  C's count just went to zero, indicating that all of C's

            --  dependents are terminated. C has a parent, P. Notify P that

            --  C and its dependents have all terminated.

            P.Alive_Count := P.Alive_Count - 1;

            exit when P.Alive_Count > 0;

            Unlock (C);

            Unlock (P);

            C := P;

            P := C.Common.Parent;

            --  Environment task cannot have terminated yet

            pragma Assert (P /= null);

            Write_Lock (P);

            Write_Lock (C);

         end loop;

         if P.Common.State = Master_Phase_2_Sleep

           and then C.Master_of_Task = P.Master_Within

         then

            pragma Assert (P.Common.Wait_Count > 0);

            P.Common.Wait_Count := P.Common.Wait_Count - 1;

            if P.Common.Wait_Count = 0 then

               Wakeup (P, Master_Phase_2_Sleep);

            end if;

         end if;

         Unlock (C);

         Unlock (P);

         return;

      end if;

      --  We are terminating in Phase 1 or Complete_Master,

      --  or are accepting on a terminate alternative.

      C.Awake_Count := C.Awake_Count - 1;

      if Task_Completed then

         C.Alive_Count := C.Alive_Count - 1;

      end if;

      if C.Awake_Count > 0 or else P = null then

         Unlock (C);

         if P /= null then

            Unlock (P);

         end if;

         return;

      end if;

      --  C's count just went to zero, indicating that all of C's

      --  dependents are terminated or accepting with terminate alt.

      --  C has a parent, P.

      loop

         --  Notify P that C has gone passive

         if P.Awake_Count > 0 then

            P.Awake_Count := P.Awake_Count - 1;

         end if;

         if Task_Completed and then C.Alive_Count = 0 then

            P.Alive_Count := P.Alive_Count - 1;

         end if;

         exit when P.Awake_Count > 0;

         Unlock (C);

         Unlock (P);

         C := P;

         P := C.Common.Parent;

         if P = null then

            return;

         end if;

         Write_Lock (P);

         Write_Lock (C);

      end loop;

      --  P has non-passive dependents

      if P.Common.State = Master_Completion_Sleep

        and then C.Master_of_Task = P.Master_Within

      then

         pragma Debug

           (Debug.Trace

            (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M'));

         --  If parent is in Master_Completion_Sleep, it

         --  cannot be on a terminate alternative, hence

         --  it cannot have Awake_Count of zero.

         pragma Assert (P.Common.Wait_Count > 0);

         P.Common.Wait_Count := P.Common.Wait_Count - 1;

         if P.Common.Wait_Count = 0 then

            Wakeup (P, Master_Completion_Sleep);

         end if;

      else

         pragma Debug

           (Debug.Trace

             (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));

         null;

      end if;

      Unlock (C);

      Unlock (P);

   end Make_Passive;

end System.Tasking.Utilities;