summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorTom Smeding <tom@tomsmeding.com>2022-04-21 00:28:51 +0200
committerTom Smeding <tom@tomsmeding.com>2022-04-21 00:28:51 +0200
commite6ca9f166c5af915946bb8ae5ed7e5a42f40b8bd (patch)
treef7f6af4edca512c2a6de0aed094aec5d5d10582f /src
Initial
Diffstat (limited to 'src')
-rw-r--r--src/GHC/GC_Hook.hs130
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)