1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
{-# 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
-- | 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.
--
-- The documentation of the fields (other than @detTimestamp@) is copied from
-- GHC @rts\/include\/RtsAPI.h@.
data Details = Details
{ -- | 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
, -- | Number of bytes allocated since the previous GC
detAllocatedBytes :: Word64
, -- | Total amount of live data in the heap (includes 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
, -- | (nanoseconds) The time elapsed during synchronisation before GC
detSyncElapsedNs :: Word64
, -- | (nanoseconds) The CPU time used during GC itself
detCpuNs :: Word64
, -- | (nanoseconds) The time elapsed during GC itself
detElapsedNs :: Word64
, -- | (nanoseconds) Concurrent garbage collector.
-- The CPU time used during the post-mark pause phase of the concurrent
-- nonmoving GC.
detNonmovingGcSyncCpuNs :: Word64
, -- | (nanoseconds) Concurrent garbage collector.
-- The time elapsed during the post-mark pause phase of the concurrent
-- nonmoving GC.
detNonmovingGcSyncElapsedNs :: Word64
, -- | (nanoseconds) Concurrent garbage collector.
-- The CPU time used during the post-mark pause phase of the concurrent
-- nonmoving GC.
detNonmovingGcCpuNs :: Word64
, -- | (nanoseconds) Concurrent garbage collector.
-- The time elapsed during the post-mark pause phase of the concurrent
-- nonmoving GC.
detNonmovingGcElapsedNs :: Word64
}
deriving (Show)
zeroDetails :: Details
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. Note: to use 'getGCLog' you first need to also
-- call @'enableGClogging' True@.
setGCHook :: IO ()
setGCHook =
c_set_gchook >>= \case
CBool 0 -> throwIO (userError "Failure setting GC hook")
CBool _ -> return ()
-- | Enable or disable GC logging. If the argument is true, logging is enabled;
-- if the argument is false, any pending logs are cleared and logging is
-- disabled from now on.
enableGClogging :: Bool -> IO ()
enableGClogging yes = c_gchook_enable_logging (CBool (if yes then 1 else 0))
-- | Set a C function to be called after every GC. Use this in the following manner:
--
-- * Create a file @cbits/something.c@ in your project (the actual file name
-- doesn't matter), and add @c-sources: cbits/something.c@ to the stanza of
-- the correct component in your .cabal file.
-- * Put the following in it: (The function names are unimportant.)
--
-- > #include "Rts.h"
-- >
-- > // the static is unnecessary, but neat
-- > static void my_delegate_function(const struct GCDetails_ *d) {
-- > // put your code here
-- > }
-- >
-- > void* get_my_delegate_ptr(void) {
-- > return my_delegate_function;
-- > }
--
-- * Use the following in Haskell:
--
-- @
-- {-# LANGUAGE ForeignFunctionInterface #-}
-- import Foreign.Ptr (Ptr)
-- foreign import ccall "get_my_delegate_ptr" c_get_my_delegate_ptr :: IO (Ptr ())
-- -- ...
-- do funptr <- c_get_my_delegate_ptr
-- 'gcSetHookDelegate' funptr
-- @
gcSetHookDelegate :: Ptr () -> IO ()
gcSetHookDelegate funptr =
c_gchook_set_c_delegate funptr >>= \case
CBool 0 -> throwIO (userError "Failure setting hook delegate, already set?")
CBool _ -> return ()
-- | Get the log of 'Details' structures up until now; also clears the log. You
-- will never get the same structure twice.
--
-- Note: This is not entirely atomic. If you call this function concurrently,
-- it is possible that alternatingly, some events go to one 'getGCLog' call and
-- other events go to the other call.
getGCLog :: IO [Details]
getGCLog =
getLogBatch >>= \case
[] -> return []
batch -> (batch ++) <$> getGCLog
getLogBatch :: IO [Details]
getLogBatch =
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 =
[(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 })
,(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)
|
