ghc-gc-hook (empty) → 0.2.0.0

raw patch · 7 files changed

+610/−0 lines, 7 filesdep +basedep +clockdep +ghc-gc-hook

Dependencies added: base, clock, ghc-gc-hook

Files

• ChangeLog.md +6/−0
• LICENSE +11/−0
• cbits/hook.c +288/−0
• ghc-gc-hook.cabal +46/−0
• src/GHC/GC_Hook.hs +207/−0
• test/Main.hs +42/−0
• test/cbits/testhook.c +10/−0

@@ -0,0 +1,6 @@+# Revision history for ghc-gc-hook+++## 0.2.0.0 -- 2022-04-25++* First version. Released on an unsuspecting world.

@@ -0,0 +1,11 @@+Copyright 2022 Tom Smeding++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,288 @@+#include "Rts.h"+#include <string.h>+#include <time.h>++// needs C11+#include <threads.h>++static size_t min_sz(size_t a, size_t b) {+	return a < b ? a : b;+}++extern RtsConfig rtsConfig;++// A copy of GCDetails_ with known structure that can be depended on by the Haskell code.+struct ShadowDetails {+	int64_t timestamp_sec;+	int64_t timestamp_nsec;++	// The generation number of this GC+	uint32_t gen;+	// Number of threads used in this GC+	uint32_t threads;+	// Number of bytes allocated since the previous GC+	uint64_t allocated_bytes;+	// Total amount of live data in the heap (incliudes large + compact data).+	// Updated after every GC. Data in uncollected generations (in minor GCs)+	// are considered live.+	uint64_t live_bytes;+	// Total amount of live data in large objects+	uint64_t large_objects_bytes;+	// Total amount of live data in compact regions+	uint64_t compact_bytes;+	// Total amount of slop (wasted memory)+	uint64_t slop_bytes;+	// Total amount of memory in use by the RTS+	uint64_t mem_in_use_bytes;+	// Total amount of data copied during this GC+	uint64_t copied_bytes;+	// In parallel GC, the max amount of data copied by any one thread+	uint64_t par_max_copied_bytes;+	// In parallel GC, the amount of balanced data copied by all threads+	uint64_t par_balanced_copied_bytes;+	// The time elapsed during synchronisation before GC+	// NOTE: nanoseconds!+	uint64_t sync_elapsed_ns;+	// The CPU time used during GC itself+	// NOTE: nanoseconds!+	uint64_t cpu_ns;+	// The time elapsed during GC itself+	// NOTE: nanoseconds!+	uint64_t elapsed_ns;++	// Concurrent garbage collector++	// The CPU time used during the post-mark pause phase of the concurrent+	// nonmoving GC.+	// NOTE: nanoseconds!+	uint64_t nonmoving_gc_sync_cpu_ns;+	// The time elapsed during the post-mark pause phase of the concurrent+	// nonmoving GC.+	// NOTE: nanoseconds!+	uint64_t nonmoving_gc_sync_elapsed_ns;+	// The CPU time used during the post-mark pause phase of the concurrent+	// nonmoving GC.+	// NOTE: nanoseconds!+	uint64_t nonmoving_gc_cpu_ns;+	// The time elapsed during the post-mark pause phase of the concurrent+	// nonmoving GC.+	// NOTE: nanoseconds!+	uint64_t nonmoving_gc_elapsed_ns;+};++static void shadow_copy(struct ShadowDetails *dst, const struct GCDetails_ *src) {+#define COPY(field) dst->field = src->field;+#define COPYTIME(field) dst->field = TimeToNS(src->field);+	COPY(gen);+	COPY(threads);+	COPY(allocated_bytes);+	COPY(live_bytes);+	COPY(large_objects_bytes);+	COPY(compact_bytes);+	COPY(slop_bytes);+	COPY(mem_in_use_bytes);+	COPY(copied_bytes);+	COPY(par_max_copied_bytes);+	COPY(par_balanced_copied_bytes);+	COPYTIME(sync_elapsed_ns);+	COPYTIME(cpu_ns);+	COPYTIME(elapsed_ns);++	COPYTIME(nonmoving_gc_sync_cpu_ns);+	COPYTIME(nonmoving_gc_sync_elapsed_ns);+	COPYTIME(nonmoving_gc_cpu_ns);+	COPYTIME(nonmoving_gc_elapsed_ns);+#undef COPY+#undef COPYTIME+}++// --------+// 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 size_t detlog_capacity = 0, detlog_length = 0;+static struct ShadowDetails *detlog = NULL;++// --------+// END OF GLOBAL VARIABLES+// --------++static void hook_callback(const struct GCDetails_ *details) {+	static bool fatal_failure = false;++	if (fatal_failure) goto cleanup_no_mutex;++	// Do this now already, before waiting on the mutex+	struct timespec now;+	if (logging_enabled && clock_gettime(CLOCK_MONOTONIC, &now) != 0) {+		perror("clock_gettime");+		fatal_failure = true;+		goto cleanup_no_mutex;+	}++	if (mtx_lock(&state_mutex) != thrd_success) {+		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");+		fatal_failure = true;+		goto cleanup_no_mutex;+	}++	// mutex is locked from here++	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++;+	}++	if (hook_c_delegate) hook_c_delegate(details);++cleanup:+	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) {+	*unit_size = sizeof(detlog[0]);++	if (mtx_lock(&state_mutex) != thrd_success) {+		fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n");+		*num_stored = 0;+		return;+	}++	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 * 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;++unlock_return:+	mtx_unlock(&state_mutex);+}++// 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;+}

@@ -0,0 +1,46 @@+cabal-version:       2.0+name:                ghc-gc-hook+synopsis:            GHC garbage collection hook+description:+  GHC exposes an API for calling a user-defined C function after every garbage+  collection pass. This small library gives access to this source of+  information from Haskell in a bare-bones form; furthermore, it gives a small+  usability improvement for running your own function from C using the hook+  from this library.+version:             0.2.0.0+category:            GHC+license:             BSD3+license-file:        LICENSE+author:              Tom Smeding+maintainer:          tom@tomsmeding.com+build-type:          Simple+extra-source-files:  ChangeLog.md++library+  exposed-modules:+    GHC.GC_Hook+  hs-source-dirs: src+  c-sources: cbits/hook.c+  build-depends:+    base >= 4.14 && < 4.17,+    clock >= 0.8.3 && < 0.9+  default-language: Haskell2010+  cc-options: -Wall+  ghc-options: -Wall++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,+    ghc-gc-hook,+    clock+  default-language: Haskell2010+  cc-options: -Wall+  ghc-options: -Wall -threaded++source-repository head+  type: git+  location: https://git.tomsmeding.com/ghc-gc-hook

@@ -0,0 +1,207 @@+{-|+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)

@@ -0,0 +1,42 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Main where++import Control.Monad (forM_, when)+import qualified System.Clock as Clock+import Foreign.Ptr (Ptr)++import GHC.GC_Hook+++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)++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

@@ -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;+}