{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
module GHC.GC_Hook (
setGCHook,
enableGClogging,
getGCLog,
gcSetHookDelegate,
Details(..),
) where
import Control.Exception (throwIO)
import Control.Monad ((>=>))
import Data.Word (Word32, Word64)
import Foreign.C.Types (CBool(..), 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 "copy_log_to_buffer" c_copy_log_to_buffer
:: CSize -> Ptr CChar -> Ptr CSize -> Ptr CSize -> IO ()
foreign import ccall "set_gchook" c_set_gchook
:: IO CBool
foreign import ccall "gchook_enable_logging" c_gchook_enable_logging
:: CBool -> IO ()
foreign import ccall "gchook_set_c_delegate" c_gchook_set_c_delegate
:: Ptr () -> IO CBool
data Details = Details
{
Details -> TimeSpec
detTimestamp :: Clock.TimeSpec
,
Details -> Word32
detGen :: Word32
,
Details -> Word32
detThreads :: Word32
,
Details -> Word64
detAllocatedBytes :: Word64
,
Details -> Word64
detLiveBytes :: Word64
,
Details -> Word64
detLargeObjectsBytes :: Word64
,
Details -> Word64
detCompactBytes :: Word64
,
Details -> Word64
detSlopBytes :: Word64
,
Details -> Word64
detMemInUseBytes :: Word64
,
Details -> Word64
detCopiedBytes :: Word64
,
Details -> Word64
detParMaxCopiedBytes :: Word64
,
Details -> Word64
detParBalancedCopiedBytes :: Word64
,
Details -> Word64
detSyncElapsedNs :: Word64
,
Details -> Word64
detCpuNs :: Word64
,
Details -> Word64
detElapsedNs :: Word64
,
Details -> Word64
detNonmovingGcSyncCpuNs :: Word64
,
Details -> Word64
detNonmovingGcSyncElapsedNs :: Word64
,
Details -> Word64
detNonmovingGcCpuNs :: Word64
,
Details -> Word64
detNonmovingGcElapsedNs :: Word64
}
deriving (Int -> Details -> ShowS
[Details] -> ShowS
Details -> String
(Int -> Details -> ShowS)
-> (Details -> String) -> ([Details] -> ShowS) -> Show Details
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Details] -> ShowS
$cshowList :: [Details] -> ShowS
show :: Details -> String
$cshow :: Details -> String
showsPrec :: Int -> Details -> ShowS
$cshowsPrec :: Int -> Details -> ShowS
Show)
zeroDetails :: Details
zeroDetails :: Details
zeroDetails = TimeSpec
-> Word32
-> Word32
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Word64
-> Details
Details (Integer -> TimeSpec
Clock.fromNanoSecs Integer
0) Word32
0 Word32
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0 Word64
0
setGCHook :: IO ()
setGCHook :: IO ()
setGCHook =
IO CBool
c_set_gchook IO CBool -> (CBool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
CBool Word8
0 -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Failure setting GC hook")
CBool Word8
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
enableGClogging :: Bool -> IO ()
enableGClogging :: Bool -> IO ()
enableGClogging Bool
yes = CBool -> IO ()
c_gchook_enable_logging (Word8 -> CBool
CBool (if Bool
yes then Word8
1 else Word8
0))
gcSetHookDelegate :: Ptr () -> IO ()
gcSetHookDelegate :: Ptr () -> IO ()
gcSetHookDelegate Ptr ()
funptr =
Ptr () -> IO CBool
c_gchook_set_c_delegate Ptr ()
funptr IO CBool -> (CBool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
CBool Word8
0 -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Failure setting hook delegate, already set?")
CBool Word8
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getGCLog :: IO [Details]
getGCLog :: IO [Details]
getGCLog =
IO [Details]
getLogBatch IO [Details] -> ([Details] -> IO [Details]) -> IO [Details]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> [Details] -> IO [Details]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Details]
batch -> ([Details]
batch [Details] -> [Details] -> [Details]
forall a. [a] -> [a] -> [a]
++) ([Details] -> [Details]) -> IO [Details] -> IO [Details]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Details]
getGCLog
getLogBatch :: IO [Details]
getLogBatch :: IO [Details]
getLogBatch =
let bufferCapacity :: Int
bufferCapacity = Int
2048
in Int -> (Ptr CChar -> IO [Details]) -> IO [Details]
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
bufferCapacity ((Ptr CChar -> IO [Details]) -> IO [Details])
-> (Ptr CChar -> IO [Details]) -> IO [Details]
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
pbuffer ->
(Ptr CSize -> IO [Details]) -> IO [Details]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO [Details]) -> IO [Details])
-> (Ptr CSize -> IO [Details]) -> IO [Details]
forall a b. (a -> b) -> a -> b
$ \Ptr CSize
punitsize ->
(Ptr CSize -> IO [Details]) -> IO [Details]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO [Details]) -> IO [Details])
-> (Ptr CSize -> IO [Details]) -> IO [Details]
forall a b. (a -> b) -> a -> b
$ \Ptr CSize
pnumstored -> do
CSize -> Ptr CChar -> Ptr CSize -> Ptr CSize -> IO ()
c_copy_log_to_buffer (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CSize Int
bufferCapacity) Ptr CChar
pbuffer Ptr CSize
punitsize Ptr CSize
pnumstored
Int
unitsize <- (Integral CSize, Num Int) => CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @Int (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
punitsize
Int
numstored <- (Integral CSize, Num Int) => CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @Int (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pnumstored
[IO Details] -> IO [Details]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Int -> Ptr Any -> IO Details
forall a. Int -> Ptr a -> IO Details
peekDetails Int
unitsize (Ptr CChar
pbuffer Ptr CChar -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
unitsize))
| Int
i <- [Int
0 .. Int
numstored Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
peekDetails :: Int -> Ptr a -> IO Details
peekDetails :: Int -> Ptr a -> IO Details
peekDetails Int
unitsize Ptr a
startptr =
let getField :: Int -> (Int, Ptr a -> Details -> IO Details)
-> Details -> IO Details
getField :: Int
-> (Int, Ptr a -> Details -> IO Details) -> Details -> IO Details
getField Int
offset (Int
_, Ptr a -> Details -> IO Details
fun) = Ptr a -> Details -> IO Details
fun (Ptr a
startptr Ptr a -> Int -> Ptr a
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset)
in if [Int] -> Int
forall a. [a] -> a
last [Int]
offsets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
unitsize
then ((Details -> IO Details)
-> (Details -> IO Details) -> Details -> IO Details)
-> (Details -> IO Details)
-> [Details -> IO Details]
-> Details
-> IO Details
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Details -> IO Details)
-> (Details -> IO Details) -> Details -> IO Details
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
(>=>) Details -> IO Details
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
-> (Int, Ptr Any -> Details -> IO Details)
-> Details
-> IO Details)
-> [Int]
-> [(Int, Ptr Any -> Details -> IO Details)]
-> [Details -> IO Details]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int
-> (Int, Ptr Any -> Details -> IO Details) -> Details -> IO Details
forall a.
Int
-> (Int, Ptr a -> Details -> IO Details) -> Details -> IO Details
getField [Int]
offsets [(Int, Ptr Any -> Details -> IO Details)]
forall a. [(Int, Ptr a -> Details -> IO Details)]
fields) Details
zeroDetails
else String -> IO Details
forall a. HasCallStack => String -> a
error String
"hook.c not compatible with GC_Hook.hs, ShadowDetails mismatch"
where
fields :: [(Int, Ptr a -> Details -> IO Details)]
fields :: [(Int, Ptr a -> Details -> IO Details)]
fields =
[(Int
8, (Details -> Int64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Int64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Int64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Int64
x -> Details
d { detTimestamp :: TimeSpec
detTimestamp = (Details -> TimeSpec
detTimestamp Details
d) { sec :: Int64
Clock.sec = Int64
x } })
,(Int
8, (Details -> Int64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Int64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Int64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Int64
x -> Details
d { detTimestamp :: TimeSpec
detTimestamp = (Details -> TimeSpec
detTimestamp Details
d) { nsec :: Int64
Clock.nsec = Int64
x } })
,(Int
4, (Details -> Word32 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word32 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word32 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word32
x -> Details
d { detGen :: Word32
detGen = Word32
x })
,(Int
4, (Details -> Word32 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word32 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word32 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word32
x -> Details
d { detThreads :: Word32
detThreads = Word32
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detAllocatedBytes :: Word64
detAllocatedBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detLiveBytes :: Word64
detLiveBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detLargeObjectsBytes :: Word64
detLargeObjectsBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detCompactBytes :: Word64
detCompactBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detSlopBytes :: Word64
detSlopBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detMemInUseBytes :: Word64
detMemInUseBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detCopiedBytes :: Word64
detCopiedBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detParMaxCopiedBytes :: Word64
detParMaxCopiedBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detParBalancedCopiedBytes :: Word64
detParBalancedCopiedBytes = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detSyncElapsedNs :: Word64
detSyncElapsedNs = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detCpuNs :: Word64
detCpuNs = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detElapsedNs :: Word64
detElapsedNs = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detNonmovingGcSyncCpuNs :: Word64
detNonmovingGcSyncCpuNs = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detNonmovingGcSyncElapsedNs :: Word64
detNonmovingGcSyncElapsedNs = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detNonmovingGcCpuNs :: Word64
detNonmovingGcCpuNs = Word64
x })
,(Int
8, (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall t t b a. Storable t => (t -> t -> b) -> Ptr a -> t -> IO b
peekModify ((Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details)
-> (Details -> Word64 -> Details) -> Ptr a -> Details -> IO Details
forall a b. (a -> b) -> a -> b
$ \Details
d Word64
x -> Details
d { detNonmovingGcElapsedNs :: Word64
detNonmovingGcElapsedNs = Word64
x })
]
where peekModify :: (t -> t -> b) -> Ptr a -> t -> IO b
peekModify t -> t -> b
g Ptr a
p t
d = Ptr t -> IO t
forall a. Storable a => Ptr a -> IO a
peek (Ptr a -> Ptr t
forall a b. Ptr a -> Ptr b
castPtr Ptr a
p) IO t -> (t -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t
x -> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> t -> b
g t
d t
x)
offsets :: [Int]
offsets :: [Int]
offsets = (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 (((Int, Ptr Any -> Details -> IO Details) -> Int)
-> [(Int, Ptr Any -> Details -> IO Details)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Ptr Any -> Details -> IO Details) -> Int
forall a b. (a, b) -> a
fst [(Int, Ptr Any -> Details -> IO Details)]
forall a. [(Int, Ptr a -> Details -> IO Details)]
fields)