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

-- TODO: use the new Windows IO manager
module GHC.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 Control.Exception (finally)
import Data.Foldable (sequence_)
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                   writeIORef)
import GHC.Base
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Conc.Signal (runHandlers)
import GHC.Enum (maxBound)
import GHC.Num (Num(..))
import GHC.Real (quot, fromIntegral)
import GHC.Show (Show(..))
import GHC.Event.Control
import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
import GHC.Event.Unique (UniqueSource, newSource, newUnique)
import GHC.Event.TimeOut
import System.Posix.Types (Fd)

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

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

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

data State = Created
           | Running
           | Dying
           | Finished
             deriving ( State -> State -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq   -- ^ @since 4.7.0.0
                      , Int -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show -- ^ @since 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
  ControlMessage
msg <- Control -> Fd -> IO ControlMessage
readControlMessage (TimerManager -> Control
emControl TimerManager
mgr) Fd
fd
  case ControlMessage
msg of
    ControlMessage
CMsgWakeup      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ControlMessage
CMsgDie         -> 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 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
  IORef TimeoutQueue
timeouts <- forall a. a -> IO (IORef a)
newIORef forall v. IntPSQ v
Q.empty
  Control
ctrl <- Bool -> IO Control
newControl Bool
True
  IORef State
state <- forall a. a -> IO (IORef a)
newIORef State
Created
  UniqueSource
us <- IO UniqueSource
newSource
  Weak (IORef State)
_ <- forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef State
state forall a b. (a -> b) -> a -> b
$ do
               State
st <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef State
state forall a b. (a -> b) -> a -> b
$ \State
s -> (State
Finished, State
s)
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State
st forall a. Eq a => a -> a -> Bool
/= State
Finished) forall a b. (a -> b) -> a -> b
$ do
                 Backend -> IO ()
I.delete Backend
be
                 Control -> IO ()
closeControl Control
ctrl
  let mgr :: TimerManager
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
                         }
  Bool
_ <- Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd Backend
be (Control -> Fd
controlReadFd Control
ctrl) forall a. Monoid a => a
mempty Event
evtRead
  Bool
_ <- Backend -> Fd -> Event -> Event -> IO Bool
I.modifyFd Backend
be (Control -> Fd
wakeupReadFd Control
ctrl) forall a. Monoid a => a
mempty Event
evtRead
  forall (m :: * -> *) a. Monad m => a -> m a
return TimerManager
mgr

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

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

cleanup :: TimerManager -> IO ()
cleanup :: TimerManager -> IO ()
cleanup TimerManager
mgr = do
  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
state <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef State
emState TimerManager
mgr) 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
state of
    State
Created -> IO ()
go 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
                  forall a. String -> a
errorWithoutStackTrace forall a b. (a -> b) -> a -> b
$ String
"GHC.Event.Manager.loop: state is already " forall a. [a] -> [a] -> [a]
++
                      forall a. Show a => a -> String
show State
state
 where
  go :: IO ()
go = do Bool
running <- TimerManager -> IO Bool
step TimerManager
mgr
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
running IO ()
go

step :: TimerManager -> IO Bool
step :: TimerManager -> IO Bool
step TimerManager
mgr = do
  Timeout
timeout <- IO Timeout
mkTimeout
  Int
_ <- Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
I.poll (TimerManager -> Backend
emBackend TimerManager
mgr) (forall a. a -> Maybe a
Just Timeout
timeout) (TimerManager -> Fd -> Event -> IO ()
handleControlEvent TimerManager
mgr)
  State
state <- forall a. IORef a -> IO a
readIORef (TimerManager -> IORef State
emState TimerManager
mgr)
  State
state seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (State
state forall a. Eq a => a -> a -> Bool
== State
Running)
 where

  -- | Call all expired timer callbacks and return the time to the
  -- next timeout.
  mkTimeout :: IO Timeout
  mkTimeout :: IO Timeout
mkTimeout = do
      Word64
now <- IO Word64
getMonotonicTimeNSec
      ([Elem (IO ())]
expired, Timeout
timeout) <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
emTimeouts TimerManager
mgr) forall a b. (a -> b) -> a -> b
$ \TimeoutQueue
tq ->
           let ([Elem (IO ())]
expired, TimeoutQueue
tq') = forall v. Word64 -> IntPSQ v -> ([Elem v], IntPSQ v)
Q.atMost Word64
now TimeoutQueue
tq
               timeout :: Timeout
timeout = case 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 forall a. Num a => a -> a -> a
- Word64
now in Word64
t' seq :: forall a b. a -> b -> b
`seq` Word64 -> Timeout
Timeout Word64
t'
           in (TimeoutQueue
tq', ([Elem (IO ())]
expired, Timeout
timeout))
      forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Elem a -> a
Q.value [Elem (IO ())]
expired
      forall (m :: * -> *) a. Monad m => a -> m a
return Timeout
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
    Word64
now <- IO Word64
getMonotonicTimeNSec
    let expTime :: Word64
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.
          | (forall a. Bounded a => a
maxBound forall a. Num a => a -> a -> a
- Word64
now) forall a. Integral a => a -> a -> a
`quot` Word64
1000 forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us  = forall a. Bounded a => a
maxBound
          | Bool
otherwise                                       = Word64
now forall a. Num a => a -> a -> a
+ Word64
ns
          where ns :: Word64
ns = Word64
1000 forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
us
    forall (m :: * -> *) a. Monad m => a -> m a
return Word64
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.
registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout :: TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
mgr Int
us IO ()
cb = do
  !Key
key <- UniqueSource -> IO Key
newUnique (TimerManager -> UniqueSource
emUniqueSource TimerManager
mgr)
  if Int
us forall a. Ord a => a -> a -> Bool
<= Int
0 then IO ()
cb
    else do
      Word64
expTime <- Int -> IO Word64
expirationTime Int
us

      -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It
      -- doesn't because we just generated it from a unique supply.
      TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr (forall v. Key -> Word64 -> v -> IntPSQ v -> IntPSQ v
Q.unsafeInsertNew Key
key Word64
expTime IO ()
cb)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key -> TimeoutKey
TK Key
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 (forall v. Key -> IntPSQ v -> IntPSQ v
Q.delete Key
key)

-- | Update an active timeout to fire in the given number of
-- microseconds.
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
updateTimeout TimerManager
mgr (TK Key
key) Int
us = do
  Word64
expTime <- Int -> IO Word64
expirationTime Int
us
  TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr (forall a. (Word64 -> Word64) -> Key -> PSQ a -> PSQ a
Q.adjust (forall a b. a -> b -> a
const Word64
expTime) Key
key)

editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts TimerManager
mgr TimeoutEdit
g = do
  Bool
wake <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
emTimeouts TimerManager
mgr) TimeoutQueue -> (TimeoutQueue, Bool)
f
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
wake (TimerManager -> IO ()
wakeManager TimerManager
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 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 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 forall a. Eq a => a -> a -> Bool
/= Word64
t1
                    Maybe (Elem (IO ()), TimeoutQueue)
_ -> Bool
True