1 files changed, 130 insertions, 0 deletions
diff --git a/src/GHC/GC_Hook.hs b/src/GHC/GC_Hook.hs
new file mode 100644
index 0000000..ea1586c
--- /dev/null
+++ b/src/GHC/GC_Hook.hs
@@ -0,0 +1,130 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TypeApplications #-}
+module GHC.GC_Hook (
+  setGCHook,
+  getGCLog,
+) where
+
+import Control.Monad ((>=>))
+import Data.Word (Word32, Word64)
+import Foreign.C.Types (CChar, CSize(..))
+import Foreign.Marshal.Alloc (alloca, allocaBytes)
+import Foreign.Ptr (Ptr, castPtr, plusPtr)
+import Foreign.Storable (peek)
+
+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 ()
+
+data Details = Details
+  { -- | 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 (incliudes 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
+  , -- | The time elapsed during synchronisation before GC
+    -- NOTE: nanoseconds!
+    detSyncElapsedNs :: Word64
+  , -- | The CPU time used during GC itself
+    -- NOTE: nanoseconds!
+    detCpuNs :: Word64
+  , -- | The time elapsed during GC itself
+    -- NOTE: nanoseconds!
+    detElapsedNs :: Word64
+
+  , -- | 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.
+    -- The time elapsed during the post-mark pause phase of the concurrent
+    -- nonmoving GC.
+    -- NOTE: nanoseconds!
+    detNonmovingGcSyncElapsedNs :: Word64
+  , -- | 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.
+    -- The time elapsed during the post-mark pause phase of the concurrent
+    -- nonmoving GC.
+    -- NOTE: nanoseconds!
+    detNonmovingGcElapsedNs :: Word64
+  }
+  deriving (Show)
+
+zeroDetails :: Details
+zeroDetails = Details 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+
+setGCHook :: IO ()
+setGCHook = do
+  c_set_gchook
+
+getGCLog :: IO [Details]
+getGCLog =
+  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 =
+      [(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)