{-|
Module      : Z.IO.LowResTimer
Description : Low resolution (0.1s) timing wheel
Copyright   : (c) Dong Han, 2017-2018
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable
This module provide low resolution (0.1s) timers using a timing wheel of size 128 per capability,
each timer thread will automatically started or stopped based on demannd. register or cancel a timeout is O(1),
and each step only need scan n/128 items given timers are registered in an even fashion.
This timer is particularly suitable for high concurrent approximated IO timeout scheduling.
You should not rely on it to provide timing information since it's very inaccurate.
Reference:
    * <https://github.com/netty/netty/blob/4.1/common/src/main/java/io/netty/util/HashedWheelTimer.java>
    * <http://www.cse.wustl.edu/~cdgill/courses/cs6874/TimingWheels.ppt>
-}


module Z.IO.LowResTimer
  ( -- * low resolution timers
    registerLowResTimer
  , registerLowResTimer_
  , registerLowResTimerOn
  , LowResTimer
  , queryLowResTimer
  , cancelLowResTimer
  , cancelLowResTimer_
  , timeoutLowRes
  , timeoutLowResEx
  , throttle
  , throttle_
  , throttleTrailing_
    -- * low resolution timer manager
  , LowResTimerManager
  , getLowResTimerManager
  , isLowResTimerManagerRunning
  , lowResTimerManagerCapabilitiesChanged
  ) where

import           Z.Data.Array
import           Data.Word
#ifndef mingw32_HOST_OS
import           GHC.Event
#endif
import           Control.Concurrent
import           Control.Monad
import           Data.IORef
import           GHC.Conc
import           System.IO.Unsafe
import           Z.Data.PrimRef.PrimIORef
import           Z.IO.Exception
import           Z.IO.UV.FFI    (uv_hrtime)

--
queueSize :: Int
queueSize :: Int
queueSize = Int
128

-- | A simple timing wheel
--
data TimerList = TimerItem {-# UNPACK #-} !Counter (IO ()) TimerList | TimerNil

data LowResTimerManager = LowResTimerManager
    (Array (IORef TimerList))
    -- timer queue
    (MVar Int)
    -- current time wheel's index
    Counter
    -- registered counter, stop timer thread if go downs to zero
    (MVar Bool)
    -- running lock

newLowResTimerManager :: IO LowResTimerManager
newLowResTimerManager :: IO LowResTimerManager
newLowResTimerManager = do
    MVar Int
indexLock <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
0
    Counter
regCounter <- Int -> IO Counter
newCounter Int
0
    MVar Bool
runningLock <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
False
    MutableArray RealWorld (IORef TimerList)
queue <- Int -> IO (MArr Array RealWorld (IORef TimerList))
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
Int -> m (MArr arr s a)
newArr Int
queueSize
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
queueSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
        MArr Array RealWorld (IORef TimerList)
-> Int -> IORef TimerList -> IO ()
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr Array RealWorld (IORef TimerList)
MutableArray RealWorld (IORef TimerList)
queue Int
i (IORef TimerList -> IO ()) -> IO (IORef TimerList) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TimerList -> IO (IORef TimerList)
forall a. a -> IO (IORef a)
newIORef TimerList
TimerNil
    Array (IORef TimerList)
iqueue <- MArr Array RealWorld (IORef TimerList)
-> IO (Array (IORef TimerList))
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> m (arr a)
unsafeFreezeArr MArr Array RealWorld (IORef TimerList)
MutableArray RealWorld (IORef TimerList)
queue
    LowResTimerManager -> IO LowResTimerManager
forall (m :: * -> *) a. Monad m => a -> m a
return (Array (IORef TimerList)
-> MVar Int -> Counter -> MVar Bool -> LowResTimerManager
LowResTimerManager Array (IORef TimerList)
iqueue MVar Int
indexLock Counter
regCounter MVar Bool
runningLock)

lowResTimerManager :: IORef (Array LowResTimerManager)
{-# NOINLINE lowResTimerManager #-}
lowResTimerManager :: IORef (Array LowResTimerManager)
lowResTimerManager = IO (IORef (Array LowResTimerManager))
-> IORef (Array LowResTimerManager)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Array LowResTimerManager))
 -> IORef (Array LowResTimerManager))
