|
|
1
|
+{-# LANGUAGE NamedFieldPuns #-}
|
|
|
2
|
+{-# LANGUAGE OverloadedStrings #-}
|
|
|
3
|
+{-# LANGUAGE LambdaCase #-}
|
|
|
4
|
+{-# LANGUAGE MagicHash #-}
|
|
|
5
|
+{-# LANGUAGE UnboxedTuples #-}
|
|
|
6
|
+{-# LANGUAGE CPP #-}
|
|
|
7
|
+
|
|
|
8
|
+module GHC.EventLog.Sample where
|
|
|
9
|
+import Prelude
|
|
|
10
|
+
|
|
|
11
|
+import Control.Concurrent
|
|
|
12
|
+import Control.Exception
|
|
|
13
|
+import Control.Monad
|
|
|
14
|
+import qualified Data.ByteString.Lazy as LBS
|
|
|
15
|
+import qualified Data.List as List
|
|
|
16
|
+import GHC.Conc
|
|
|
17
|
+import GHC.Conc.Sync
|
|
|
18
|
+
|
|
|
19
|
+import Control.Concurrent
|
|
|
20
|
+import Control.Monad (replicateM, when)
|
|
|
21
|
+import Data.Binary
|
|
|
22
|
+import Data.Binary.Get
|
|
|
23
|
+import Data.Binary.Put
|
|
|
24
|
+import qualified Data.ByteString as B
|
|
|
25
|
+import qualified Data.ByteString.Unsafe as BU
|
|
|
26
|
+import qualified System.IO.Unsafe as Unsafe
|
|
|
27
|
+import qualified Data.ByteString.Lazy as LBS
|
|
|
28
|
+import Data.Text (Text)
|
|
|
29
|
+import qualified Data.Text as Text
|
|
|
30
|
+import Data.Typeable (cast)
|
|
|
31
|
+import Data.Maybe
|
|
|
32
|
+import qualified Data.List.NonEmpty as NonEmpty
|
|
|
33
|
+import Unsafe.Coerce
|
|
|
34
|
+import GHC.Exts (Ptr(..), Int(..), traceBinaryEvent#)
|
|
|
35
|
+import GHC.IO (IO(..))
|
|
|
36
|
+import GHC.Stack.Annotation.Experimental
|
|
|
37
|
+
|
|
|
38
|
+import GHC.Stack.CloneStack (StackSnapshot(..), cloneThreadStack)
|
|
|
39
|
+import GHC.Internal.Conc.Sync
|
|
|
40
|
+
|
|
|
41
|
+import GHC.Internal.Conc.Sync
|
|
|
42
|
+import GHC.Internal.InfoProv.Types (InfoProv(..), lookupIpProvId)
|
|
|
43
|
+import GHC.Internal.Heap.Closures
|
|
|
44
|
+import qualified GHC.Internal.Stack.Decode as Decode
|
|
|
45
|
+import GHC.Internal.Stack.Types
|
|
|
46
|
+
|
|
|
47
|
+import Control.Monad (replicateM)
|
|
|
48
|
+import Data.Binary
|
|
|
49
|
+import Data.Binary.Put
|
|
|
50
|
+import Data.Binary.Get
|
|
|
51
|
+
|
|
|
52
|
+import GHC.Internal.RTS.Flags.Test
|
|
|
53
|
+
|
|
|
54
|
+import Debug.Trace
|
|
|
55
|
+import GHC.Profiling.Eras
|
|
|
56
|
+
|
|
|
57
|
+traceBinaryEventIO :: B.ByteString -> IO ()
|
|
|
58
|
+traceBinaryEventIO bytes = traceBinaryEventIO' bytes
|
|
|
59
|
+
|
|
|
60
|
+traceBinaryEventIO' :: B.ByteString -> IO ()
|
|
|
61
|
+traceBinaryEventIO' bytes =
|
|
|
62
|
+ BU.unsafeUseAsCStringLen bytes $ \(Ptr p, I# n) -> IO $ \s ->
|
|
|
63
|
+ case traceBinaryEvent# p n s of
|
|
|
64
|
+ s' -> (# s', () #)
|
|
|
65
|
+
|
|
|
66
|
+data SamplerThread = MkSamplerThread
|
|
|
67
|
+ { samplerThreadId :: ThreadId
|
|
|
68
|
+ } deriving (Show, Eq, Ord)
|
|
|
69
|
+
|
|
|
70
|
+withSampleProfiler :: Int -> IO a -> IO a
|
|
|
71
|
+withSampleProfiler delay act = do
|
|
|
72
|
+ enabled <- getUserEventTracingEnabled
|
|
|
73
|
+ if enabled
|
|
|
74
|
+ then bracket setupSamplers tearDownSamplers (const act)
|
|
|
75
|
+ else act
|
|
|
76
|
+ where
|
|
|
77
|
+ setupSamplers = do
|
|
|
78
|
+ samplerThreadConfigMVar <- newEmptyMVar
|
|
|
79
|
+ sid <- forkIO $ do
|
|
|
80
|
+ config <- takeMVar samplerThreadConfigMVar
|
|
|
81
|
+ sampleThreadId <- myThreadId
|
|
|
82
|
+ labelThread sampleThreadId "Sample Profiler Thread"
|
|
|
83
|
+ forever $ do
|
|
|
84
|
+ tids <- listThreads
|
|
|
85
|
+ userThreads <- filterM (isThreadOfInterest config) tids
|
|
|
86
|
+ forM_ userThreads $ \tid ->
|
|
|
87
|
+ sampleToEventlog tid
|
|
|
88
|
+ -- TODO: this is wrong, we don't sample every delay time as sampling takes time as well
|
|
|
89
|
+ threadDelay delay
|
|
|
90
|
+
|
|
|
91
|
+ let sampleThreadConf = MkSamplerThread
|
|
|
92
|
+ { samplerThreadId = sid
|
|
|
93
|
+ }
|
|
|
94
|
+ putMVar samplerThreadConfigMVar sampleThreadConf
|
|
|
95
|
+ pure sampleThreadConf
|
|
|
96
|
+
|
|
|
97
|
+ tearDownSamplers MkSamplerThread{samplerThreadId} =
|
|
|
98
|
+ killThread samplerThreadId
|
|
|
99
|
+
|
|
|
100
|
+ isThreadOfInterest :: SamplerThread -> ThreadId -> IO Bool
|
|
|
101
|
+ isThreadOfInterest config tid = do
|
|
|
102
|
+ lbl <- threadLabel tid
|
|
|
103
|
+ pure $ not $ or
|
|
|
104
|
+ [ isProfilerThread config tid lbl
|
|
|
105
|
+ , isBuiltinThread tid lbl
|
|
|
106
|
+ ]
|
|
|
107
|
+
|
|
|
108
|
+isProfilerThread :: SamplerThread -> ThreadId -> Maybe String -> Bool
|
|
|
109
|
+isProfilerThread MkSamplerThread {samplerThreadId} tid lbl = tid == samplerThreadId
|
|
|
110
|
+
|
|
|
111
|
+isBuiltinThread :: ThreadId -> Maybe String -> Bool
|
|
|
112
|
+isBuiltinThread _ Nothing = False
|
|
|
113
|
+isBuiltinThread _tid (Just lbl) =
|
|
|
114
|
+ lbl `elem` ["TimerManager"] || "IOManager on cap" `List.isPrefixOf` lbl
|
|
|
115
|
+
|
|
|
116
|
+
|
|
|
117
|
+sampleToEventlog :: ThreadId -> IO ()
|
|
|
118
|
+sampleToEventlog tid = do
|
|
|
119
|
+ sampleThread tid >>= \ case
|
|
|
120
|
+ Nothing -> pure ()
|
|
|
121
|
+ Just threadSample -> do
|
|
|
122
|
+ msg <- serializeThreadSample threadSample
|
|
|
123
|
+ traceBinaryEventIO $ LBS.toStrict msg
|
|
|
124
|
+
|
|
|
125
|
+
|
|
|
126
|
+----
|
|
|
127
|
+
|
|
|
128
|
+
|
|
|
129
|
+newtype CapabilityId =
|
|
|
130
|
+ CapabilityId
|
|
|
131
|
+ { getCapabilityId :: Word64
|
|
|
132
|
+ }
|
|
|
133
|
+ deriving (Show, Eq, Ord)
|
|
|
134
|
+
|
|
|
135
|
+data ThreadSample =
|
|
|
136
|
+ ThreadSample
|
|
|
137
|
+ { threadSampleId :: ThreadId
|
|
|
138
|
+ , threadSampleCapability :: CapabilityId
|
|
|
139
|
+ , threadSampleStackSnapshot :: StackSnapshot
|
|
|
140
|
+ }
|
|
|
141
|
+
|
|
|
142
|
+sampleThread :: ThreadId -> IO (Maybe ThreadSample)
|
|
|
143
|
+sampleThread tid = do
|
|
|
144
|
+ (cap, blocked) <- threadCapability tid
|
|
|
145
|
+ if blocked
|
|
|
146
|
+ then pure Nothing
|
|
|
147
|
+ else do
|
|
|
148
|
+ stack <- cloneThreadStack tid
|
|
|
149
|
+ pure $ Just $ ThreadSample
|
|
|
150
|
+ { threadSampleId = tid
|
|
|
151
|
+ , threadSampleCapability = CapabilityId $ intToWord64 cap
|
|
|
152
|
+ , threadSampleStackSnapshot = stack
|
|
|
153
|
+ }
|
|
|
154
|
+
|
|
|
155
|
+serializeThreadSample :: ThreadSample -> IO LBS.ByteString
|
|
|
156
|
+serializeThreadSample sample = do
|
|
|
157
|
+ callStackMessage <- threadSampleToCallStackMessage sample
|
|
|
158
|
+ pure $ runPut $ put callStackMessage
|
|
|
159
|
+
|
|
|
160
|
+deserializeCallStackMessage :: LBS.ByteString -> Either String CallStackMessage
|
|
|
161
|
+deserializeCallStackMessage = Right . runGet get
|
|
|
162
|
+
|
|
|
163
|
+-- Message format:
|
|
|
164
|
+--
|
|
|
165
|
+-- MESSAGE
|
|
|
166
|
+-- := "CA" "11" <STACK>
|
|
|
167
|
+-- STACK
|
|
|
168
|
+-- := <capability: Word32> <threadId: Word32> <length: Word32> <ENTRY>+
|
|
|
169
|
+-- ENTRY
|
|
|
170
|
+-- := "01" <ipe: Word64>
|
|
|
171
|
+-- | "02" <string: STRING>
|
|
|
172
|
+-- | "03" <row: Word32> <col: Word32> <function: CStringLen> <filename: CStringLen>
|
|
|
173
|
+-- CStringLen
|
|
|
174
|
+-- := <length: Word8> <Char>+
|
|
|
175
|
+
|
|
|
176
|
+data CallStackMessage =
|
|
|
177
|
+ MkCallStackMessage
|
|
|
178
|
+ { callThreadId :: Word64
|
|
|
179
|
+ , callCapabilityId :: CapabilityId
|
|
|
180
|
+ , callStack :: [StackItem]
|
|
|
181
|
+ }
|
|
|
182
|
+ deriving (Eq, Ord, Show)
|
|
|
183
|
+
|
|
|
184
|
+data StackItem
|
|
|
185
|
+ = IpeId !Word64
|
|
|
186
|
+ | UserMessage !String
|
|
|
187
|
+ | SourceLocation !SourceLocation
|
|
|
188
|
+ deriving (Eq, Ord, Show)
|
|
|
189
|
+
|
|
|
190
|
+data SourceLocation =
|
|
|
191
|
+ MkSourceLocation
|
|
|
192
|
+ { line :: !Word32
|
|
|
193
|
+ , column :: !Word32
|
|
|
194
|
+ , functionName :: !Text
|
|
|
195
|
+ , fileName :: !Text
|
|
|
196
|
+ }
|
|
|
197
|
+ deriving (Eq, Ord, Show)
|
|
|
198
|
+
|
|
|
199
|
+instance Binary CallStackMessage where
|
|
|
200
|
+ put msg = do
|
|
|
201
|
+ putByteString "CA"
|
|
|
202
|
+ putByteString "11"
|
|
|
203
|
+ putWord32 $ word64ToWord32 $ getCapabilityId $ callCapabilityId msg
|
|
|
204
|
+ putWord32 $ word64ToWord32 $ callThreadId msg
|
|
|
205
|
+ putWord8 $ intToWord8 $ min cutOffLength $ length $ callStack msg -- TODO: limit number of stack entries to 2^32
|
|
|
206
|
+ mapM_ put $ take cutOffLength $ callStack msg
|
|
|
207
|
+
|
|
|
208
|
+ get = do
|
|
|
209
|
+ _ <- getByteString 2 -- CA
|
|
|
210
|
+ _ <- getByteString 2 -- 11
|
|
|
211
|
+ capId <- getWord32
|
|
|
212
|
+ tid <- getWord32
|
|
|
213
|
+ len <- getWord8
|
|
|
214
|
+ items <- replicateM (word8ToInt len) get
|
|
|
215
|
+ pure MkCallStackMessage
|
|
|
216
|
+ { callThreadId = word32ToWord64 tid
|
|
|
217
|
+ , callCapabilityId = CapabilityId $ word32ToWord64 capId
|
|
|
218
|
+ , callStack = items
|
|
|
219
|
+ }
|
|
|
220
|
+
|
|
|
221
|
+instance Binary SourceLocation where
|
|
|
222
|
+ put loc = do
|
|
|
223
|
+ putWord32 $ line loc
|
|
|
224
|
+ putWord32 $ column loc
|
|
|
225
|
+ putStringLen $ Text.unpack $ functionName loc
|
|
|
226
|
+ putStringLen $ Text.unpack $ fileName loc
|
|
|
227
|
+
|
|
|
228
|
+ get = do
|
|
|
229
|
+ MkSourceLocation
|
|
|
230
|
+ <$> getWord32
|
|
|
231
|
+ <*> getWord32
|
|
|
232
|
+ <*> (Text.pack <$> getStringLen)
|
|
|
233
|
+ <*> (Text.pack <$> getStringLen)
|
|
|
234
|
+
|
|
|
235
|
+instance Binary StackItem where
|
|
|
236
|
+ put = \ case
|
|
|
237
|
+ IpeId ipeId -> do
|
|
|
238
|
+ putWord8 1
|
|
|
239
|
+ putWord64 ipeId
|
|
|
240
|
+ UserMessage msg -> do
|
|
|
241
|
+ putWord8 2
|
|
|
242
|
+ putStringLen msg
|
|
|
243
|
+ SourceLocation loc -> do
|
|
|
244
|
+ putWord8 3
|
|
|
245
|
+ put loc
|
|
|
246
|
+
|
|
|
247
|
+ get = do
|
|
|
248
|
+ getWord8 >>= \ case
|
|
|
249
|
+ 1 -> IpeId <$> getWord64
|
|
|
250
|
+ 2 -> UserMessage <$> getStringLen
|
|
|
251
|
+ 3 -> SourceLocation <$> get
|
|
|
252
|
+ n -> fail $ "StackItem: Unexpected tag byte encounter: " <> show n
|
|
|
253
|
+
|
|
|
254
|
+decodeStackWithIpProvId :: StackSnapshot -> IO [(StackFrame, Maybe Word64)]
|
|
|
255
|
+decodeStackWithIpProvId snapshot = do
|
|
|
256
|
+ concat . snd <$> Decode.decodeStackWithFrameUnpack unpackStackFrameWithIpProvId snapshot
|
|
|
257
|
+
|
|
|
258
|
+unpackStackFrameWithIpProvId :: Decode.StackFrameLocation -> IO (StackFrame, Maybe Word64)
|
|
|
259
|
+unpackStackFrameWithIpProvId stackFrameLoc = do
|
|
|
260
|
+ Decode.unpackStackFrameTo stackFrameLoc
|
|
|
261
|
+ (\ info infoKey nextChunk@(StackSnapshot stack#) -> do
|
|
|
262
|
+ framesWithIpe <- decodeStackWithIpProvId nextChunk
|
|
|
263
|
+ mIpeId <- lookupIpProvId infoKey
|
|
|
264
|
+ pure
|
|
|
265
|
+ ( UnderflowFrame
|
|
|
266
|
+ { info_tbl = info,
|
|
|
267
|
+ nextChunk =
|
|
|
268
|
+ GenStgStackClosure
|
|
|
269
|
+ { ssc_info = info,
|
|
|
270
|
+ ssc_stack_size = Decode.getStackFields stack#,
|
|
|
271
|
+ ssc_stack = map fst framesWithIpe
|
|
|
272
|
+ }
|
|
|
273
|
+ }
|
|
|
274
|
+ , mIpeId
|
|
|
275
|
+ )
|
|
|
276
|
+
|
|
|
277
|
+ )
|
|
|
278
|
+ (\ frame infoKey -> do
|
|
|
279
|
+ mIpeId <- lookupIpProvId infoKey
|
|
|
280
|
+ pure (frame, mIpeId)
|
|
|
281
|
+ )
|
|
|
282
|
+
|
|
|
283
|
+threadSampleToCallStackMessage :: ThreadSample -> IO CallStackMessage
|
|
|
284
|
+threadSampleToCallStackMessage sample = do
|
|
|
285
|
+ frames <- decodeStackWithIpProvId $ threadSampleStackSnapshot sample
|
|
|
286
|
+ let stackMessages = fmap List.head . List.group $ mapMaybe (uncurry stackFrameToStackItem) frames
|
|
|
287
|
+ pure MkCallStackMessage
|
|
|
288
|
+ { callThreadId = fromThreadId $ threadSampleId sample
|
|
|
289
|
+ , callCapabilityId = threadSampleCapability sample
|
|
|
290
|
+ , callStack = stackMessages
|
|
|
291
|
+ }
|
|
|
292
|
+
|
|
|
293
|
+stackFrameToStackItem :: StackFrame -> Maybe Word64 -> Maybe StackItem
|
|
|
294
|
+stackFrameToStackItem frame mIpe =
|
|
|
295
|
+ case frame of
|
|
|
296
|
+ AnnFrame { annotation = Box someStackAnno } ->
|
|
|
297
|
+ case unsafeCoerce someStackAnno of
|
|
|
298
|
+ SomeStackAnnotation ann ->
|
|
|
299
|
+ case cast ann of
|
|
|
300
|
+ Just (CallStackAnnotation cs) ->
|
|
|
301
|
+ case getCallStack cs of
|
|
|
302
|
+ [] -> Nothing
|
|
|
303
|
+ ((name, sourceLoc):_) ->
|
|
|
304
|
+ Just $ SourceLocation $ MkSourceLocation
|
|
|
305
|
+ { line = intToWord32 $ srcLocStartLine sourceLoc
|
|
|
306
|
+ , column = intToWord32 $ srcLocStartCol sourceLoc
|
|
|
307
|
+ , functionName = Text.pack $ name
|
|
|
308
|
+ , fileName = Text.pack $ srcLocFile sourceLoc
|
|
|
309
|
+ }
|
|
|
310
|
+
|
|
|
311
|
+ Nothing -> case cast ann of
|
|
|
312
|
+ Just (StringAnnotation msg) ->
|
|
|
313
|
+ Just $ UserMessage msg
|
|
|
314
|
+ Nothing ->
|
|
|
315
|
+ Nothing
|
|
|
316
|
+ _ ->
|
|
|
317
|
+ IpeId <$> mIpe
|
|
|
318
|
+
|
|
|
319
|
+--------
|
|
|
320
|
+
|
|
|
321
|
+cutOffLength :: Int
|
|
|
322
|
+cutOffLength = 255
|
|
|
323
|
+
|
|
|
324
|
+putStringLenWithTag :: Word8 -> String -> Put
|
|
|
325
|
+putStringLenWithTag tag msg =
|
|
|
326
|
+ putWord8 tag <> putStringLen msg
|
|
|
327
|
+
|
|
|
328
|
+putStringLen :: String -> Put
|
|
|
329
|
+putStringLen msg =
|
|
|
330
|
+ putWord8 len <> putStringUtf8 msg
|
|
|
331
|
+ where
|
|
|
332
|
+ shortName = take cutOffLength msg
|
|
|
333
|
+ -- this is safe as we made sure that cutOffLength fits in a Word8
|
|
|
334
|
+ len = intToWord8 $ length shortName
|
|
|
335
|
+
|
|
|
336
|
+getStringLen :: Get String
|
|
|
337
|
+getStringLen = do
|
|
|
338
|
+ len <- getWord8
|
|
|
339
|
+ replicateM (word8ToInt len) get
|
|
|
340
|
+
|
|
|
341
|
+putWord64 :: Word64 -> Put
|
|
|
342
|
+putWord64 = putWord64be
|
|
|
343
|
+
|
|
|
344
|
+putWord32 :: Word32 -> Put
|
|
|
345
|
+putWord32 = putWord32be
|
|
|
346
|
+
|
|
|
347
|
+getWord64 :: Get Word64
|
|
|
348
|
+getWord64 = getWord64be
|
|
|
349
|
+
|
|
|
350
|
+getWord32 :: Get Word32
|
|
|
351
|
+getWord32 = getWord32be
|
|
|
352
|
+
|
|
|
353
|
+word64ToWord32 :: Word64 -> Word32
|
|
|
354
|
+word64ToWord32 = fromIntegral
|
|
|
355
|
+
|
|
|
356
|
+word32ToWord64 :: Word32 -> Word64
|
|
|
357
|
+word32ToWord64 = fromIntegral
|
|
|
358
|
+
|
|
|
359
|
+word32ToInt :: Word32 -> Int
|
|
|
360
|
+word32ToInt = fromIntegral
|
|
|
361
|
+
|
|
|
362
|
+word64ToInt :: Word64 -> Int
|
|
|
363
|
+word64ToInt = fromIntegral
|
|
|
364
|
+
|
|
|
365
|
+intToWord64 :: Int -> Word64
|
|
|
366
|
+intToWord64 = fromIntegral
|
|
|
367
|
+
|
|
|
368
|
+intToWord32 :: Int -> Word32
|
|
|
369
|
+intToWord32 = fromIntegral
|
|
|
370
|
+
|
|
|
371
|
+intToWord8 :: Int -> Word8
|
|
|
372
|
+intToWord8 = fromIntegral
|
|
|
373
|
+
|
|
|
374
|
+word8ToInt :: Word8 -> Int
|
|
|
375
|
+word8ToInt = fromIntegral
|
|
|
376
|
+ |