From 7b9e405e2f77268e3242a6d723c1b65d7759fd63 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Thu, 21 Apr 2022 00:46:24 +0200
Subject: Expose GC end timestamp

---
 .gitignore         |  1 +
 cbits/hook.c       | 25 ++++++++++++++++++++-----
 ghc-gc-hook.cabal  |  3 ++-
 src/GHC/GC_Hook.hs | 21 ++++++++++++++++++---
 4 files changed, 41 insertions(+), 9 deletions(-)

diff --git a/.gitignore b/.gitignore
index c33954f..f8452c3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -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 })
-- 
cgit v1.2.3-54-g00ecf