-> IO (IORef (Array LowResTimerManager))
-> IORef (Array LowResTimerManager)
forall a b. (a -> b) -> a -> b
$ do
    Int
numCaps <- IO Int
getNumCapabilities
    MutableArray RealWorld LowResTimerManager
lrtmArray <- Int -> IO (MArr Array RealWorld LowResTimerManager)
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
Int -> m (MArr arr s a)
newArr Int
numCaps
    [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
numCapsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
        MArr Array RealWorld LowResTimerManager
-> Int -> LowResTimerManager -> IO ()
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr Array RealWorld LowResTimerManager
MutableArray RealWorld LowResTimerManager
lrtmArray Int
i (LowResTimerManager -> IO ()) -> IO LowResTimerManager -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LowResTimerManager
newLowResTimerManager
    Array LowResTimerManager
ilrtmArray <- MArr Array RealWorld LowResTimerManager
-> IO (Array LowResTimerManager)
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> m (arr a)
unsafeFreezeArr MArr Array RealWorld LowResTimerManager
MutableArray RealWorld LowResTimerManager
lrtmArray
    Array LowResTimerManager -> IO (IORef (Array LowResTimerManager))
forall a. a -> IO (IORef a)
newIORef Array LowResTimerManager
ilrtmArray

-- | Create new low resolution timer manager on capability change.
--
-- Since low resolution timer manager is not hooked into RTS, you're responsible to call this function
-- after you call 'setNumCapabilities' to match timer manager array size with new capability number.
--
-- This is not a must though, when we fetch timer manager we always take a modulo.
--
lowResTimerManagerCapabilitiesChanged :: IO ()
lowResTimerManagerCapabilitiesChanged :: IO ()
lowResTimerManagerCapabilitiesChanged = do
    Array LowResTimerManager
lrtmArray <- IORef (Array LowResTimerManager) -> IO (Array LowResTimerManager)
forall a. IORef a -> IO a
readIORef IORef (Array LowResTimerManager)
lowResTimerManager
    let oldSize :: Int
oldSize = Array LowResTimerManager -> Int
forall (arr :: * -> *) a. Arr arr a => arr a -> Int
sizeofArr Array LowResTimerManager
lrtmArray
    Int
numCaps <- IO Int
getNumCapabilities
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numCaps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
oldSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        MutableArray RealWorld LowResTimerManager
lrtmArray' <- Int -> IO (MArr Array RealWorld LowResTimerManager)
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
Int -> m (MArr arr s a)
newArr Int
numCaps
        if Int
numCaps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
oldSize
        then do
            [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
numCapsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
                MArr Array RealWorld LowResTimerManager
-> Int -> LowResTimerManager -> IO ()
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr Array RealWorld LowResTimerManager
MutableArray RealWorld LowResTimerManager
lrtmArray' Int
i (LowResTimerManager -> IO ()) -> IO LowResTimerManager -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Array LowResTimerManager -> Int -> IO LowResTimerManager
forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m) =>
arr a -> Int -> m a
indexArrM Array LowResTimerManager
lrtmArray Int
i
        else do
            [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
oldSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
                MArr Array RealWorld LowResTimerManager
-> Int -> LowResTimerManager -> IO ()
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr Array RealWorld LowResTimerManager
MutableArray RealWorld LowResTimerManager
lrtmArray' Int
i (LowResTimerManager -> IO ()) -> IO LowResTimerManager -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Array LowResTimerManager -> Int -> IO LowResTimerManager
forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m) =>
arr a -> Int -> m a
indexArrM Array LowResTimerManager
lrtmArray Int
i
            [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
oldSize..Int
numCapsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
                MArr Array RealWorld LowResTimerManager
-> Int -> LowResTimerManager -> IO ()
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr Array RealWorld LowResTimerManager
MutableArray RealWorld LowResTimerManager
lrtmArray' Int
i (LowResTimerManager -> IO ()) -> IO LowResTimerManager -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LowResTimerManager
newLowResTimerManager

        Array LowResTimerManager
ilrtmArray' <- MArr Array RealWorld LowResTimerManager
-> IO (Array LowResTimerManager)
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> m (arr a)
unsafeFreezeArr MArr Array RealWorld LowResTimerManager
MutableArray RealWorld LowResTimerManager
lrtmArray'
        IORef (Array LowResTimerManager)
-> (Array LowResTimerManager -> (Array LowResTimerManager, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Array LowResTimerManager)
lowResTimerManager ((Array LowResTimerManager -> (Array LowResTimerManager, ()))
 -> IO ())
-> (Array LowResTimerManager -> (Array LowResTimerManager, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \ Array LowResTimerManager
_ -> (Array LowResTimerManager
ilrtmArray', ())

-- | Get a 'LowResTimerManager' for current thread.
--
getLowResTimerManager :: IO LowResTimerManager
getLowResTimerManager :: IO LowResTimerManager
getLowResTimerManager = do
    (Int
cap, Bool
_) <- ThreadId -> IO (Int, Bool)
threadCapability (ThreadId -> IO (Int, Bool)) -> IO ThreadId -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
    Array LowResTimerManager
lrtmArray <- IORef (Array LowResTimerManager) -> IO (Array LowResTimerManager)
forall a. IORef a -> IO a
readIORef IORef (Array LowResTimerManager)
lowResTimerManager
    Array LowResTimerManager -> Int -> IO LowResTimerManager
forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m) =>
arr a -> Int -> m a
indexArrM Array LowResTimerManager
lrtmArray (Int
cap Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Array LowResTimerManager -> Int
forall (arr :: * -> *) a. Arr arr a => arr a -> Int
sizeofArr Array LowResTimerManager
lrtmArray)

-- | Check if a timer manager's wheel is turning
--
-- This is mostly for testing purpose.
--
isLowResTimerManagerRunning :: LowResTimerManager -> IO Bool
isLowResTimerManagerRunning :: LowResTimerManager -> IO Bool
isLowResTimerManagerRunning (LowResTimerManager Array (IORef TimerList)
_ MVar Int
_ Counter
_ MVar Bool
runningLock) = MVar Bool -> IO Bool
forall a. MVar a -> IO a
readMVar MVar Bool
runningLock

-- | Register a new timer on current capability's timer manager, start the timing wheel if it's not turning.
--
-- If the action could block, you may want to run it in another thread. Example to kill a thread after 10s:
--
-- @
--   registerLowResTimer 100 (forkIO $ killThread tid)
-- @
--
registerLowResTimer :: Int          -- ^ timeout in unit of 0.1s
                    -> IO ()        -- ^ the action you want to perform, it should not block
                    -> IO LowResTimer
registerLowResTimer :: Int -> IO () -> IO LowResTimer
registerLowResTimer Int
t IO ()
action = do
    LowResTimerManager
lrtm <- IO LowResTimerManager
getLowResTimerManager
    LowResTimerManager -> Int -> IO () -> IO LowResTimer
registerLowResTimerOn LowResTimerManager
lrtm Int
t IO ()
action

-- | 'void' ('registerLowResTimer' t action)
registerLowResTimer_ :: Int          -- ^ timeout in unit of 0.1s
                     -> IO ()        -- ^ the action you want to perform, it should not block
                     -> IO ()
registerLowResTimer_ :: Int -> IO () -> IO ()
registerLowResTimer_ Int
t IO ()
action = IO LowResTimer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> IO () -> IO LowResTimer
registerLowResTimer Int
t IO ()
action)

-- | Same as 'registerLowResTimer', but allow you choose timer manager.
--
registerLowResTimerOn :: LowResTimerManager   -- ^ a low resolution timer manager
                      -> Int          -- ^ timeout in unit of 0.1s
                      -> IO ()        -- ^ the action you want to perform, it should not block
                      -> IO LowResTimer
registerLowResTimerOn :: LowResTimerManager -> Int -> IO () -> IO LowResTimer
registerLowResTimerOn lrtm :: LowResTimerManager
lrtm@(LowResTimerManager Array (IORef TimerList)
queue MVar Int
indexLock Counter
regCounter MVar Bool
_) Int
t IO ()
action = do

    let (Int
round_, Int
tick) = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
t) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
queueSize
    Int
i <- MVar Int -> IO Int
forall a. MVar a -> IO a
readMVar MVar Int
indexLock
    IORef TimerList
tlistRef <- Array (IORef TimerList) -> Int -> IO (IORef TimerList)
forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m) =>
arr a -> Int -> m a
indexArrM Array (IORef TimerList)
queue ((Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tick) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
queueSize)
    Counter
roundCounter <- Int -> IO Counter
newCounter Int
round_
    IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IORef TimerList -> (TimerList -> (TimerList, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef TimerList
tlistRef ((TimerList -> (TimerList, ())) -> IO ())
-> (TimerList -> (TimerList, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ TimerList
tlist ->
            let newList :: TimerList
newList = Counter -> IO () -> TimerList -> TimerList
TimerItem Counter
roundCounter IO ()
action TimerList
tlist
            in (TimerList
newList, ())
        Counter -> Int -> IO ()
atomicAddCounter_ Counter
regCounter Int
1

    LowResTimerManager -> IO ()
ensureLowResTimerManager LowResTimerManager
lrtm

    LowResTimer -> IO LowResTimer
forall (m :: * -> *) a. Monad m => a -> m a
return (Counter -> LowResTimer
LowResTimer Counter
roundCounter)  -- cancel is simple, just set the round number to -1.
                                       -- next scan will eventually release it

-- | Timer registered by 'registerLowResTimer' or 'registerLowResTimerOn'.
--
newtype LowResTimer = LowResTimer Counter

-- | Query how many seconds remain before timer firing.
--
-- A return value <= 0 indictate the timer is firing or fired.
--
queryLowResTimer :: LowResTimer -> IO Int
queryLowResTimer :: LowResTimer -> IO Int
queryLowResTimer (LowResTimer Counter
c) = Counter -> IO Int
forall a. Prim a => PrimIORef a -> IO a
readPrimIORef Counter
c

-- | Cancel a timer, return the remaining ticks.
--
-- This function have no effect after the timer is fired.
--
cancelLowResTimer :: LowResTimer -> IO Int
cancelLowResTimer :: LowResTimer -> IO Int
cancelLowResTimer (LowResTimer Counter
c) = Counter -> Int -> IO Int
atomicOrCounter Counter
c (-Int
1)

-- | @void . cancelLowResTimer@
--
cancelLowResTimer_ :: LowResTimer -> IO ()
cancelLowResTimer_ :: LowResTimer -> IO ()
cancelLowResTimer_ = IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ())
-> (LowResTimer -> IO Int) -> LowResTimer -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LowResTimer -> IO Int
cancelLowResTimer

-- | similar to 'System.Timeout.timeout', this function put a limit on time which an IO can consume.
--
-- Note timeoutLowRes is also implemented with 'Exception' underhood, which can have some surprising
-- effects on some devices, e.g. use 'timeoutLowRes' with reading or writing on 'UVStream's may close
-- the 'UVStream' once a reading or writing is not able to be done in time.
timeoutLowRes :: Int    -- ^ timeout in unit of 0.1s
              -> IO a
              -> IO (Maybe a)
timeoutLowRes :: Int -> IO a -> IO (Maybe a)
timeoutLowRes Int
timeo IO a
io = do
    ThreadId
mid <- IO ThreadId
myThreadId
    IO (Maybe a) -> (TimeOutException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
        (do LowResTimer
timer <- Int -> IO () -> IO LowResTimer
registerLowResTimer Int
timeo (ThreadId -> IO ()
timeoutAThread ThreadId
mid)
            a
r <- IO a
io
            Int
_ <- LowResTimer -> IO Int
cancelLowResTimer LowResTimer
timer
            Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
r))
        ( \ (TimeOutException
_ :: TimeOutException) -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing )
  where
    timeoutAThread :: ThreadId -> IO ()
timeoutAThread ThreadId
tid = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> TimeOutException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (ThreadId -> CallStack -> TimeOutException
TimeOutException ThreadId
tid CallStack
forall a. HasCallStack => a
undefined)

-- | Similar to 'timeoutLowRes', but raise a 'TimeOutException' to current thread
-- instead of return 'Nothing' if timeout.
timeoutLowResEx :: HasCallStack
                => Int    -- ^ timeout in unit of 0.1s
                -> IO a
                -> IO a
timeoutLowResEx :: Int -> IO a -> IO a
timeoutLowResEx Int
timeo IO a
io = do
    ThreadId
mid <- IO ThreadId
myThreadId
    LowResTimer
timer <- Int -> IO () -> IO LowResTimer
registerLowResTimer Int
timeo (ThreadId -> IO ()
timeoutAThread ThreadId
mid)
    a
r <- IO a
io
    Int
_ <- LowResTimer -> IO Int
cancelLowResTimer LowResTimer
timer
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  where
    timeoutAThread :: ThreadId -> IO ()
timeoutAThread ThreadId
tid = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> TimeOutException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (ThreadId -> CallStack -> TimeOutException
TimeOutException ThreadId
tid CallStack
HasCallStack => CallStack
callStack)

data TimeOutException = TimeOutException ThreadId CallStack deriving Int -> TimeOutException -> ShowS
[TimeOutException] -> ShowS
TimeOutException -> String
(Int -> TimeOutException -> ShowS)
-> (TimeOutException -> String)
-> ([TimeOutException] -> ShowS)
-> Show TimeOutException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeOutException] -> ShowS
$cshowList :: [TimeOutException] -> ShowS
show :: TimeOutException -> String
$cshow :: TimeOutException -> String
showsPrec :: Int -> TimeOutException -> ShowS
$cshowsPrec :: Int -> TimeOutException -> ShowS
Show
instance Exception TimeOutException

--------------------------------------------------------------------------------
-- | Check if low resolution timer manager loop is running, start loop if not.
--
ensureLowResTimerManager :: LowResTimerManager -> IO ()
ensureLowResTimerManager :: LowResTimerManager -> IO ()
ensureLowResTimerManager lrtm :: LowResTimerManager
lrtm@(LowResTimerManager Array (IORef TimerList)
_ MVar Int
_ Counter
_ MVar Bool
runningLock) = do
    MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
runningLock ((Bool -> IO Bool) -> IO ()) -> (Bool -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Bool
running -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
running (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Word64
t <- IO Word64
uv_hrtime
            ThreadId
tid <- IO () -> IO ThreadId
forkIO (LowResTimerManager -> Word64 -> IO ()
startLowResTimerManager LowResTimerManager
lrtm Word64
t)
            ThreadId -> String -> IO ()
labelThread ThreadId
tid String
"Z-IO: low resolution time manager"    -- make sure we can see it in GHC event log
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Start low resolution timer loop, the loop is automatically stopped if there's no more new registrations.
--
startLowResTimerManager :: LowResTimerManager -> Word64 -> IO ()
startLowResTimerManager :: LowResTimerManager -> Word64 -> IO ()
startLowResTimerManager lrtm :: LowResTimerManager
lrtm@(LowResTimerManager Array (IORef TimerList)
_ MVar Int
_ Counter
regCounter MVar Bool
runningLock) !Word64
stdT = do
    MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
runningLock ((Bool -> IO Bool) -> IO ()) -> (Bool -> IO Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Bool
_ -> do     -- we shouldn't receive async exception here
        Int
c <- Counter -> IO Int
forall a. Prim a => PrimIORef a -> IO a
readPrimIORef Counter
regCounter          -- unless something terribly wrong happened, e.g., stackoverflow
        if Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        then do
            Word64
t <- IO Word64
uv_hrtime 
            -- we can't use 100000 as maximum, because that will produce a 0us thread delay
            -- and GHC's registerTimeout will run next startLowResTimerManager directly(on current thread)
            -- but we're still holding runningLock, which cause an deadlock.
            let !deltaT :: Int
deltaT = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
stdT) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`quot` Word64
1000)) Int
99999
            ThreadId
_ <- IO () -> IO ThreadId
forkIO (LowResTimerManager -> IO ()
fireLowResTimerQueue LowResTimerManager
lrtm)  -- we offload the scanning to another thread to minimize
                                                -- the time we holding runningLock
            case () of
                ()
_
#ifndef mingw32_HOST_OS
                    | Bool
rtsSupportsBoundThreads -> do
                        TimerManager
htm <- IO TimerManager
getSystemTimerManager
                        IO TimeoutKey -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO TimeoutKey -> IO ()) -> IO TimeoutKey -> IO ()
forall a b. (a -> b) -> a -> b
$ TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
htm (Int
100000 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
deltaT)  (LowResTimerManager -> Word64 -> IO ()
startLowResTimerManager LowResTimerManager
lrtm (Word64
stdT Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
100000000))
#endif
                    | Bool
otherwise -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do   -- we have to fork another thread since we're holding runningLock,
                        Int -> IO ()
threadDelay (Int
100000 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
deltaT)   -- this may affect accuracy, but on windows there're no other choices.
                        LowResTimerManager -> Word64 -> IO ()
startLowResTimerManager LowResTimerManager
lrtm (Word64
stdT Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
100000000)
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- if we haven't got any registered timeout, we stop the time manager
                         -- doing this can stop us from getting the way of idle GC
                         -- since we're still inside runningLock, we won't miss new registration.

-- | Scan the timeout queue in current tick index, and move tick index forward by one.
--
fireLowResTimerQueue :: LowResTimerManager -> IO ()
fireLowResTimerQueue :: LowResTimerManager -> IO ()
fireLowResTimerQueue (LowResTimerManager Array (IORef TimerList)
queue MVar Int
indexLock Counter
regCounter MVar Bool
_) = do
    (TimerList
tList, IORef TimerList
tListRef) <- MVar Int
-> (Int -> IO (Int, (TimerList, IORef TimerList)))
-> IO (TimerList, IORef TimerList)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Int
indexLock ((Int -> IO (Int, (TimerList, IORef TimerList)))
 -> IO (TimerList, IORef TimerList))
-> (Int -> IO (Int, (TimerList, IORef TimerList)))
-> IO (TimerList, IORef TimerList)
forall a b. (a -> b) -> a -> b
$ \ Int
index -> do                 -- get the index lock
        IORef TimerList
tListRef <- Array (IORef TimerList) -> Int -> IO (IORef TimerList)
forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m) =>
arr a -> Int -> m a
indexArrM Array (IORef TimerList)
queue Int
index
        TimerList
tList <- IORef TimerList
-> (TimerList -> (TimerList, TimerList)) -> IO TimerList
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef TimerList
tListRef ((TimerList -> (TimerList, TimerList)) -> IO TimerList)
-> (TimerList -> (TimerList, TimerList)) -> IO TimerList
forall a b. (a -> b) -> a -> b
$ \ TimerList
tList -> (TimerList
TimerNil, TimerList
tList)   -- swap current index list with an empty one
        let !index' :: Int
index' = (Int
indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
queueSize                               -- move index forward by 1
        (Int, (TimerList, IORef TimerList))
-> IO (Int, (TimerList, IORef TimerList))
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
index', (TimerList
tList, IORef TimerList
tListRef))                                    -- release the lock

    TimerList -> IORef TimerList -> Counter -> IO ()
