module Hasura.GC
  ( ourIdleGC,
  )
where

import Control.Concurrent.Extended qualified as C
import GHC.Stats
import Hasura.Logging
import Hasura.Prelude
import System.Mem (performMajorGC)

-- | The RTS's idle GC doesn't work for us:
--
--    - when `-I` is too low it may fire continuously causing scary high CPU
--      when idle among other issues (see #2565)
--    - when we set it higher it won't run at all leading to memory being
--      retained when idle (especially noticeable when users are benchmarking and
--      see memory stay high after finishing). In the theoretical worst case
--      there is such low haskell heap pressure that we never run finalizers to
--      free the foreign data from e.g. libpq.
--    - as of GHC 8.10.2 we have access to `-Iw`, but those two knobs still
--      don’t give us a guarantee that a major GC will always run at some
--      minumum frequency (e.g. for finalizers)
--
-- ...so we hack together our own using GHC.Stats, which should have
-- insignificant runtime overhead.
ourIdleGC ::
  Logger Hasura ->
  -- | Run a major GC when we've been "idle" for idleInterval
  DiffTime ->
  -- | ...as long as it has been > minGCInterval time since the last major GC
  DiffTime ->
  -- | Additionally, if it has been > maxNoGCInterval time, force a GC regardless.
  DiffTime ->
  IO void
ourIdleGC :: Logger Hasura -> DiffTime -> DiffTime -> DiffTime -> IO void
ourIdleGC (Logger forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger) DiffTime
idleInterval DiffTime
minGCInterval DiffTime
maxNoGCInterval =
  IO (IO DiffTime)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadIO n) =>
m (n DiffTime)
startTimer IO (IO DiffTime) -> (IO DiffTime -> IO void) -> IO void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Word32 -> IO DiffTime -> IO void
go Word32
0 Word32
0
  where
    go :: Word32 -> Word32 -> IO DiffTime -> IO void
go Word32
gcs_prev Word32
major_gcs_prev IO DiffTime
timerSinceLastMajorGC = do
      DiffTime
timeSinceLastGC <- IO DiffTime
timerSinceLastMajorGC
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiffTime
timeSinceLastGC DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
minGCInterval) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- no need to check idle until we've passed the minGCInterval:
        DiffTime -> IO ()
C.sleep (DiffTime
minGCInterval DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
timeSinceLastGC)

      RTSStats {Word32
gcs :: RTSStats -> Word32
gcs :: Word32
gcs, Word32
major_gcs :: RTSStats -> Word32
major_gcs :: Word32
major_gcs} <- IO RTSStats
getRTSStats
      -- We use minor GCs as a proxy for "activity", which seems to work
      -- well-enough (in tests it stays stable for a few seconds when we're
      -- logically "idle" and otherwise increments quickly)
      let areIdle :: Bool
areIdle = Word32
gcs Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
gcs_prev
          areOverdue :: Bool
areOverdue = DiffTime
timeSinceLastGC DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
maxNoGCInterval

      -- a major GC was run since last iteration (cool!), reset timer:
      if
          | Word32
major_gcs Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
major_gcs_prev -> do
            IO (IO DiffTime)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadIO n) =>
m (n DiffTime)
startTimer IO (IO DiffTime) -> (IO DiffTime -> IO void) -> IO void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Word32 -> IO DiffTime -> IO void
go Word32
gcs Word32
major_gcs

          -- we are idle and its a good time to do a GC, or we're overdue and must run a GC:
          | Bool
areIdle Bool -> Bool -> Bool
|| Bool
areOverdue -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
areOverdue Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
areIdle) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              UnstructuredLog -> IO ()
forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
logger (UnstructuredLog -> IO ()) -> UnstructuredLog -> IO ()
forall a b. (a -> b) -> a -> b
$
                LogLevel -> SerializableBlob -> UnstructuredLog
UnstructuredLog LogLevel
LevelWarn (SerializableBlob -> UnstructuredLog)
-> SerializableBlob -> UnstructuredLog
forall a b. (a -> b) -> a -> b
$
                  SerializableBlob
"Overdue for a major GC: forcing one even though we don't appear to be idle"
            IO ()
performMajorGC
            IO (IO DiffTime)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadIO n) =>
m (n DiffTime)
startTimer IO (IO DiffTime) -> (IO DiffTime -> IO void) -> IO void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Word32 -> IO DiffTime -> IO void
go (Word32
gcs Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1) (Word32
major_gcs Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1)

          -- else keep the timer running, waiting for us to go idle:
          | Bool
otherwise -> do
            DiffTime -> IO ()
C.sleep DiffTime
idleInterval
            Word32 -> Word32 -> IO DiffTime -> IO void
go Word32
gcs Word32
major_gcs IO DiffTime
timerSinceLastMajorGC