{-# LANGUAGE CPP #-}
#if defined(javascript_HOST_ARCH)

{-# LANGUAGE Safe #-}
module GHC.Internal.Event.TimerManager () where

#else

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Trustworthy #-}

-- TODO: use the new Windows IO manager
module GHC.Internal.Event.TimerManager
    ( -- * Types
      TimerManager

      -- * Creation
    , new
    , newWith
    , newDefaultBackend
    , emControl

      -- * Running
    , finished
    , loop
    , step
    , shutdown
    , cleanup
    , wakeManager

      -- * Registering interest in timeout events
    , TimeoutCallback
    , TimeoutKey
    , registerTimeout
    , updateTimeout
    , unregisterTimeout
    ) where

#include "EventConfig.h"

------------------------------------------------------------------------
-- Imports

import GHC.Internal.Control.Exception (finally)
import GHC.Internal.Data.Foldable (sequence_)
import GHC.Internal.Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                   writeIORef)
import GHC.Internal.Base
import GHC.Internal.Clock (getMonotonicTimeNSec)
import GHC.Internal.Conc.Signal (runHandlers)
import GHC.Internal.Enum (maxBound)
import GHC.Internal.Num (Num(..))
import GHC.Internal.Real (quot, fromIntegral)
import GHC.Internal.Show (Show(..))
import GHC.Internal.Event.Control
import GHC.Internal.Event.Internal (Backend, Event, evtRead, Timeout(..))
import GHC.Internal.Event.Unique (UniqueSource, newSource, newUnique)
import GHC.Internal.Event.TimeOut
import GHC.Internal.System.Posix.Types (Fd)

import qualified GHC.Internal.Event.Internal as I
import qualified GHC.Internal.Event.PSQ as Q

#if defined(HAVE_POLL)
import qualified GHC.Internal.Event.Poll   as Poll
#else
# error not implemented for this operating system
#endif

------------------------------------------------------------------------
-- Types

data State = Created
           | Running
           | Dying
           | Finished
             deriving ( State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq   -- ^ @since base-4.7.0.0
                      , Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [State] -> ShowS
Show -- ^ @since base-4.7.0.0
                      )

-- | The event manager state.
data TimerManager = TimerManager
    { TimerManager -> Backend
emBackend      :: !Backend
    , TimerManager -> IORef TimeoutQueue
emTimeouts     :: {-# UNPACK #-} !(IORef TimeoutQueue)
    , TimerManager -> IORef State
emState        :: {-# UNPACK #-} !(IORef State)
    , TimerManager -> UniqueSource
emUniqueSource :: {-# UNPACK #-} !UniqueSource
    , TimerManager -> Control
emControl      :: {-# UNPACK #-} !Control
    }

------------------------------------------------------------------------
-- Creation

handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
handleControlEvent TimerManager
mgr Fd
fd Event
_evt = do
  msg <- Control -> Fd -> IO ControlMessage
readControlMessage (TimerManager -> Control
emControl TimerManager
mgr) Fd
fd
  case msg of
    ControlMessage
CMsgWakeup      -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ControlMessage
CMsgDie         -> IORef State -> State -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TimerManager -> IORef State
emState TimerManager
mgr) State
Finished
    CMsgSignal ForeignPtr Word8
fp Signal
s -> ForeignPtr Word8 -> Signal -> IO ()
runHandlers ForeignPtr Word8
fp Signal
s

newDefaultBackend :: IO Backend
#if defined(HAVE_POLL)
newDefaultBackend :: IO Backend
newDefaultBackend = IO Backend
Poll.new
#else
newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
#endif

-- | Create a new event manager.
new :: IO TimerManager
new :: IO TimerManager
new = Backend -> IO TimerManager
newWith (Backend -> IO TimerManager) -> IO Backend -> IO TimerManager
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Backend
newDefaultBackend

newWith :: Backend -> IO TimerManager
newWith :: Backend -> IO TimerManager
newWith Backend
be = do
  timeouts <- TimeoutQueue -> IO (IORef TimeoutQueue)
forall a. a -> IO (IORef a)
newIORef TimeoutQueue
forall v. IntPSQ v
Q.empty
  ctrl <- newControl True
  state <- newIORef Created
  us <- newSource
  _ <- mkWeakIORef state $ do
               st <- atomicModifyIORef' state $ \State
s -> (State
Finished, State
s)
               when (st /= Finished) $ do
                 I.delete be
                 closeControl ctrl
  let mgr = TimerManager { emBackend :: Backend
emBackend = Backend
be
                         , emTimeouts :: IORef TimeoutQueue
emTimeouts = IORef TimeoutQueue
timeouts
                         , emState :: IORef State
emState = IORef State
state
                         , emUniqueSource :: UniqueSource
emUniqueSource = UniqueSource
us
                         , emControl :: Control
emControl = Control
ctrl
                         }
  _ <- I.modifyFd be (controlReadFd ctrl) mempty evtRead
  _ <- I.modifyFd be (wakeupReadFd ctrl) mempty evtRead
  return mgr

-- | Asynchronously shuts down the event manager, if running.
shutdown :: TimerManager -> IO ()
shutdown :: TimerManager -> IO ()
shutdown TimerManager
mgr = do
  state <- IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef State
emState TimerManager
mgr) ((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \State
s -> (State
Dying, State
s)
  when (state == Running) $ sendDie (emControl mgr)

finished :: TimerManager -> IO Bool
finished :: TimerManager -> IO Bool
finished TimerManager
mgr = (State -> State -> Bool
forall a. Eq a => a -> a -> Bool
== State
Finished) (State -> Bool) -> IO State -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IORef State -> IO State
forall a. IORef a -> IO a
readIORef (TimerManager -> IORef State
emState TimerManager
mgr)

cleanup :: TimerManager -> IO ()
cleanup :: TimerManager -> IO ()
cleanup TimerManager
mgr = do
  IORef State -> State -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (TimerManager -> IORef State
emState TimerManager
mgr) State
Finished
  Backend -> IO ()
I.delete (TimerManager -> Backend
emBackend TimerManager
mgr)
  Control -> IO ()
closeControl (TimerManager -> Control
emControl TimerManager
mgr)

------------------------------------------------------------------------
-- Event loop

-- | Start handling events.  This function loops until told to stop,
-- using 'shutdown'.
--
-- /Note/: This loop can only be run once per 'TimerManager', as it
-- closes all of its control resources when it finishes.
loop :: TimerManager -> IO ()
loop :: TimerManager -> IO ()
loop TimerManager
mgr = do
  state <- IORef State -> (State -> (State, State)) -> IO State
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef State
emState TimerManager
mgr) ((State -> (State, State)) -> IO State)
-> (State -> (State, State)) -> IO State
forall a b. (a -> b) -> a -> b
$ \State
s -> case State
s of
    State
Created -> (State
Running, State
s)
    State
_       -> (State
s, State
s)
  case state of
    State
Created -> IO ()
go IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` TimerManager -> IO ()
cleanup TimerManager
mgr
    State
Dying   -> TimerManager -> IO ()
cleanup TimerManager
mgr
    State
_       -> do TimerManager -> IO ()
cleanup TimerManager
mgr
                  String -> IO ()
forall a. String -> a
errorWithoutStackTrace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"GHC.Internal.Event.Manager.loop: state is already " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                      State -> String
forall a. Show a => a -> String
show State
state
 where
  go :: IO ()
go = do running <- TimerManager -> IO Bool
step TimerManager
mgr
          when running go

step :: TimerManager -> IO Bool
step :: TimerManager -> IO Bool
step TimerManager
mgr = do
  timeout <- IO Timeout
mkTimeout
  _ <- I.poll (emBackend mgr) (Just timeout) (handleControlEvent mgr)
  state <- readIORef (emState mgr)
  state `seq` return (state == Running)
 where

  -- Call all expired timer callbacks and return the time to the
  -- next timeout.
  mkTimeout :: IO Timeout
  mkTimeout :: IO Timeout
mkTimeout = do
      now <- IO Word64
getMonotonicTimeNSec
      (expired, timeout) <- atomicModifyIORef' (emTimeouts mgr) $ \TimeoutQueue
tq ->
           let ([Elem (IO ())]
expired, TimeoutQueue
tq') = Word64 -> TimeoutQueue -> ([Elem (IO ())], TimeoutQueue)
forall v. Word64 -> IntPSQ v -> ([Elem v], IntPSQ v)
Q.atMost Word64
now TimeoutQueue
tq
               timeout :: Timeout
timeout = case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
tq' of
                 Maybe (Elem (IO ()), TimeoutQueue)
Nothing             -> Timeout
Forever
                 Just (Q.E Key
_ Word64
t IO ()
_, TimeoutQueue
_) ->
                     -- This value will always be positive since the call
                     -- to 'atMost' above removed any timeouts <= 'now'
                     let t' :: Word64
t' = Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
now in Word64
t' Word64 -> Timeout -> Timeout
forall a b. a -> b -> b
`seq` Word64 -> Timeout
Timeout Word64
t'
           in (TimeoutQueue
tq', ([Elem (IO ())]
expired, Timeout
timeout))
      sequence_ $ map Q.value expired
      return timeout

-- | Wake up the event manager.
wakeManager :: TimerManager -> IO ()
wakeManager :: TimerManager -> IO ()
wakeManager TimerManager
mgr = Control -> IO ()
sendWakeup (TimerManager -> Control
emControl TimerManager
mgr)

------------------------------------------------------------------------
-- Registering interest in timeout events

expirationTime :: Int -> IO Q.Prio
expirationTime :: Int -> IO Word64
expirationTime Int
us = do
    now <- IO Word64
getMonotonicTimeNSec
    let expTime
          -- Currently we treat overflows by clamping to maxBound. If humanity
          -- still exists in 2500 CE we will ned to be a bit more careful here.
          -- See #15158.
          | (Word64
forall a. Bounded a => a
maxBound Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
now) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
1000 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us  = Word64
forall a. Bounded a => a
maxBound
          | Bool
otherwise                                       = Word64
now Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
ns
          where ns :: Word64
ns = Word64
1000 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us
    return expTime

-- | Register a timeout in the given number of microseconds.  The
-- returned 'TimeoutKey' can be used to later unregister or update the
-- timeout.  The timeout is automatically unregistered after the given
-- time has passed.
--
-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
--
registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout :: TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
mgr Int
us IO ()
cb = do
  !key <- UniqueSource -> IO Key
newUnique (TimerManager -> UniqueSource
emUniqueSource TimerManager
mgr)
  if us <= 0 then cb
    else do
      expTime <- expirationTime us

      -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It
      -- doesn't because we just generated it from a unique supply.
      editTimeouts mgr (Q.unsafeInsertNew key expTime cb)
  return $ TK key

-- | Unregister an active timeout.
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
unregisterTimeout TimerManager
mgr (TK Key
key) =
  TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr (Key -> TimeoutEdit
forall v. Key -> IntPSQ v -> IntPSQ v
Q.delete Key
key)

-- | Update an active timeout to fire in the given number of
-- microseconds.
--
-- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
-- 2147483647 μs, less than 36 minutes.
--
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout TimerManager
mgr (TK Key
key) Int
us = do
  expTime <- Int -> IO Word64
expirationTime Int
us
  editTimeouts mgr (Q.adjust (const expTime) key)

editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr TimeoutEdit
g = do
  wake <- IORef TimeoutQueue
-> (TimeoutQueue -> (TimeoutQueue, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
emTimeouts TimerManager
mgr) TimeoutQueue -> (TimeoutQueue, Bool)
f
  when wake (wakeManager mgr)
  where
    f :: TimeoutQueue -> (TimeoutQueue, Bool)
f TimeoutQueue
q = (TimeoutQueue
q', Bool
wake)
      where
        q' :: TimeoutQueue
q' = TimeoutEdit
g TimeoutQueue
q
        wake :: Bool
wake = case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
q of
                Maybe (Elem (IO ()), TimeoutQueue)
Nothing -> Bool
True
                Just (Q.E Key
_ Word64
t0 IO ()
_, TimeoutQueue
_) ->
                  case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
Q.minView TimeoutQueue
q' of
                    Just (Q.E Key
_ Word64
t1 IO ()
_, TimeoutQueue
_) ->
                      -- don't wake the manager if the
                      -- minimum element didn't change.
                      Word64
t0 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
t1
                    Maybe (Elem (IO ()), TimeoutQueue)
_ -> Bool
True

#endif