summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cbits/hook.c151
-rw-r--r--ghc-gc-hook.cabal8
-rw-r--r--src/GHC/GC_Hook.hs96
-rw-r--r--test/Main.hs38
-rw-r--r--test/cbits/testhook.c10
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;
+}
generated by cgit v1.2.3-70-g09d2 (git 2.51.0) at 2025-10-31 10:37:42 +0100