GC_Hook.hs

{-|
Make use of GHC's GC hook functionality from Haskell. This is still a very
bare-bones API.
-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
module GHC.GC_Hook (
  setGCHook,
  enableGClogging,
  getGCLog,
  gcSetHookDelegate,
  Details(..),
) where

import Control.Exception (throwIO)
import Control.Monad ((>=>))
import Data.Word (Word32, Word64)
import Foreign.C.Types (CBool(..), CChar, CSize(..))
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Ptr (Ptr, castPtr, plusPtr)
import Foreign.Storable (peek)
import qualified System.Clock as Clock

foreign import ccall "copy_log_to_buffer" c_copy_log_to_buffer
  :: CSize -> Ptr CChar -> Ptr CSize -> Ptr CSize -> IO ()
foreign import ccall "set_gchook" c_set_gchook
  :: IO CBool
foreign import ccall "gchook_enable_logging" c_gchook_enable_logging
  :: CBool -> IO ()
foreign import ccall "gchook_set_c_delegate" c_gchook_set_c_delegate
  :: Ptr () -> IO CBool

-- | GC details as given to the GC hook installed by 'setGCHook'. The only
-- field that is not contained in @GCDetails_@ provided by the GHC RTS is
-- 'detTimestamp', which is the time at which the GC was finished. The GC start
-- time can probably be computed by subtracting 'detElapsedNs' from this.
--
-- The documentation of the fields (other than @detTimestamp@) is copied from
-- GHC @rts\/include\/RtsAPI.h@.
data Details = Details
  { -- | The timestamp at which the GC was finished (i.e. @gcDoneHook@ was
    -- called). Note: this is recorded using the 'Clock.Monotonic' clock.
    detTimestamp :: Clock.TimeSpec

  , -- | The generation number of this GC
    detGen :: Word32
  , -- | Number of threads used in this GC
    detThreads :: Word32
  , -- | Number of bytes allocated since the previous GC
    detAllocatedBytes :: Word64
  , -- | Total amount of live data in the heap (includes large + compact data).
    -- Updated after every GC. Data in uncollected generations (in minor GCs)
    -- are considered live.
    detLiveBytes :: Word64
  , -- | Total amount of live data in large objects
    detLargeObjectsBytes :: Word64
  , -- | Total amount of live data in compact regions
    detCompactBytes :: Word64
  , -- | Total amount of slop (wasted memory)
    detSlopBytes :: Word64
  , -- | Total amount of memory in use by the RTS
    detMemInUseBytes :: Word64
  , -- | Total amount of data copied during this GC
    detCopiedBytes :: Word64
  , -- | In parallel GC, the max amount of data copied by any one thread
    detParMaxCopiedBytes :: Word64
  , -- | In parallel GC, the amount of balanced data copied by all threads
    detParBalancedCopiedBytes :: Word64
  , -- | (nanoseconds) The time elapsed during synchronisation before GC
    detSyncElapsedNs :: Word64
  , -- | (nanoseconds) The CPU time used during GC itself
    detCpuNs :: Word64
  , -- | (nanoseconds) The time elapsed during GC itself
    detElapsedNs :: Word64

  , -- | (nanoseconds) Concurrent garbage collector.
    -- The CPU time used during the post-mark pause phase of the concurrent
    -- nonmoving GC.
    detNonmovingGcSyncCpuNs :: Word64
  , -- | (nanoseconds) Concurrent garbage collector.
    -- The time elapsed during the post-mark pause phase of the concurrent
    -- nonmoving GC.
    detNonmovingGcSyncElapsedNs :: Word64
  , -- | (nanoseconds) Concurrent garbage collector.
    -- The CPU time used during the post-mark pause phase of the concurrent
    -- nonmoving GC.
    detNonmovingGcCpuNs :: Word64
  , -- | (nanoseconds) Concurrent garbage collector.
    -- The time elapsed during the post-mark pause phase of the concurrent
    -- nonmoving GC.
    detNonmovingGcElapsedNs :: Word64
  }
  deriving (Show)

zeroDetails :: Details
zeroDetails = Details (Clock.fromNanoSecs 0) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0

-- | Initialise the GC hook. Note: to use 'getGCLog' you first need to also
-- call @'enableGClogging' True@.
setGCHook :: IO ()
setGCHook =
  c_set_gchook >>= \case
    CBool 0 -> throwIO (userError "Failure setting GC hook")
    CBool _ -> return ()

-- | Enable or disable GC logging. If the argument is true, logging is enabled;
-- if the argument is false, any pending logs are cleared and logging is
-- disabled from now on.
enableGClogging :: Bool -> IO ()
enableGClogging yes = c_gchook_enable_logging (CBool (if yes then 1 else 0))

-- | Set a C function to be called after every GC. Use this in the following manner:
--
-- * Create a file @cbits/something.c@ in your project (the actual file name
--   doesn't matter), and add @c-sources: cbits/something.c@ (and, if you wish,
--   @cc-options: -Wall@) to the stanza of the correct component in your .cabal
--   file.
-- * Put the following in it: (The function names are unimportant.)
--
-- > #include "Rts.h"
-- >
-- > // the static is unnecessary, but neat
-- > static void my_delegate_function(const struct GCDetails_ *d) {
-- >     // put your code here
-- > }
-- >
-- > void* get_my_delegate_ptr(void) {
-- >     return my_delegate_function;
-- > }
--
-- * Use the following in Haskell:
--
-- @
-- {-# LANGUAGE ForeignFunctionInterface #-}
-- import Foreign.Ptr (Ptr)
-- foreign import ccall "get_my_delegate_ptr" c_get_my_delegate_ptr :: IO (Ptr ())
-- -- ...
-- do funptr <- c_get_my_delegate_ptr
--    'gcSetHookDelegate' funptr
-- @
gcSetHookDelegate :: Ptr () -> IO ()
gcSetHookDelegate funptr =
  c_gchook_set_c_delegate funptr >>= \case
    CBool 0 -> throwIO (userError "Failure setting hook delegate, already set?")
    CBool _ -> return ()

-- | Get the log of 'Details' structures up until now; also clears the log. You
-- will never get the same structure twice.
--
-- Note: This is not entirely atomic. If you call this function concurrently,
-- it is possible that alternatingly, some events go to one 'getGCLog' call and
-- other events go to the other call.
getGCLog :: IO [Details]
getGCLog =
  getLogBatch >>= \case
    [] -> return []
    batch -> (batch ++) <$> getGCLog

getLogBatch :: IO [Details]
getLogBatch =
  let bufferCapacity = 2048
  in allocaBytes bufferCapacity $ \pbuffer ->
     alloca $ \punitsize ->
     alloca $ \pnumstored -> do
       c_copy_log_to_buffer (fromIntegral @Int @CSize bufferCapacity) pbuffer punitsize pnumstored
       unitsize <- fromIntegral @CSize @Int <$> peek punitsize
       numstored <- fromIntegral @CSize @Int <$> peek pnumstored
       sequence [peekDetails unitsize (pbuffer `plusPtr` (i * unitsize))
                | i <- [0 .. numstored - 1]]

peekDetails :: Int -> Ptr a -> IO Details
peekDetails unitsize startptr =
  let getField :: Int -> (Int, Ptr a -> Details -> IO Details)
               -> Details -> IO Details
      getField offset (_, fun) = fun (startptr `plusPtr` offset)
  in if last offsets == unitsize
       then foldr (>=>) return (zipWith getField offsets fields) zeroDetails
       else error "hook.c not compatible with GC_Hook.hs, ShadowDetails mismatch"
  where
    fields :: [(Int, Ptr a -> Details -> IO Details)]
    fields =
      [(8, peekModify $ \d x -> d { detTimestamp = (detTimestamp d) { Clock.sec = x } })
      ,(8, peekModify $ \d x -> d { detTimestamp = (detTimestamp d) { Clock.nsec = x } })
      ,(4, peekModify $ \d x -> d { detGen = x })
      ,(4, peekModify $ \d x -> d { detThreads = x })
      ,(8, peekModify $ \d x -> d { detAllocatedBytes = x })
      ,(8, peekModify $ \d x -> d { detLiveBytes = x })
      ,(8, peekModify $ \d x -> d { detLargeObjectsBytes = x })
      ,(8, peekModify $ \d x -> d { detCompactBytes = x })
      ,(8, peekModify $ \d x -> d { detSlopBytes = x })
      ,(8, peekModify $ \d x -> d { detMemInUseBytes = x })
      ,(8, peekModify $ \d x -> d { detCopiedBytes = x })
      ,(8, peekModify $ \d x -> d { detParMaxCopiedBytes = x })
      ,(8, peekModify $ \d x -> d { detParBalancedCopiedBytes = x })
      ,(8, peekModify $ \d x -> d { detSyncElapsedNs = x })
      ,(8, peekModify $ \d x -> d { detCpuNs = x })
      ,(8, peekModify $ \d x -> d { detElapsedNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcSyncCpuNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcSyncElapsedNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcCpuNs = x })
      ,(8, peekModify $ \d x -> d { detNonmovingGcElapsedNs = x })
      ]
      where peekModify g p d = peek (castPtr p) >>= \x -> return (g d x)

    offsets :: [Int]
    offsets = scanl (+) 0 (map fst fields)