0.2.0: C hook delegate and enable/disable logging

5 files changed, 245 insertions, 58 deletions

diff --git a/cbits/hook.c b/cbits/hook.c
index 2175be4..d8619ff 100644
--- a/cbits/hook.c
+++ b/cbits/hook.c
@@ -100,8 +100,14 @@ static void shadow_copy(struct ShadowDetails *dst, const struct GCDetails_ *src)
 // GLOBAL VARIABLES
 // --------
 
+static bool constructor_worked = false;
+static bool hook_initialised = false;
+static bool logging_enabled = false;
+static void (*hook_c_delegate)(const struct GCDetails_*) = NULL;
+
+static mtx_t state_mutex;
+
 static void (*old_hook)(const struct GCDetails_ *details) = NULL;
-static mtx_t detlog_mutex;
 static size_t detlog_capacity = 0, detlog_length = 0;
 static struct ShadowDetails *detlog = NULL;
 
@@ -116,13 +122,13 @@ static void hook_callback(const struct GCDetails_ *details) {
 
 	// Do this now already, before waiting on the mutex
 	struct timespec now;
-	if (clock_gettime(CLOCK_MONOTONIC, &now) != 0) {
+	if (logging_enabled && clock_gettime(CLOCK_MONOTONIC, &now) != 0) {
 		perror("clock_gettime");
 		fatal_failure = true;
 		goto cleanup_no_mutex;
 	}
 
-	if (mtx_lock(&detlog_mutex) != thrd_success) {
+	if (mtx_lock(&state_mutex) != thrd_success) {
 		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
 		fatal_failure = true;
 		goto cleanup_no_mutex;
@@ -130,62 +136,153 @@ static void hook_callback(const struct GCDetails_ *details) {
 
 	// mutex is locked from here
 
-	if (detlog_length == detlog_capacity) {
-		detlog_capacity = detlog_capacity == 0 ? 128 : 2 * detlog_capacity;
-		detlog = realloc(detlog, detlog_capacity * sizeof(detlog[0]));
-		if (detlog == NULL || detlog_capacity == 0) {  // also check for overflow here
-			fprintf(stderr, "ghc-gc-hook: ERROR: Could not allocate memory for GC log hook\n");
-			fatal_failure = true;
-			goto cleanup;
+	if (logging_enabled) {
+		if (detlog_length == detlog_capacity) {
+			detlog_capacity = detlog_capacity == 0 ? 128 : 2 * detlog_capacity;
+			detlog = realloc(detlog, detlog_capacity * sizeof(detlog[0]));
+			if (detlog == NULL || detlog_capacity == 0) {  // also check for overflow here
+				fprintf(stderr, "ghc-gc-hook: ERROR: Could not allocate memory for GC log hook\n");
+				fatal_failure = true;
+				goto cleanup;
+			}
 		}
+
+		struct ShadowDetails *dst = &detlog[detlog_length];
+		dst->timestamp_sec = now.tv_sec;
+		dst->timestamp_nsec = now.tv_nsec;
+		shadow_copy(dst, details);
+		detlog_length++;
 	}
 
-	struct ShadowDetails *dst = &detlog[detlog_length];
-	dst->timestamp_sec = now.tv_sec;
-	dst->timestamp_nsec = now.tv_nsec;
-	shadow_copy(dst, details);
-	detlog_length++;
+	if (hook_c_delegate) hook_c_delegate(details);
 
 cleanup:
-	mtx_unlock(&detlog_mutex);  // ignore return value
+	mtx_unlock(&state_mutex);  // ignore return value
 
 cleanup_no_mutex:
 	if (old_hook) old_hook(details);
 }
 
+__attribute__((constructor))
+static void constructor(void) {
+	if (mtx_init(&state_mutex, mtx_plain) != thrd_success) {
+		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex initialisation failed\n");
+		return;
+	}
+
+	constructor_worked = true;
+}
+
 // --------
 // EXPORTED FUNCTIONS
 // --------
 
+// Only works if logging is enabled.
 void copy_log_to_buffer(size_t space_available, char *buffer, size_t *unit_size, size_t *num_stored) {
-	if (mtx_lock(&detlog_mutex) != thrd_success) {
+	*unit_size = sizeof(detlog[0]);
+
+	if (mtx_lock(&state_mutex) != thrd_success) {
 		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
-		*unit_size = 0;
 		*num_stored = 0;
 		return;
 	}
 
-	const size_t sz = sizeof(detlog[0]);
-	const size_t n = min_sz(space_available / sz, detlog_length);
+	if (detlog_length == 0) {
+		*num_stored = 0;
+		goto unlock_return;
+	}
+
+	const size_t n = min_sz(space_available / sizeof(detlog[0]), detlog_length);
 
 	// First copy over the fitting items
-	memcpy(buffer, detlog, n * sz);
-	*unit_size = sz;
+	memcpy(buffer, detlog, n * sizeof(detlog[0]));
+	*unit_size = sizeof(detlog[0]);
 	*num_stored = n;
 
 	// Then shift back the remaining items
 	memmove(detlog, detlog + n, (detlog_length - n) * sizeof(detlog[0]));
 	detlog_length -= n;
 
-	mtx_unlock(&detlog_mutex);
+unlock_return:
+	mtx_unlock(&state_mutex);
 }
 
-void set_gchook() {
-	if (mtx_init(&detlog_mutex, mtx_plain) != thrd_success) {
-		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex initialisation failed\n");
-		return;
+// Sets the GC hook, logging or C hook delegate not yet enabled. Returns success.
+bool set_gchook(void) {
+	if (mtx_lock(&state_mutex) != thrd_success) {
+		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
+		return false;
+	}
+
+	bool retval = false;
+
+	if (!constructor_worked) {
+		fprintf(stderr, "ghc-gc-hook: ERROR: Cannot set hook, system does not allow initialisation\n");
+		goto unlock_return_retval;
+	}
+
+	if (hook_initialised) {
+		fprintf(stderr, "ghc-gc-hook: ERROR: Hook already initialised\n");
+		goto unlock_return_retval;
 	}
 
 	old_hook = rtsConfig.gcDoneHook;
 	rtsConfig.gcDoneHook = hook_callback;
+
+	hook_initialised = true;
+	retval = true;
+
+unlock_return_retval:
+	mtx_unlock(&state_mutex);
+	return retval;
+}
+
+// Enable logging on the GC hook.
+void gchook_enable_logging(bool yes) {
+	if (!hook_initialised) {
+		if (!set_gchook()) exit(1);  // meh
+	}
+
+	if (mtx_lock(&state_mutex) != thrd_success) {
+		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
+		return;
+	}
+
+	if (logging_enabled && !yes) {
+		detlog_length = 0;
+		detlog_capacity = 0;
+		free(detlog);
+		detlog = NULL;
+	}
+
+	logging_enabled = yes;
+
+	mtx_unlock(&state_mutex);
+}
+
+// Set a C function to be called after every GC with the GCDetails_ structure
+// from `rts/include/RtsAPI.h`. Returns success.
+bool gchook_set_c_delegate(void (*delegate)(const struct GCDetails_*)) {
+	if (!hook_initialised) {
+		if (!set_gchook()) exit(1);  // meh
+	}
+
+	if (mtx_lock(&state_mutex) != thrd_success) {
+		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");
+		return false;
+	}
+
+	bool retval = false;
+
+	if (hook_c_delegate != NULL) {
+		fprintf(stderr, "ghc-gc-hook: ERROR: C hook delegate already set\n");
+		goto unlock_return_retval;
+	}
+
+	hook_c_delegate = delegate;
+	retval = true;
+
+unlock_return_retval:
+	mtx_unlock(&state_mutex);
+	return retval;
 }
diff --git a/ghc-gc-hook.cabal b/ghc-gc-hook.cabal
index 0d6884d..0865edc 100644
--- a/ghc-gc-hook.cabal
+++ b/ghc-gc-hook.cabal
@@ -1,7 +1,7 @@
 cabal-version:       2.0
 name:                ghc-gc-hook
 synopsis:            GHC garbage collection hook
-version:             0.1.0.0
+version:             0.2.0.0
 category:            GHC
 license:             MIT
 author:              Tom Smeding
@@ -11,11 +11,11 @@ build-type:          Simple
 library
   exposed-modules:
     GHC.GC_Hook
+  hs-source-dirs: src
   c-sources: cbits/hook.c
   build-depends:
     base >= 4.13 && < 4.17,
     clock
-  hs-source-dirs: src
   default-language: Haskell2010
   cc-options: -Wall
   ghc-options: -Wall
@@ -24,9 +24,11 @@ test-suite test
   type: exitcode-stdio-1.0
   main-is: Main.hs
   hs-source-dirs: test
+  c-sources: test/cbits/testhook.c
   build-depends:
     base >= 4.13 && < 4.17,
-    ghc-gc-hook
+    ghc-gc-hook,
+    clock
   default-language: Haskell2010
   ghc-options: -Wall -threaded
 
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
diff --git a/test/Main.hs b/test/Main.hs
index c813e48..aad5ebb 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,14 +1,42 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
 module Main where
 
-import Control.Monad (forM_)
+import Control.Monad (forM_, when)
+import qualified System.Clock as Clock
+import Foreign.Ptr (Ptr)
 
 import GHC.GC_Hook
 
 
-main :: IO ()
-main = do
-  setGCHook
+foreign import ccall "get_my_delegate_ptr" c_get_my_delegate_ptr :: IO (Ptr ())
+
+
+{-# NOINLINE invokeGCsometimes #-}
+invokeGCsometimes :: IO ()
+invokeGCsometimes =
   forM_ [1..10] $ \i -> do
     let l = [i..10000]
     print (sum l + product l + length l)
-  getGCLog >>= print
+
+main :: IO ()
+main = do
+  setGCHook
+
+  invokeGCsometimes
+
+  enabletm <- Clock.getTime Clock.Monotonic
+  enableGClogging True
+
+  invokeGCsometimes
+
+  gclog <- getGCLog
+  when (length gclog == 0) $
+    fail "GC log was unexpectedly empty"
+  when (any ((< enabletm) . detTimestamp) gclog) $ do
+    _ <- fail "Logging was already on before enableGClogging"
+    print enabletm
+    putStrLn "--"
+    mapM_ print (map detTimestamp gclog)
+
+  c_get_my_delegate_ptr >>= gcSetHookDelegate
+  invokeGCsometimes
diff --git a/test/cbits/testhook.c b/test/cbits/testhook.c
new file mode 100644
index 0000000..47a774a
--- /dev/null
+++ b/test/cbits/testhook.c
@@ -0,0 +1,10 @@
+#include "Rts.h"
+#include <stdio.h>
+
+static void my_delegate_function(const struct GCDetails_ *d) {
+    printf("Yup test delegate hook worked\n");
+}
+
+void* get_my_delegate_ptr(void) {
+    return my_delegate_function;
+}