Subversion Repositories openrisc_me

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

--                                                                          --

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

--                                                                          --

--           S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S          --

--                                                                          --

--                                  B o d y                                 --

--                                                                          --

--         Copyright (C) 1998-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.     --

--                                                                          --

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

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

with Ada.Task_Identification;

with System.Task_Primitives.Operations;

with System.Tasking.Utilities;

with System.Tasking.Initialization;

with System.Tasking.Debug;

with System.OS_Primitives;

with System.Interrupt_Management.Operations;

with System.Parameters;

with System.Traces.Tasking;

package body System.Tasking.Async_Delays is

   package STPO renames System.Task_Primitives.Operations;

   package ST renames System.Tasking;

   package STU renames System.Tasking.Utilities;

   package STI renames System.Tasking.Initialization;

   package OSP renames System.OS_Primitives;

   use Parameters;

   use System.Traces;

   use System.Traces.Tasking;

   function To_System is new Ada.Unchecked_Conversion

     (Ada.Task_Identification.Task_Id, Task_Id);

   Timer_Server_ID : ST.Task_Id;

   Timer_Attention : Boolean := False;

   pragma Atomic (Timer_Attention);

   task Timer_Server is

      pragma Interrupt_Priority (System.Any_Priority'Last);

   end Timer_Server;

   --  The timer queue is a circular doubly linked list, ordered by absolute

   --  wakeup time. The first item in the queue is Timer_Queue.Succ.

   --  It is given a Resume_Time that is larger than any legitimate wakeup

   --  time, so that the ordered insertion will always stop searching when it

   --  gets back to the queue header block.

   Timer_Queue : aliased Delay_Block;

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

   -- Cancel_Async_Delay --

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

   --  This should (only) be called from the compiler-generated cleanup routine

   --  for an async. select statement with delay statement as trigger. The

   --  effect should be to remove the delay from the timer queue, and exit one

   --  ATC nesting level.

   --  The usage and logic are similar to Cancel_Protected_Entry_Call, but

   --  simplified because this is not a true entry call.

   procedure Cancel_Async_Delay (D : Delay_Block_Access) is

      Dpred : Delay_Block_Access;

      Dsucc : Delay_Block_Access;

   begin

      --  Note that we mark the delay as being cancelled

      --  using a level value that is reserved.

      --  make this operation idempotent

      if D.Level = ATC_Level_Infinity then

         return;

      end if;

      D.Level := ATC_Level_Infinity;

      --  remove self from timer queue

      STI.Defer_Abort_Nestable (D.Self_Id);

      if Single_Lock then

         STPO.Lock_RTS;

      end if;

      STPO.Write_Lock (Timer_Server_ID);

      Dpred := D.Pred;

      Dsucc := D.Succ;

      Dpred.Succ := Dsucc;

      Dsucc.Pred := Dpred;

      D.Succ := D;

      D.Pred := D;

      STPO.Unlock (Timer_Server_ID);

      --  Note that the above deletion code is required to be

      --  idempotent, since the block may have been dequeued

      --  previously by the Timer_Server.

      --  leave the asynchronous select

      STPO.Write_Lock (D.Self_Id);

      STU.Exit_One_ATC_Level (D.Self_Id);

      STPO.Unlock (D.Self_Id);

      if Single_Lock then

         STPO.Unlock_RTS;

      end if;

      STI.Undefer_Abort_Nestable (D.Self_Id);

   end Cancel_Async_Delay;

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

   -- Enqueue_Time_Duration --

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

   function Enqueue_Duration

     (T : Duration;

      D : Delay_Block_Access) return Boolean

   is

   begin

      if T <= 0.0 then

         D.Timed_Out := True;

         STPO.Yield;

         return False;

      else

         --  The corresponding call to Undefer_Abort is performed by the

         --  expanded code (see exp_ch9).

         STI.Defer_Abort (STPO.Self);

         Time_Enqueue

           (STPO.Monotonic_Clock

            + Duration'Min (T, OSP.Max_Sensible_Delay), D);

         return True;

      end if;

   end Enqueue_Duration;

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

   -- Time_Enqueue --

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

   --  Allocate a queue element for the wakeup time T and put it in the

   --  queue in wakeup time order.  Assume we are on an asynchronous

   --  select statement with delay trigger.  Put the calling task to

   --  sleep until either the delay expires or is cancelled.

   --  We use one entry call record for this delay, since we have

   --  to increment the ATC nesting level, but since it is not a

   --  real entry call we do not need to use any of the fields of

   --  the call record.  The following code implements a subset of

   --  the actions for the asynchronous case of Protected_Entry_Call,

   --  much simplified since we know this never blocks, and does not

   --  have the full semantics of a protected entry call.

   procedure Time_Enqueue

     (T : Duration;

      D : Delay_Block_Access)

   is

      Self_Id : constant Task_Id  := STPO.Self;

      Q       : Delay_Block_Access;

      use type ST.Task_Id;

      --  for visibility of operator "="

   begin

      pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));

      pragma Assert (Self_Id.Deferral_Level = 1,

        "async delay from within abort-deferred region");

      if Self_Id.ATC_Nesting_Level = ATC_Level'Last then

         raise Storage_Error with "not enough ATC nesting levels";

      end if;

      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;

      pragma Debug

        (Debug.Trace (Self_Id, "ASD: entered ATC level: " &

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

      D.Level := Self_Id.ATC_Nesting_Level;

      D.Self_Id := Self_Id;

      D.Resume_Time := T;

      if Single_Lock then

         STPO.Lock_RTS;

      end if;

      STPO.Write_Lock (Timer_Server_ID);

      --  Previously, there was code here to dynamically create

      --  the Timer_Server task, if one did not already exist.

      --  That code had a timing window that could allow multiple

      --  timer servers to be created. Luckily, the need for

      --  postponing creation of the timer server should now be

      --  gone, since this package will only be linked in if

      --  there are calls to enqueue calls on the timer server.

      --  Insert D in the timer queue, at the position determined

      --  by the wakeup time T.

      Q := Timer_Queue.Succ;

      while Q.Resume_Time < T loop

         Q := Q.Succ;

      end loop;

      --  Q is the block that has Resume_Time equal to or greater than

      --  T. After the insertion we want Q to be the successor of D.

      D.Succ := Q;

      D.Pred := Q.Pred;

      D.Pred.Succ := D;

      Q.Pred := D;

      --  If the new element became the head of the queue,

      --  signal the Timer_Server to wake up.

      if Timer_Queue.Succ = D then

         Timer_Attention := True;

         STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);

      end if;

      STPO.Unlock (Timer_Server_ID);

      if Single_Lock then

         STPO.Unlock_RTS;

      end if;

   end Time_Enqueue;

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

   -- Timed_Out --

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

   function Timed_Out (D : Delay_Block_Access) return Boolean is

   begin

      return D.Timed_Out;

   end Timed_Out;

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

   -- Timer_Server --

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

   task body Timer_Server is

      function Get_Next_Wakeup_Time return Duration;

      --  Used to initialize Next_Wakeup_Time, but also to ensure that

      --  Make_Independent is called during the elaboration of this task.

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

      -- Get_Next_Wakeup_Time --

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

      function Get_Next_Wakeup_Time return Duration is

      begin

         STU.Make_Independent;

         return Duration'Last;

      end Get_Next_Wakeup_Time;

      --  Local Declarations

      Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time;

      Timedout         : Boolean;

      Yielded          : Boolean;

      Now              : Duration;

      Dequeued         : Delay_Block_Access;

      Dequeued_Task    : Task_Id;

      pragma Unreferenced (Timedout, Yielded);

   begin

      Timer_Server_ID := STPO.Self;

      --  Since this package may be elaborated before System.Interrupt,

      --  we need to call Setup_Interrupt_Mask explicitly to ensure that

      --  this task has the proper signal mask.

      Interrupt_Management.Operations.Setup_Interrupt_Mask;

      --  Initialize the timer queue to empty, and make the wakeup time of the

      --  header node be larger than any real wakeup time we will ever use.

      loop

         STI.Defer_Abort (Timer_Server_ID);

         if Single_Lock then

            STPO.Lock_RTS;

         end if;

         STPO.Write_Lock (Timer_Server_ID);

         --  The timer server needs to catch pending aborts after finalization

         --  of library packages. If it doesn't poll for it, the server will

         --  sometimes hang.

         if not Timer_Attention then

            Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;

            if Next_Wakeup_Time = Duration'Last then

               Timer_Server_ID.User_State := 1;

               Next_Wakeup_Time :=

                 STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;

            else

               Timer_Server_ID.User_State := 2;

            end if;

            STPO.Timed_Sleep

              (Timer_Server_ID, Next_Wakeup_Time,

               OSP.Absolute_RT, ST.Timer_Server_Sleep,

               Timedout, Yielded);

            Timer_Server_ID.Common.State := ST.Runnable;

         end if;

         --  Service all of the wakeup requests on the queue whose times have

         --  been reached, and update Next_Wakeup_Time to next wakeup time

         --  after that (the wakeup time of the head of the queue if any, else

         --  a time far in the future).

         Timer_Server_ID.User_State := 3;

         Timer_Attention := False;

         Now := STPO.Monotonic_Clock;

         while Timer_Queue.Succ.Resume_Time <= Now loop

            --  Dequeue the waiting task from the front of the queue

            pragma Debug (System.Tasking.Debug.Trace

              (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));

            Dequeued := Timer_Queue.Succ;

            Timer_Queue.Succ := Dequeued.Succ;

            Dequeued.Succ.Pred := Dequeued.Pred;

            Dequeued.Succ := Dequeued;

            Dequeued.Pred := Dequeued;

            --  We want to abort the queued task to the level of the async.

            --  select statement with the delay. To do that, we need to lock

            --  the ATCB of that task, but to avoid deadlock we need to release

            --  the lock of the Timer_Server. This leaves a window in which

            --  another task might perform an enqueue or dequeue operation on

            --  the timer queue, but that is OK because we always restart the

            --  next iteration at the head of the queue.

            if Parameters.Runtime_Traces then

               Send_Trace_Info (E_Kill, Dequeued.Self_Id);

            end if;

            STPO.Unlock (Timer_Server_ID);

            STPO.Write_Lock (Dequeued.Self_Id);

            Dequeued_Task := Dequeued.Self_Id;

            Dequeued.Timed_Out := True;

            STI.Locked_Abort_To_Level

              (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);

            STPO.Unlock (Dequeued_Task);

            STPO.Write_Lock (Timer_Server_ID);

         end loop;

         Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;

         --  Service returns the Next_Wakeup_Time.

         --  The Next_Wakeup_Time is either an infinity (no delay request)

         --  or the wakeup time of the queue head. This value is used for

         --  an actual delay in this server.

         STPO.Unlock (Timer_Server_ID);

         if Single_Lock then

            STPO.Unlock_RTS;

         end if;

         STI.Undefer_Abort (Timer_Server_ID);

      end loop;

   end Timer_Server;

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

   -- Package Body Elaboration --

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

begin

   Timer_Queue.Succ := Timer_Queue'Access;

   Timer_Queue.Pred := Timer_Queue'Access;

   Timer_Queue.Resume_Time := Duration'Last;

   Timer_Server_ID := To_System (Timer_Server'Identity);

end System.Tasking.Async_Delays;