{-| 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)