{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Debug.Breakpoint.TimerManager
( modifyTimeouts
, suspendTimeouts
) where
import Control.Concurrent(rtsSupportsBoundThreads)
import Control.Monad (when)
import Data.Foldable (foldl')
import Data.IORef (atomicModifyIORef')
import Data.Word (Word64)
#if MIN_VERSION_ghc(9,2,0)
import qualified GHC.Clock as Clock
#endif
import GHC.Event
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
psqToList :: IntPSQ v -> [Elem v]
psqToList =
$(pure $ VarE $
Name (OccName "toList")
(NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ"))
)
psqAdjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a
psqAdjust =
$(pure $ VarE $
Name (OccName "adjust")
(NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ"))
)
psqKey :: Elem a -> Key
psqKey =
$(pure $ VarE $
Name (OccName "key")
(NameG VarName (PkgName "base") (ModName "GHC.Event.PSQ"))
)
emTimeouts :: TimerManager -> IORef TimeoutQueue
emTimeouts =
$(pure $ VarE $
Name (OccName "emTimeouts")
(NameG VarName (PkgName "base") (ModName "GHC.Event.TimerManager"))
)
wakeManager :: TimerManager -> IO ()
wakeManager :: TimerManager -> IO ()
wakeManager =
$(pure $ VarE $
Name (OccName "wakeManager")
(NameG VarName (PkgName "base") (ModName "GHC.Event.TimerManager"))
)
editTimeouts :: TimerManager -> (TimeoutQueue -> TimeoutQueue) -> IO ()
editTimeouts TimerManager
mgr TimeoutQueue -> TimeoutQueue
g = do
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
emTimeouts TimerManager
mgr) TimeoutQueue -> (TimeoutQueue, ())
f
TimerManager -> IO ()
wakeManager TimerManager
mgr
where
f :: TimeoutQueue -> (TimeoutQueue, ())
f TimeoutQueue
q = (TimeoutQueue -> TimeoutQueue
g TimeoutQueue
q, ())
modifyTimeouts :: (Word64 -> Word64) -> IO ()
modifyTimeouts :: (Prio -> Prio) -> IO ()
modifyTimeouts Prio -> Prio
f =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtsSupportsBoundThreads forall a b. (a -> b) -> a -> b
$ do
#if defined(mingw32_HOST_OS)
pure ()
#else
TimerManager
mgr <- IO TimerManager
getSystemTimerManager
TimerManager -> (TimeoutQueue -> TimeoutQueue) -> IO ()
editTimeouts TimerManager
mgr forall a b. (a -> b) -> a -> b
$ \TimeoutQueue
pq ->
let els :: [Elem (IO ())]
els = forall v. IntPSQ v -> [Elem v]
psqToList TimeoutQueue
pq
upd :: PSQ a -> Key -> PSQ a
upd PSQ a
pq' Key
k =
forall a. (Prio -> Prio) -> Key -> PSQ a -> PSQ a
psqAdjust Prio -> Prio
f Key
k PSQ a
pq'
in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. PSQ a -> Key -> PSQ a
upd TimeoutQueue
pq (forall a. Elem a -> Key
psqKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elem (IO ())]
els)
#endif
suspendTimeouts :: IO a -> IO a
#if MIN_VERSION_ghc(9,2,0)
suspendTimeouts :: forall a. IO a -> IO a
suspendTimeouts IO a
action = do
let oneYear :: Prio
oneYear = Prio
1000 forall a. Num a => a -> a -> a
* Prio
1000000 forall a. Num a => a -> a -> a
* Prio
60 forall a. Num a => a -> a -> a
* Prio
60 forall a. Num a => a -> a -> a
* Prio
24 forall a. Num a => a -> a -> a
* Prio
365
(Prio -> Prio) -> IO ()
modifyTimeouts (forall a. Num a => a -> a -> a
+ Prio
oneYear)
Prio
before <- IO Prio
Clock.getMonotonicTimeNSec
a
r <- IO a
action
Prio
after <- IO Prio
Clock.getMonotonicTimeNSec
let elapsed :: Prio
elapsed = Prio
after forall a. Num a => a -> a -> a
- Prio
before
(Prio -> Prio) -> IO ()
modifyTimeouts (forall a. Num a => a -> a -> a
subtract forall a b. (a -> b) -> a -> b
$ Prio
oneYear forall a. Num a => a -> a -> a
- Prio
elapsed)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
#else
suspendTimeouts = id
#endif