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, performMinorGC)

-- | 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.
--
-- NOTE: as always the cost of a major GC (forced here, or initiated by the RTS)
-- with the default copying collector is proportional to live (non-garbage)
-- heap data. Tune parameters here to balance: more frequent GC pauses vs.
-- prompt cleanup of foreign data (which does not exert GC pressure).
--
-- NOTE: larger nursery size (+RTS -A) may help us run more finalizers during
-- cheaper minor GCs, before they are promoted, making it feasible (maybe) to
-- run this with longer interval parameters.
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 :: forall void.
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Word32 -> Bool -> IO DiffTime -> IO void
go Word32
0 Word32
0 Bool
False
  where
    go :: Word32 -> Word32 -> Bool -> IO DiffTime -> IO void
go Word32
gcs_prev Word32
major_gcs_prev Bool
lastIterationPerformedGC 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 :: Word32
gcs :: RTSStats -> Word32
gcs, Word32
major_gcs :: Word32
major_gcs :: RTSStats -> 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

      if
        -- a major GC was run since last iteration (cool!), reset timer:
        | 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Word32 -> Bool -> IO DiffTime -> IO void
go Word32
gcs Word32
major_gcs Bool
False

        -- 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
            -- If we performed a GC last time and nothing was promoted meantime
            -- (minor GCs are the same) running a cheaper minor GC should
            -- suffice to perform any new due finalizers:
            if Bool
lastIterationPerformedGC Bool -> Bool -> Bool
&& Bool
areIdle
              then do
                IO ()
performMinorGC
                IO (IO DiffTime)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadIO n) =>
m (n DiffTime)
startTimer IO (IO DiffTime) -> (IO DiffTime -> IO void) -> IO void
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Word32 -> Bool -> IO DiffTime -> IO void
go (Word32
gcs Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1) Word32
major_gcs Bool
True
              else 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Word32 -> Bool -> 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) Bool
True

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