go TimerList
tList IORef TimerList
tListRef Counter
regCounter
  where
    go :: TimerList -> IORef TimerList -> Counter -> IO ()
go (TimerItem Counter
roundCounter IO ()
action TimerList
nextList) IORef TimerList
tListRef Counter
counter = do
        Int
r <- Counter -> Int -> IO Int
atomicSubCounter Counter
roundCounter Int
1
        case Int
r Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
0 of
            Ordering
LT -> do                                     -- if round number is less than 0, then it's a cancelled timer
                Counter -> Int -> IO ()
atomicSubCounter_ Counter
counter Int
1
                TimerList -> IORef TimerList -> Counter -> IO ()
go TimerList
nextList IORef TimerList
tListRef Counter
counter
            Ordering
EQ -> do                                     -- if round number is equal to 0, fire it
                Counter -> Int -> IO ()
atomicSubCounter_ Counter
counter Int
1
                IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
action ( \ (SomeException
_ :: SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () )  -- well, we really don't want timers break our loop
                TimerList -> IORef TimerList -> Counter -> IO ()
go TimerList
nextList IORef TimerList
tListRef Counter
counter
            Ordering
GT -> do                                     -- if round number is larger than 0, put it back for another round
                IORef TimerList -> (TimerList -> (TimerList, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef TimerList
tListRef ((TimerList -> (TimerList, ())) -> IO ())
-> (TimerList -> (TimerList, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ TimerList
tlist -> (Counter -> IO () -> TimerList -> TimerList
TimerItem Counter
roundCounter IO ()
action TimerList
tlist, ())
                TimerList -> IORef TimerList -> Counter -> IO ()
go TimerList
nextList IORef TimerList
tListRef Counter
counter
    go TimerList
TimerNil IORef TimerList
_ Counter
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

-- | Cache result of an IO action for give time t.
--
-- This combinator is useful when you want to share IO result within a period, the action will be called
-- on demand, and the result will be cached for t milliseconds.
--
-- One common way to get a shared periodical updated value is to start a seperate thread and do calculation
-- periodically, but doing that will stop system from being idle, which stop idle GC from running,
-- and in turn disable deadlock detection, which is too bad. This function solves that.
throttle :: Int         -- ^ cache time in unit of 0.1s
         -> IO a        -- ^ the original IO action
         -> IO (IO a)   -- ^ throttled IO action
throttle :: Int -> IO a -> IO (IO a)
throttle Int
t IO a
action = do
    Counter
resultCounter <- Int -> IO Counter
newCounter Int
0
    IORef a
resultRef <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef (a -> IO (IORef a)) -> IO a -> IO (IORef a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
action
    IO a -> IO (IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> IO (IO a)) -> IO a -> IO (IO a)
forall a b. (a -> b) -> a -> b
$ do
        Int
c <- Counter -> Int -> IO Int
atomicOrCounter Counter
resultCounter (-Int
1) -- 0x11111111 or 0x1111111111111111 depend machine word size
        if Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then do
            Int -> IO () -> IO ()
registerLowResTimer_ Int
t (IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> Int -> IO Int
atomicAndCounter Counter
resultCounter Int
0)
            !a
r <- IO a
action
            IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef a
resultRef a
r
            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
        else IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
resultRef

-- | Throttle an IO action without caching result.
--
-- The IO action will run at leading edge. i.e. once run, during following (t/10)s throttled action will
-- no-ops.
--
-- Note the action will run in the calling thread.
throttle_ :: Int            -- ^ cache time in unit of 0.1s
          -> IO ()          -- ^ the original IO action
          -> IO (IO ())     -- ^ throttled IO action
throttle_ :: Int -> IO () -> IO (IO ())
throttle_ Int
t IO ()
action = do
    Counter
resultCounter <- Int -> IO Counter
newCounter Int
0
    IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
        Int
c <- Counter -> Int -> IO Int
atomicOrCounter Counter
resultCounter (-Int
1) -- 0x11111111 or 0x1111111111111111 depend machine word size
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Int -> IO () -> IO ()
registerLowResTimer_ Int
t (IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Counter -> Int -> IO Int
atomicAndCounter Counter
resultCounter Int
0)
            IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO ()
action

-- | Similar to 'throttle_' but run action in trailing edge
--
-- The IO action will run at trailing edge. i.e. no matter how many times throttled action
-- are called, original action will run only once after (t/10)s.
--
-- Note the action will be run in a new created thread.
throttleTrailing_ :: Int
                  -> IO ()        -- ^ the original IO action
                  -> IO (IO ())   -- ^ throttled IO action
throttleTrailing_ :: Int -> IO () -> IO (IO ())
throttleTrailing_ Int
t IO ()
action = do
    Counter
resultCounter <- Int -> IO Counter
newCounter Int
0
    IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
        Int
c <- Counter -> Int -> IO Int
atomicOrCounter Counter
resultCounter (-Int
1) -- 0x11111111 or 0x1111111111111111 depend machine word size
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO () -> IO ()
registerLowResTimer_ Int
t (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Counter -> Int -> IO ()
atomicAndCounter_ Counter
resultCounter Int
0
            IO ()
action