1 files changed, 73 insertions, 23 deletions

diff --git a/src/GHC/GC_Hook.hs b/src/GHC/GC_Hook.hs
index 35fbbc5..b3e1947 100644
--- a/src/GHC/GC_Hook.hs
+++ b/src/GHC/GC_Hook.hs
@@ -3,29 +3,39 @@
 {-# 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 (CChar, CSize(..))
+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 "set_gchook" c_set_gchook
-  :: IO ()
 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
+-- 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
+  { -- | 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
 
@@ -35,7 +45,7 @@ data Details = Details
     detThreads :: Word32
   , -- | Number of bytes allocated since the previous GC
     detAllocatedBytes :: Word64
-  , -- | Total amount of live data in the heap (incliudes large + compact data).
+  , -- | 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
@@ -53,35 +63,28 @@ data Details = Details
     detParMaxCopiedBytes :: Word64
   , -- | In parallel GC, the amount of balanced data copied by all threads
     detParBalancedCopiedBytes :: Word64
-  , -- | The time elapsed during synchronisation before GC
-    -- NOTE: nanoseconds!
+  , -- | (nanoseconds) The time elapsed during synchronisation before GC
     detSyncElapsedNs :: Word64
-  , -- | The CPU time used during GC itself
-    -- NOTE: nanoseconds!
+  , -- | (nanoseconds) The CPU time used during GC itself
     detCpuNs :: Word64
-  , -- | The time elapsed during GC itself
-    -- NOTE: nanoseconds!
+  , -- | (nanoseconds) The time elapsed during GC itself
     detElapsedNs :: Word64
 
-  , -- | Concurrent garbage collector.
+  , -- | (nanoseconds) Concurrent garbage collector.
     -- The CPU time used during the post-mark pause phase of the concurrent
     -- nonmoving GC.
-    -- NOTE: nanoseconds!
     detNonmovingGcSyncCpuNs :: Word64
-  , -- | Concurrent garbage collector.
+  , -- | (nanoseconds) Concurrent garbage collector.
     -- The time elapsed during the post-mark pause phase of the concurrent
     -- nonmoving GC.
-    -- NOTE: nanoseconds!
     detNonmovingGcSyncElapsedNs :: Word64
-  , -- | Concurrent garbage collector.
+  , -- | (nanoseconds) Concurrent garbage collector.
     -- The CPU time used during the post-mark pause phase of the concurrent
     -- nonmoving GC.
-    -- NOTE: nanoseconds!
     detNonmovingGcCpuNs :: Word64
-  , -- | Concurrent garbage collector.
+  , -- | (nanoseconds) Concurrent garbage collector.
     -- The time elapsed during the post-mark pause phase of the concurrent
     -- nonmoving GC.
-    -- NOTE: nanoseconds!
     detNonmovingGcElapsedNs :: Word64
   }
   deriving (Show)
@@ -89,13 +92,60 @@ data Details = Details
 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.
+-- | Initialise the GC hook. Note: to use 'getGCLog' you first need to also
+-- call @'enableGClogging' True@.
 setGCHook :: IO ()
-setGCHook = do
-  c_set_gchook
+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@ 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