{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Debug.Breakpoint.TimerManager
  ( suspendTimeouts
  ) where

#if defined(mingw32_HOST_OS)
-- Since Windows has its own timeout manager internals, I'm choosing not to support it for now.

suspendTimeouts :: IO a -> IO a
suspendTimeouts = id

#else

import           Control.Concurrent(rtsSupportsBoundThreads)
import           Control.Monad (when)
#if !MIN_VERSION_ghc(9,10,0)
import           Data.Foldable (foldl')
#endif
import           Data.IORef
import           Data.Word (Word64)
import qualified GHC.Clock as Clock
import           GHC.Event
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import           System.IO.Unsafe

import           Debug.Breakpoint.TimerManager.Names

--------------------------------------------------------------------------------
-- Hidden functions imported via TH
--------------------------------------------------------------------------------

psqToList :: IntPSQ v -> [Elem v]
psqToList =
  $(pure $ VarE $
      Name (OccName "toList")
           (NameG VarName (PkgName pkgName) (ModName psqModName))
   )

psqAdjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a
psqAdjust =
  $(pure $ VarE $
      Name (OccName "adjust")
           (NameG VarName (PkgName pkgName) (ModName psqModName))
   )

psqKey :: Elem a -> Key
psqKey =
  $(pure $ VarE $
      Name (OccName "key")
#if MIN_VERSION_ghc(9,8,0)
           (NameG (FldName "E") (PkgName pkgName) (ModName psqModName))
#else
           (NameG VarName (PkgName pkgName) (ModName psqModName))
#endif
   )

-- emTimeouts :: TimerManager -> IORef TimeoutQueue
emTimeouts :: TimerManager -> IORef TimeoutQueue
emTimeouts =
  $(pure $ VarE $
      Name (OccName "emTimeouts")
#if MIN_VERSION_ghc(9,8,0)
           (NameG (FldName "TimerManager") (PkgName pkgName) (ModName timerManagerModName))
#else
           (NameG VarName (PkgName pkgName) (ModName timerManagerModName))
#endif
   )

wakeManager :: TimerManager -> IO ()
wakeManager :: TimerManager -> IO ()
wakeManager =
  $(pure $ VarE $
      Name (OccName "wakeManager")
           (NameG VarName (PkgName pkgName) (ModName timerManagerModName))
   )

--------------------------------------------------------------------------------
-- Timeout editing
--------------------------------------------------------------------------------

-- editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
editTimeouts :: TimerManager -> (TimeoutQueue -> TimeoutQueue) -> IO ()
editTimeouts TimerManager
mgr TimeoutQueue -> TimeoutQueue
g = do
  IORef TimeoutQueue -> (TimeoutQueue -> (TimeoutQueue, ())) -> IO ()
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, ())

-- | Modify the times in nanoseconds at which all currently registered timeouts
-- will expire.
modifyTimeouts :: (Word64 -> Word64) -> IO ()
modifyTimeouts :: (Prio -> Prio) -> IO ()
modifyTimeouts Prio -> Prio
f =
  -- This only works for the threaded RTS
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtsSupportsBoundThreads (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TimerManager
mgr <- IO TimerManager
getSystemTimerManager
    TimerManager -> (TimeoutQueue -> TimeoutQueue) -> IO ()
editTimeouts TimerManager
mgr ((TimeoutQueue -> TimeoutQueue) -> IO ())
-> (TimeoutQueue -> TimeoutQueue) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TimeoutQueue
pq ->
      let els :: [Elem (IO ())]
els = TimeoutQueue -> [Elem (IO ())]
forall v. IntPSQ v -> [Elem v]
psqToList TimeoutQueue
pq
          upd :: PSQ a -> Key -> PSQ a
upd PSQ a
pq' Key
k =
            (Prio -> Prio) -> Key -> PSQ a -> PSQ a
forall a. (Prio -> Prio) -> Key -> PSQ a -> PSQ a
psqAdjust Prio -> Prio
f Key
k PSQ a
pq'
       in (TimeoutQueue -> Key -> TimeoutQueue)
-> TimeoutQueue -> [Key] -> TimeoutQueue
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TimeoutQueue -> Key -> TimeoutQueue
forall {a}. PSQ a -> Key -> PSQ a
upd TimeoutQueue
pq (Elem (IO ()) -> Key
forall a. Elem a -> Key
psqKey (Elem (IO ()) -> Key) -> [Elem (IO ())] -> [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elem (IO ())]
els)

-- | has the effect of suspending timeouts while an action is occurring. This
-- is only used for GHC >= 9.2 because the semantics are too strange without
-- the ability to freeze the runtime.
suspendTimeouts :: IO a -> IO a
suspendTimeouts :: forall a. IO a -> IO a
suspendTimeouts IO a
action = do
  Bool
alreadySuspended <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
timeoutsSuspended
  -- Don't allow nested breakpoints to both modify timeouts
  if Bool
alreadySuspended Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
rtsSupportsBoundThreads
     then IO a
action
     else do
       IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
timeoutsSuspended Bool
True
       let oneYear :: Prio
oneYear = Prio
1000 Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
* Prio
1000000 Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
* Prio
60 Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
* Prio
60 Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
* Prio
24 Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
* Prio
365
       -- Add a large length of time to all timeouts so that they don't immediately
       -- expire when blocking ends
       (Prio -> Prio) -> IO ()
modifyTimeouts (Prio -> Prio -> Prio
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 Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
- Prio
before
       -- Set timeouts back to where they were plus the length of time spent blocking
       (Prio -> Prio) -> IO ()
modifyTimeouts (Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
subtract (Prio -> Prio -> Prio) -> Prio -> Prio -> Prio
forall a b. (a -> b) -> a -> b
$ Prio
oneYear Prio -> Prio -> Prio
forall a. Num a => a -> a -> a
- Prio
elapsed)
       -- NB: any timeouts registered right before the block or immediately afterwards
       -- would result in strange behavior. Perhaps do an atomic modify of the IORef
       -- holding the timeout queue that covers the whole transaction?
       IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
timeoutsSuspended Bool
False
       a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r

timeoutsSuspended :: IORef Bool
timeoutsSuspended :: IORef Bool
timeoutsSuspended = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
{-# NOINLINE timeoutsSuspended #-}

#endif