{-|
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
  , threadDelayLowRes
  , 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
import           Z.IO.Exception
import           Z.IO.UV.FFI_Env    (uv_hrtime)

--
queueSize :: Int
{-# INLINABLE queueSize #-}
queueSize :: Int
queueSize = Int
128

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

data LowResTimerManager = LowResTimerManager
    (SmallArray (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
{-# INLINABLE newLowResTimerManager #-}
newLowResTimerManager :: IO LowResTimerManager
newLowResTimerManager = do
    MVar Int
indexLock <- forall a. a -> IO (MVar a)
newMVar Int
0
    Counter
regCounter <- Int -> IO Counter
newCounter Int
0
    MVar Bool
runningLock <- forall a. a -> IO (MVar a)
newMVar Bool
False
    MArr SmallArray RealWorld (IORef TimerList)
queue <- forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
Int -> m (MArr arr s a)
newArr Int
queueSize
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
queueSizeforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
        forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr SmallArray RealWorld (IORef TimerList)
queue Int
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. a -> IO (IORef a)
newIORef TimerList
TimerNil
    SmallArray (IORef TimerList)
iqueue <- forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> m (arr a)
unsafeFreezeArr MArr SmallArray RealWorld (IORef TimerList)
queue
    forall (m :: * -> *) a. Monad m => a -> m a
return (SmallArray (IORef TimerList)
-> MVar Int -> Counter -> MVar Bool -> LowResTimerManager
LowResTimerManager SmallArray (IORef TimerList)
iqueue MVar Int
indexLock Counter
regCounter MVar Bool
runningLock)

lowResTimerManager :: IORef (SmallArray LowResTimerManager)
{-# NOINLINE lowResTimerManager #-}
lowResTimerManager :: IORef (SmallArray LowResTimerManager)
lowResTimerManager = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    Int
numCaps <- IO Int
getNumCapabilities
    MArr SmallArray RealWorld LowResTimerManager
lrtmArray <- forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
Int -> m (MArr arr s a)
newArr Int
numCaps
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
numCapsforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
        forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr SmallArray RealWorld LowResTimerManager
lrtmArray Int
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LowResTimerManager
newLowResTimerManager
    SmallArray LowResTimerManager
ilrtmArray <- forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> m (arr a)
unsafeFreezeArr MArr SmallArray RealWorld LowResTimerManager
lrtmArray
    forall a. a -> IO (IORef a)
newIORef SmallArray 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 ()
{-# INLINABLE lowResTimerManagerCapabilitiesChanged #-}
lowResTimerManagerCapabilitiesChanged :: IO ()
lowResTimerManagerCapabilitiesChanged = do
    SmallArray LowResTimerManager
lrtmArray <- forall a. IORef a -> IO a
readIORef IORef (SmallArray LowResTimerManager)
lowResTimerManager
    let oldSize :: Int
oldSize = forall (arr :: * -> *) a. Arr arr a => arr a -> Int
sizeofArr SmallArray LowResTimerManager
lrtmArray
    Int
numCaps <- IO Int
getNumCapabilities
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numCaps forall a. Eq a => a -> a -> Bool
/= Int
oldSize) forall a b. (a -> b) -> a -> b
$ do
        MArr SmallArray RealWorld LowResTimerManager
lrtmArray' <- forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
Int -> m (MArr arr s a)
newArr Int
numCaps
        if Int
numCaps forall a. Ord a => a -> a -> Bool
< Int
oldSize
        then do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
numCapsforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
                forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr SmallArray RealWorld LowResTimerManager
lrtmArray' Int
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m, HasCallStack) =>
arr a -> Int -> m a
indexArrM SmallArray LowResTimerManager
lrtmArray Int
i
        else do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
oldSizeforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
                forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr SmallArray RealWorld LowResTimerManager
lrtmArray' Int
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m, HasCallStack) =>
arr a -> Int -> m a
indexArrM SmallArray LowResTimerManager
lrtmArray Int
i
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
oldSize..Int
numCapsforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
                forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) =>
MArr arr s a -> Int -> a -> m ()
writeArr MArr SmallArray RealWorld LowResTimerManager
lrtmArray' Int
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LowResTimerManager
newLowResTimerManager

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

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

-- | Check if a timer manager's wheel is turning
--
-- This is mostly for testing purpose.
--
isLowResTimerManagerRunning :: LowResTimerManager -> IO Bool
{-# INLINABLE isLowResTimerManagerRunning #-}
isLowResTimerManagerRunning :: LowResTimerManager -> IO Bool
isLowResTimerManagerRunning (LowResTimerManager SmallArray (IORef TimerList)
_ MVar Int
_ Counter
_ MVar Bool
runningLock) = 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
{-# INLINABLE registerLowResTimer #-}
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 ()
{-# INLINABLE registerLowResTimer_ #-}
registerLowResTimer_ :: Int -> IO () -> IO ()
registerLowResTimer_ Int
t IO ()
action = 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
{-# INLINABLE registerLowResTimerOn #-}
registerLowResTimerOn :: LowResTimerManager -> Int -> IO () -> IO LowResTimer
registerLowResTimerOn lrtm :: LowResTimerManager
lrtm@(LowResTimerManager SmallArray (IORef TimerList)
queue MVar Int
indexLock Counter
regCounter MVar Bool
_) Int
t IO ()
action = do

    let (Int
round_, Int
tick) = (forall a. Ord a => a -> a -> a
max Int
0 Int
t) forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
queueSize
    Int
i <- forall a. MVar a -> IO a
readMVar MVar Int
indexLock
    IORef TimerList
tlistRef <- forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m, HasCallStack) =>
arr a -> Int -> m a
indexArrM SmallArray (IORef TimerList)
queue ((Int
i forall a. Num a => a -> a -> a
+ Int
tick) forall a. Integral a => a -> a -> a
`rem` Int
queueSize)
    Counter
roundCounter <- Int -> IO Counter
newCounter Int
round_
    forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
        forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef TimerList
tlistRef 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

    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
{-# INLINABLE queryLowResTimer #-}
queryLowResTimer :: LowResTimer -> IO Int
queryLowResTimer (LowResTimer Counter
c) = forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
PrimRef (PrimState m) a -> m a
readPrimRef Counter
c

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

-- | @void . cancelLowResTimer@
--
cancelLowResTimer_ :: LowResTimer -> IO ()
{-# INLINABLE cancelLowResTimer_ #-}
cancelLowResTimer_ :: LowResTimer -> IO ()
cancelLowResTimer_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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)
{-# INLINABLE timeoutLowRes #-}
timeoutLowRes :: forall a. Int -> IO a -> IO (Maybe a)
timeoutLowRes Int
timeo IO a
io = do
    ThreadId
mid <- IO ThreadId
myThreadId
    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
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
r))
        ( \ (TimeOutException
_ :: TimeOutException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing )
  where
    timeoutAThread :: ThreadId -> IO ()
timeoutAThread ThreadId
tid = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (ThreadId -> CallStack -> TimeOutException
TimeOutException ThreadId
tid forall a. HasCallStack => a
undefined)

-- | Similar to 'timeoutLowRes', but throw an async 'TimeOutException' to current thread
-- instead of return 'Nothing' if timeout.
timeoutLowResEx :: HasCallStack
                => Int    -- ^ timeout in unit of 0.1s
                -> IO a
                -> IO a
{-# INLINABLE timeoutLowResEx #-}
timeoutLowResEx :: forall a. HasCallStack => 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
    forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  where
    timeoutAThread :: ThreadId -> IO ()
timeoutAThread ThreadId
tid = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (ThreadId -> CallStack -> TimeOutException
TimeOutException ThreadId
tid HasCallStack => CallStack
callStack)

-- | see 'timeoutLowResEx' on 'TimeOutException'.
--
-- This exception is not a sub-exception type of 'SomeIOException',
-- but a sub-exception type of 'TimeOutException'.
data TimeOutException = TimeOutException ThreadId CallStack deriving Int -> TimeOutException -> ShowS
[TimeOutException] -> ShowS
TimeOutException -> String
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 where
    toException :: TimeOutException -> SomeException
toException = forall e. Exception e => e -> SomeException
asyncExceptionToException
    fromException :: SomeException -> Maybe TimeOutException
fromException = forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException


-- | Similiar to 'threadDelay', suspends the current thread for a given number of deciseconds.
--
threadDelayLowRes :: Int -> IO ()
{-# INLINABLE threadDelayLowRes #-}
threadDelayLowRes :: Int -> IO ()
threadDelayLowRes Int
dsecs = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    MVar ()
m <- forall a. IO (MVar a)
newEmptyMVar
    LowResTimer
t <- Int -> IO () -> IO LowResTimer
registerLowResTimer Int
dsecs (forall a. MVar a -> a -> IO ()
putMVar MVar ()
m ())
    forall a. MVar a -> IO a
takeMVar MVar ()
m forall a b. IO a -> IO b -> IO a
`onException` LowResTimer -> IO ()
cancelLowResTimer_ LowResTimer
t

--------------------------------------------------------------------------------
-- | Check if low resolution timer manager loop is running, start loop if not.
--
ensureLowResTimerManager :: LowResTimerManager -> IO ()
{-# INLINABLE ensureLowResTimerManager #-}
ensureLowResTimerManager :: LowResTimerManager -> IO ()
ensureLowResTimerManager lrtm :: LowResTimerManager
lrtm@(LowResTimerManager SmallArray (IORef TimerList)
_ MVar Int
_ Counter
_ MVar Bool
runningLock) = do
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
runningLock forall a b. (a -> b) -> a -> b
$ \ Bool
running -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
running 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
        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 ()
{-# INLINABLE startLowResTimerManager #-}
startLowResTimerManager :: LowResTimerManager -> Word64 -> IO ()
startLowResTimerManager lrtm :: LowResTimerManager
lrtm@(LowResTimerManager SmallArray (IORef TimerList)
_ MVar Int
_ Counter
regCounter MVar Bool
runningLock) !Word64
stdT = do
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
runningLock forall a b. (a -> b) -> a -> b
$ \ Bool
_ -> do     -- we shouldn't receive async exception here
        Int
c <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
PrimRef (PrimState m) a -> m a
readPrimRef Counter
regCounter          -- unless something terribly wrong happened, e.g., stackoverflow
        if Int
c 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 = forall a. Ord a => a -> a -> a
min (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
t forall a. Num a => a -> a -> a
- Word64
stdT) 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
                        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ TimerManager -> Int -> IO () -> IO TimeoutKey
registerTimeout TimerManager
htm (Int
100000 forall a. Num a => a -> a -> a
- Int
deltaT)  (LowResTimerManager -> Word64 -> IO ()
startLowResTimerManager LowResTimerManager
lrtm (Word64
stdT forall a. Num a => a -> a -> a
+ Word64
100000000))
#endif
                    | Bool
otherwise -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do   -- we have to fork another thread since we're holding runningLock,
                        Int -> IO ()
threadDelay (Int
100000 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 forall a. Num a => a -> a -> a
+ Word64
100000000)
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do
            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 ()
{-# INLINABLE fireLowResTimerQueue #-}
fireLowResTimerQueue :: LowResTimerManager -> IO ()
fireLowResTimerQueue (LowResTimerManager SmallArray (IORef TimerList)
queue MVar Int
indexLock Counter
regCounter MVar Bool
_) = do
    (TimerList
tList, IORef TimerList
tListRef) <- forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Int
indexLock forall a b. (a -> b) -> a -> b
$ \ Int
index -> do                 -- get the index lock
        IORef TimerList
tListRef <- forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m, HasCallStack) =>
arr a -> Int -> m a
indexArrM SmallArray (IORef TimerList)
queue Int
index
        TimerList
tList <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef TimerList
tListRef 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
indexforall a. Num a => a -> a -> a
+Int
1) forall a. Integral a => a -> a -> a
`rem` Int
queueSize                               -- move index forward by 1
        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 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
                forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catchSync IO ()
action ( \ (SomeException
_ :: SomeException) -> 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
                forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef TimerList
tListRef 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
_ = 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
{-# INLINABLE throttle #-}
throttle :: forall a. Int -> IO a -> IO (IO a)
throttle Int
t IO a
action = do
    Counter
resultCounter <- Int -> IO Counter
newCounter Int
0
    IORef a
resultRef <- forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
action
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Eq a => a -> a -> Bool
== Int
0
        then do
            Int -> IO () -> IO ()
registerLowResTimer_ Int
t (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Counter -> Int -> IO Int
atomicAndCounter Counter
resultCounter Int
0)
            !a
r <- IO a
action
            forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef a
resultRef a
r
            forall (m :: * -> *) a. Monad m => a -> m a
return a
r
        else 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
{-# INLINABLE throttle_ #-}
throttle_ :: Int -> IO () -> IO (IO ())
throttle_ Int
t IO ()
action = do
    Counter
resultCounter <- Int -> IO Counter
newCounter Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
c forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ do
            Int -> IO () -> IO ()
registerLowResTimer_ Int
t (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Counter -> Int -> IO Int
atomicAndCounter Counter
resultCounter Int
0)
            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
{-# INLINABLE throttleTrailing_ #-}
throttleTrailing_ :: Int -> IO () -> IO (IO ())
throttleTrailing_ Int
t IO ()
action = do
    Counter
resultCounter <- Int -> IO Counter
newCounter Int
0
    forall (m :: * -> *) a. Monad m => a -> m a
return 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
c forall a. Eq a => a -> a -> Bool
== Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO () -> IO ()
registerLowResTimer_ Int
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
            Counter -> Int -> IO ()
atomicAndCounter_ Counter
resultCounter Int
0
            IO ()
action