diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | cbits/hook.c | 25 | ||||
| -rw-r--r-- | ghc-gc-hook.cabal | 3 | ||||
| -rw-r--r-- | src/GHC/GC_Hook.hs | 21 |
4 files changed, 41 insertions, 9 deletions
@@ -1 +1,2 @@ dist-newstyle/ +.ccls-cache/ diff --git a/cbits/hook.c b/cbits/hook.c index e05ccd4..2175be4 100644 --- a/cbits/hook.c +++ b/cbits/hook.c @@ -1,5 +1,6 @@ #include "Rts.h" #include <string.h> +#include <time.h> // needs C11 #include <threads.h> @@ -12,6 +13,9 @@ 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 @@ -106,13 +110,21 @@ static struct ShadowDetails *detlog = NULL; // -------- static void hook_callback(const struct GCDetails_ *details) { - static bool alloc_failed = false; + static bool fatal_failure = false; + + if (fatal_failure) goto cleanup_no_mutex; - if (alloc_failed) goto cleanup_no_mutex; + // Do this now already, before waiting on the mutex + struct timespec now; + if (clock_gettime(CLOCK_MONOTONIC, &now) != 0) { + perror("clock_gettime"); + fatal_failure = true; + goto cleanup_no_mutex; + } if (mtx_lock(&detlog_mutex) != thrd_success) { fprintf(stderr, "ghc-gc-hook: ERROR: Mutex lock failed\n"); - alloc_failed = true; // dumb proxy for "don't do anything anymore please" + fatal_failure = true; goto cleanup_no_mutex; } @@ -123,12 +135,15 @@ static void hook_callback(const struct GCDetails_ *details) { 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"); - alloc_failed = true; + fatal_failure = true; goto cleanup; } } - shadow_copy(&detlog[detlog_length], details); + struct ShadowDetails *dst = &detlog[detlog_length]; + dst->timestamp_sec = now.tv_sec; + dst->timestamp_nsec = now.tv_nsec; + shadow_copy(dst, details); detlog_length++; cleanup: diff --git a/ghc-gc-hook.cabal b/ghc-gc-hook.cabal index 6f21e56..7bf1c1f 100644 --- a/ghc-gc-hook.cabal +++ b/ghc-gc-hook.cabal @@ -12,7 +12,8 @@ library GHC.GC_Hook c-sources: cbits/hook.c build-depends: - base >= 4.13 && < 4.17 + base >= 4.13 && < 4.17, + clock hs-source-dirs: src default-language: Haskell2010 cc-options: -Wall -O2 diff --git a/src/GHC/GC_Hook.hs b/src/GHC/GC_Hook.hs index ea1586c..44826c9 100644 --- a/src/GHC/GC_Hook.hs +++ b/src/GHC/GC_Hook.hs @@ -3,6 +3,7 @@ module GHC.GC_Hook ( setGCHook, getGCLog, + Details(..), ) where import Control.Monad ((>=>)) @@ -11,14 +12,23 @@ import Foreign.C.Types (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 () +-- | 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. data Details = Details - { -- | The generation number of this GC + { -- | 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 @@ -76,12 +86,15 @@ data Details = Details deriving (Show) zeroDetails :: Details -zeroDetails = Details 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 +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. setGCHook :: IO () setGCHook = do c_set_gchook +-- | Get the log of 'Details' structures up until now; also clears the log. You +-- will never get the same structure twice. getGCLog :: IO [Details] getGCLog = let bufferCapacity = 2048 @@ -105,7 +118,9 @@ peekDetails unitsize startptr = where fields :: [(Int, Ptr a -> Details -> IO Details)] fields = - [(4, peekModify $ \d x -> d { detGen = x }) + [(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 }) |