diff options
| -rw-r--r-- | cbits/hook.c | 151 | ||||
| -rw-r--r-- | ghc-gc-hook.cabal | 8 | ||||
| -rw-r--r-- | src/GHC/GC_Hook.hs | 96 | ||||
| -rw-r--r-- | test/Main.hs | 38 | ||||
| -rw-r--r-- | test/cbits/testhook.c | 10 |
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; +} |