From 6ca1e41da1d702467dbfb0d6bf7b463884eedc31 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Fri, 22 Apr 2022 23:33:12 +0200
Subject: 0.2.0: C hook delegate and enable/disable logging

---
 test/Main.hs          | 38 +++++++++++++++++++++++++++++++++-----
 test/cbits/testhook.c | 10 ++++++++++
 2 files changed, 43 insertions(+), 5 deletions(-)
 create mode 100644 test/cbits/testhook.c

(limited to 'test')

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;
+}
-- 
cgit v1.2.3-54-g00ecf