1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE MultiWayIf #-}
4{-# OPTIONS_GHC -fsimpl-tick-factor=150 #-}
5{-
6 -   Parser functions for GHC RTS EventLog framework.
7 -}
8
9module GHC.RTS.Events (
10       -- * The event log types
11       EventLog(..),
12       Header(..),
13       Data(..),
14       EventType(..),
15       Event(..),
16       EventInfo(..),
17       ThreadStopStatus(..),
18       CapsetType(..),
19       HeapProfBreakdown(..),
20       HeapProfFlags(..),
21       Timestamp,
22       ThreadId,
23       TaskId,
24       KernelThreadId(..),
25       EventTypeNum,
26       EventTypeDesc,
27       EventTypeSize,
28       BlockSize,
29       Capset,
30       PID,
31       StringId,
32       -- some types for the parallel RTS
33       ProcessId,
34       MachineId,
35       PortId,
36       MessageSize,
37       MessageTag(..),
38       ParConjDynId,
39       ParConjStaticId,
40       SparkId,
41       FutureId,
42       PerfEventTypeNum,
43
44       -- * Reading and writing event logs
45       readEventLogFromFile,
46       writeEventLogToFile,
47
48       serialiseEventLog,
49
50       -- * Utilities
51       CapEvent(..), sortEvents,
52       buildEventTypeMap,
53
54       -- * Printing
55       printEventsIncremental,
56       showEventInfo, buildEventInfo,
57       showThreadStopStatus,
58       ppEventLog, ppEventType,
59       ppEvent, buildEvent, buildEvent',
60
61       -- * Perf events
62       nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT,
63       sz_perf_num, sz_kernel_tid,
64
65       -- * For compatibility with old clients
66       -- readEventLogFromFile, TODO
67       spec,
68       time,
69  ) where
70
71{- Libraries. -}
72import Control.Applicative
73import Control.Concurrent hiding (ThreadId)
74import qualified Data.Binary.Put as P
75import qualified Data.ByteString as B
76import qualified Data.ByteString.Char8 as B8
77import qualified Data.ByteString.Lazy as BL
78import Data.Char (isPrint)
79import Data.IntMap (IntMap)
80import qualified Data.IntMap as IM
81import Data.Function hiding (id)
82import Data.List
83import Data.String (IsString)
84import qualified Data.Text as T
85import qualified Data.Text.Encoding as TE
86import qualified Data.Text.Lazy as TL
87import qualified Data.Text.Lazy.Builder as TB
88import qualified Data.Text.Lazy.Builder.Int as TB
89import qualified Data.Text.Lazy.IO as TL
90import qualified Data.Vector.Unboxed as VU
91import Data.Word
92import System.IO
93import Prelude hiding (gcd, rem, id)
94
95import GHC.RTS.EventTypes
96import GHC.RTS.Events.Binary
97import GHC.RTS.Events.Incremental
98
99#if !MIN_VERSION_base(4, 8, 0)
100import Data.Foldable (foldMap)
101import Data.Monoid (mempty)
102#endif
103
104#if !MIN_VERSION_base(4, 11, 0)
105import Data.Monoid ((<>))
106#endif
107
108-- | Read an entire eventlog file. It returns an error message if it
109-- encouters an error while decoding.
110--
111-- Note that it doesn't fail if it consumes all input in the middle of decoding
112-- of an event.
113readEventLogFromFile :: FilePath -> IO (Either String EventLog)
114readEventLogFromFile path = fmap fst . readEventLog <$> BL.readFile path
115
116-- | Read an eventlog file and pretty print it to stdout
117printEventsIncremental
118  :: Bool -- ^ Follow the file or not
119  -> FilePath
120  -> IO ()
121printEventsIncremental follow path =
122  withFile path ReadMode (hPrintEventsIncremental follow)
123
124-- | Read an eventlog from the Handle and pretty print it to stdout
125hPrintEventsIncremental
126  :: Bool -- ^ Follow the handle or not
127  -> Handle
128  -> IO ()
129hPrintEventsIncremental follow hdl = go decodeEventLog
130  where
131    go decoder = case decoder of
132      Produce event decoder' -> do
133        TL.hPutStrLn stdout $ TB.toLazyText $ buildEvent' event
134        go decoder'
135      Consume k -> do
136        chunk <- B.hGetSome hdl 4096
137        if
138          | not (B.null chunk) -> go $ k chunk
139          | follow -> threadDelay 1000000 >> go decoder
140          | otherwise -> return ()
141      Done {} -> return ()
142      Error _ err -> fail err
143
144
145-- | Writes the 'EventLog' to file. The log is expected to __NOT__ have 'EventBlock'
146-- markers/events - the parsers no longer emit them and they are handled behind
147-- the scenes.
148writeEventLogToFile :: FilePath -> EventLog -> IO ()
149writeEventLogToFile fp = BL.writeFile fp . serialiseEventLog
150
151
152-- | Serialises an 'EventLog' back to a 'ByteString', usually for writing it
153-- back to a file.
154serialiseEventLog :: EventLog -> BL.ByteString
155serialiseEventLog el@(EventLog _ (Data events)) =
156  P.runPut $ putEventLog blockedEl
157  where
158    eventsMap = capSplitEvents events
159    blockedEventsMap = IM.mapWithKey addBlockMarker eventsMap
160    blockedEl = el{dat = Data blockedEvents}
161    blockedEvents = IM.foldr (++) [] blockedEventsMap
162
163-- Gets the Capability of an event in numeric form
164getIntCap :: Event -> Int
165getIntCap Event{evCap = cap} =
166  case cap of
167  Just capNo -> capNo
168  Nothing    -> -1
169
170-- Creates an IntMap of the events with capability number as the key.
171-- Key -1 indicates global (capless) event
172capSplitEvents :: [Event] -> IM.IntMap [Event]
173capSplitEvents evts = capSplitEvents' evts IM.empty
174
175capSplitEvents' :: [Event] -> IM.IntMap [Event] -> IM.IntMap [Event]
176capSplitEvents' evts imap =
177  case evts of
178  (x:xs) -> capSplitEvents' xs (IM.insertWith (++) (getIntCap x) [x] imap)
179  []     -> imap
180
181-- Adds a block marker to the beginnng of a list of events, annotated with
182-- its capability. All events are expected to belong to the same cap.
183addBlockMarker :: Int -> [Event] -> [Event]
184addBlockMarker cap evts =
185  (Event startTime (EventBlock endTime cap sz) (mkCap cap)) : sortedEvts
186  where
187    sz = fromIntegral . BL.length $ P.runPut $ mapM_ putEvent evts
188    startTime = case sortedEvts of
189      (x:_) -> evTime x
190      [] -> error "Cannot add block marker to an empty list of events"
191    sortedEvts = sortEvents evts
192    endTime = evTime $ last sortedEvts
193
194-- -----------------------------------------------------------------------------
195-- Utilities
196sortEvents :: [Event] -> [Event]
197sortEvents = sortBy (compare `on` evTime)
198
199buildEventTypeMap :: [EventType] -> IntMap EventType
200buildEventTypeMap etypes =
201  IM.fromList [ (fromIntegral (num t),t) | t <- etypes ]
202
203-----------------------------------------------------------------------------
204-- Some pretty-printing support
205
206showEventInfo :: EventInfo -> String
207showEventInfo = TL.unpack . TB.toLazyText . buildEventInfo
208
209buildEventInfo :: EventInfo -> TB.Builder
210buildEventInfo spec' =
211    case spec' of
212        EventBlock end_time cap _block_events ->
213          "event block: cap " <> TB.decimal cap
214          <> ", end time: " <> TB.decimal end_time <> "\n"
215        Startup n_caps ->
216          "startup: " <> TB.decimal n_caps <> " capabilities"
217        CreateThread thread ->
218          "creating thread " <> TB.decimal thread
219        RunThread thread ->
220          "running thread " <> TB.decimal thread
221        StopThread thread status ->
222          "stopping thread " <> TB.decimal thread
223          <> " (" <> TB.fromString (showThreadStopStatus status) <> ")"
224        ThreadRunnable thread ->
225          "thread " <> TB.decimal thread <> " is runnable"
226        MigrateThread thread newCap  ->
227          "migrating thread " <> TB.decimal thread
228          <> " to cap " <> TB.decimal newCap
229        CreateSparkThread sparkThread ->
230          "creating spark thread " <> TB.decimal sparkThread
231        SparkCounters crt dud ovf cnv fiz gcd rem ->
232          "spark stats: "
233          <> TB.decimal crt <> " created, "
234          <> TB.decimal cnv <> " converted, "
235          <> TB.decimal rem <> " remaining ("
236          <> TB.decimal ovf <> " overflowed, "
237          <> TB.decimal dud <> " dud, "
238          <> TB.decimal gcd <> " GC'd, "
239          <> TB.decimal fiz <> " fizzled)"
240        SparkCreate ->
241          "spark created"
242        SparkDud ->
243          "dud spark discarded"
244        SparkOverflow ->
245          "overflowed spark discarded"
246        SparkRun ->
247          "running a local spark"
248        SparkSteal victimCap ->
249          "stealing a spark from cap " <> TB.decimal victimCap
250        SparkFizzle ->
251          "spark fizzled"
252        SparkGC ->
253          "spark GCed"
254        TaskCreate taskId cap tid ->
255          "task 0x" <> TB.hexadecimal taskId
256          <> " created on cap " <> TB.decimal cap
257          <>" with OS kernel thread " <> TB.decimal (kernelThreadId tid)
258        TaskMigrate taskId cap new_cap ->
259          "task 0x" <> TB.hexadecimal taskId
260          <> " migrated from cap " <> TB.decimal cap
261          <> " to cap " <> TB.decimal new_cap
262        TaskDelete taskId ->
263          "task 0x" <> TB.hexadecimal taskId <> " deleted"
264        Shutdown ->
265          "shutting down"
266        WakeupThread thread otherCap ->
267          "waking up thread " <> TB.decimal thread
268          <> " on cap " <> TB.decimal otherCap
269        ThreadLabel thread label ->
270          "thread " <> TB.decimal thread
271          <> " has label \"" <> TB.fromText label <> "\""
272        RequestSeqGC ->
273          "requesting sequential GC"
274        RequestParGC ->
275          "requesting parallel GC"
276        StartGC ->
277          "starting GC"
278        EndGC ->
279          "finished GC"
280        GCWork ->
281          "GC working"
282        GCIdle ->
283          "GC idle"
284        GCDone ->
285          "GC done"
286        GlobalSyncGC ->
287          "all caps stopped for GC"
288        GCStatsGHC{..} ->
289          "GC stats for heap capset " <> TB.decimal heapCapset
290          <> ": generation " <> TB.decimal gen <> ", "
291          <> TB.decimal copied <> " bytes copied, "
292          <> TB.decimal slop <> " bytes slop, "
293          <> TB.decimal frag <> " bytes fragmentation, "
294          <> TB.decimal parNThreads <> " par threads, "
295          <> TB.decimal parMaxCopied <> " bytes max par copied, "
296          <> TB.decimal parTotCopied <> " bytes total par copied"
297          <> maybe mempty (\val -> ", " <> TB.decimal val <> " bytes balanced par copied") parBalancedCopied
298        MemReturn{..} ->
299          "memory returned (mblocks): current(" <> TB.decimal current  <>
300                                   ") needed(" <> TB.decimal needed  <>
301                                   ") returned(" <> TB.decimal returned <> ")"
302        HeapAllocated{..} ->
303          "allocated on heap capset " <> TB.decimal heapCapset
304          <> ": " <> TB.decimal allocBytes <> " total bytes till now"
305        HeapSize{..} ->
306          "size of heap capset " <> TB.decimal heapCapset
307          <> ": " <> TB.decimal sizeBytes <> " bytes"
308        BlocksSize{..} ->
309          "blocks size of heap capset " <> TB.decimal heapCapset
310          <> ": " <> TB.decimal blocksSize <> " bytes"
311        HeapLive{..} ->
312          "live data in heap capset " <> TB.decimal heapCapset
313          <> ": " <> TB.decimal liveBytes <> " bytes"
314        HeapInfoGHC{..} ->
315          "heap stats for heap capset " <> TB.decimal heapCapset
316          <> ": generations " <> TB.decimal gens <> ", "
317          <> TB.decimal maxHeapSize <> " bytes max heap size, "
318          <> TB.decimal allocAreaSize <> " bytes alloc area size, "
319          <> TB.decimal mblockSize <> " bytes mblock size, "
320          <> TB.decimal blockSize <> " bytes block size"
321        CapCreate{cap} ->
322          "created cap " <> TB.decimal cap
323        CapDelete{cap} ->
324          "deleted cap " <> TB.decimal cap
325        CapDisable{cap} ->
326          "disabled cap " <> TB.decimal cap
327        CapEnable{cap} ->
328          "enabled cap " <> TB.decimal cap
329        Message msg ->
330          TB.fromText msg
331        UserMessage msg ->
332          TB.fromText msg
333        UserMarker markername ->
334          "marker: " <> TB.fromText markername
335        CapsetCreate cs ct ->
336          "created capset " <> TB.decimal cs
337          <> " of type " <> TB.fromString (show ct)
338        CapsetDelete cs ->
339          "deleted capset " <> TB.decimal cs
340        CapsetAssignCap cs cp ->
341          "assigned cap " <> TB.decimal cp <> " to capset " <> TB.decimal cs
342        CapsetRemoveCap cs cp ->
343          "removed cap " <> TB.decimal cp <> " from capset " <> TB.decimal cs
344        OsProcessPid cs pid ->
345          "capset " <> TB.decimal cs <> ": pid " <> TB.decimal pid
346        OsProcessParentPid cs ppid ->
347          "capset " <> TB.decimal cs <> ": parent pid " <> TB.decimal ppid
348        WallClockTime cs sec nsec ->
349          "capset " <> TB.decimal cs <> ": wall clock time "
350          <> TB.decimal sec <> "s "
351          <> TB.decimal nsec <> "ns (unix epoch)"
352        RtsIdentifier cs i ->
353          "capset " <> TB.decimal cs
354          <> ": RTS version \"" <> TB.fromText i <> "\""
355        ProgramArgs cs args ->
356          "capset " <> TB.decimal cs
357          <> ": args: " <> TB.fromString (show args)
358        ProgramEnv cs env ->
359          "capset " <> TB.decimal cs
360          <> ": env: " <> TB.fromString (show env)
361        UnknownEvent n ->
362          "Unknown event type " <> TB.decimal n
363        InternString str sId ->
364          "Interned string: \"" <> TB.fromString str
365          <> "\" with id " <> TB.decimal sId
366        -- events for the parallel RTS
367        Version version ->
368          "compiler version is " <> TB.fromString version
369        ProgramInvocation  commandline ->
370          "program invocation: " <> TB.fromString commandline
371        EdenStartReceive ->
372          "starting to receive"
373        EdenEndReceive ->
374          "stop receiving"
375        CreateProcess  process ->
376          "creating process " <> TB.decimal process
377        KillProcess process ->
378          "killing process " <> TB.decimal process
379        AssignThreadToProcess thread process ->
380          "assigning thread " <> TB.decimal thread
381          <> " to process " <> TB.decimal process
382        CreateMachine machine realtime ->
383          "creating machine " <> TB.decimal machine
384          <> " at " <> TB.decimal realtime
385        KillMachine machine ->
386          "killing machine " <> TB.decimal machine
387        SendMessage mesTag senderProcess senderThread
388          receiverMachine receiverProcess receiverInport ->
389            "sending message with tag " <> TB.fromString (show mesTag)
390            <> " from process " <> TB.decimal senderProcess
391            <> ", thread " <> TB.decimal senderThread
392            <> " to machine " <> TB.decimal receiverMachine
393            <> ", process " <> TB.decimal receiverProcess
394            <> " on inport " <> TB.decimal receiverInport
395        ReceiveMessage mesTag receiverProcess receiverInport
396          senderMachine senderProcess senderThread messageSize ->
397            "receiving message with tag " <> TB.fromString (show mesTag)
398            <> " at process " <> TB.decimal receiverProcess
399            <> ", inport " <> TB.decimal receiverInport
400            <> " from machine " <> TB.decimal senderMachine
401            <> ", process " <> TB.decimal senderProcess
402            <> ", thread " <> TB.decimal senderThread
403            <> " with size " <> TB.decimal messageSize
404        SendReceiveLocalMessage mesTag senderProcess senderThread
405          receiverProcess receiverInport ->
406            "sending/receiving message with tag " <> TB.fromString (show mesTag)
407            <> " from process " <> TB.decimal senderProcess
408            <> ", thread " <> TB.decimal senderThread
409            <> " to process " <> TB.decimal receiverProcess
410            <> " on inport " <> TB.decimal receiverInport
411        MerStartParConjunction dyn_id static_id ->
412          "Start a parallel conjunction 0x" <> TB.hexadecimal dyn_id
413          <> ", static_id: " <> TB.decimal static_id
414        MerEndParConjunction dyn_id ->
415          "End par conjunction: 0x" <> TB.hexadecimal dyn_id
416        MerEndParConjunct dyn_id ->
417          "End par conjunct: 0x" <> TB.hexadecimal dyn_id
418        MerCreateSpark dyn_id spark_id ->
419          "Create spark for conjunction: 0x" <> TB.hexadecimal dyn_id
420          <> " spark: 0x" <> TB.hexadecimal spark_id
421        MerFutureCreate future_id name_id ->
422          "Create future 0x" <> TB.hexadecimal future_id
423          <> " named " <> TB.decimal name_id
424        MerFutureWaitNosuspend future_id ->
425          "Wait didn't suspend for future: 0x" <> TB.hexadecimal future_id
426        MerFutureWaitSuspended future_id ->
427          "Wait suspended on future: 0x" <> TB.hexadecimal future_id
428        MerFutureSignal future_id ->
429          "Signaled future 0x" <> TB.hexadecimal future_id
430        MerLookingForGlobalThread ->
431          "Looking for global thread to resume"
432        MerWorkStealing ->
433          "Trying to steal a spark"
434        MerLookingForLocalSpark ->
435          "Looking for a local spark to execute"
436        MerReleaseThread thread_id ->
437          "Releasing thread " <> TB.decimal thread_id <> " to the free pool"
438        MerCapSleeping ->
439          "Capability going to sleep"
440        MerCallingMain ->
441          "About to call the program entry point"
442        PerfName{perfNum, name} ->
443          "perf event " <> TB.decimal perfNum
444          <> " named \"" <> TB.fromText name <> "\""
445        PerfCounter{perfNum, tid, period} ->
446          "perf event counter " <> TB.decimal perfNum
447          <> " incremented by " <> TB.decimal (period + 1)
448          <> " in OS thread " <> TB.decimal (kernelThreadId tid)
449        PerfTracepoint{perfNum, tid} ->
450          "perf event tracepoint " <> TB.decimal perfNum
451          <> " reached in OS thread " <> TB.decimal (kernelThreadId tid)
452        HeapProfBegin {..} ->
453          "start heap profiling " <> TB.decimal heapProfId
454          <> " at sampling period " <> TB.decimal heapProfSamplingPeriod
455          <> " broken down by " <> showHeapProfBreakdown heapProfBreakdown
456          <> maybe "" (" filtered by " <>)
457            (buildFilters
458              [ heapProfModuleFilter
459              , heapProfClosureDescrFilter
460              , heapProfTypeDescrFilter
461              , heapProfCostCentreFilter
462              , heapProfCostCentreStackFilter
463              , heapProfRetainerFilter
464              , heapProfBiographyFilter
465              ])
466        HeapProfCostCentre {..} ->
467          "cost centre " <> TB.decimal heapProfCostCentreId
468          <> " " <> TB.fromText heapProfLabel
469          <> " in " <> TB.fromText heapProfModule
470          <> " at " <> TB.fromText heapProfSrcLoc
471          <> if isCaf heapProfFlags then " CAF" else ""
472        InfoTableProv{..} ->
473         "Info Table: " <> TB.hexadecimal itInfo <> ":"
474                        <> TB.decimal itClosureDesc <> ":"
475                        <> TB.fromText itTableName
476                        <> " - " <> TB.fromText itSrcLoc
477        HeapProfSampleBegin {..} ->
478          "start heap prof sample " <> TB.decimal heapProfSampleEra
479        HeapProfSampleEnd {..} ->
480          "end prof sample " <> TB.decimal heapProfSampleEra
481        HeapBioProfSampleBegin {..} ->
482          "start heap prof sample " <> TB.decimal heapProfSampleEra
483            <> " at time " <> TB.decimal heapProfSampleTime
484
485
486        HeapProfSampleCostCentre {..} ->
487          "heap prof sample " <> TB.decimal heapProfId
488          <> ", residency " <> TB.decimal heapProfResidency
489          <> ", cost centre stack " <> buildCostCentreStack heapProfStack
490
491        HeapProfSampleString {..} ->
492          "heap prof sample " <> TB.decimal heapProfId
493          <> ", residency " <> TB.decimal heapProfResidency
494          <> ", label " <> TB.fromText heapProfLabel
495
496        ProfSampleCostCentre {..} ->
497          "cap no " <> TB.decimal profCapset
498          <> ", prof sample " <> TB.decimal profTicks
499          <> ", cost centre stack " <> buildCostCentreStack profCcsStack
500
501        ProfBegin {..} ->
502          "start time profiling, tick interval " <> TB.decimal profTickInterval <> " (ns)"
503
504        UserBinaryMessage {..} ->
505          "binary message " <> TB.fromText (replaceUnprintableWith '.' payload)
506
507        ConcMarkBegin    ->
508          "concurrent mark began"
509        ConcMarkEnd {..} ->
510          "concurrent mark ended: "
511          <> "marked " <> TB.decimal concMarkedObjectCount <> " objects"
512        ConcSyncBegin ->
513          "post-mark synchronization began"
514        ConcSyncEnd ->
515          "post-mark synchronization ended"
516        ConcSweepBegin ->
517          "concurrent sweep began"
518        ConcSweepEnd ->
519          "concurrent sweep ended"
520        ConcUpdRemSetFlush {..}  ->
521          "update remembered set flushed by " <> TB.decimal cap
522        NonmovingHeapCensus {..}  ->
523          "nonmoving heap census " <> TB.decimal (2^nonmovingCensusBlkSize :: Int)
524          <> ": " <> TB.decimal nonmovingCensusActiveSegs <> " active segments"
525          <> ", " <> TB.decimal nonmovingCensusFilledSegs <> " filled segments"
526          <> ", " <> TB.decimal nonmovingCensusLiveBlocks <> " live blocks"
527        TickyCounterDef {..}  ->
528          "ticky counter definition " <> TB.decimal tickyCtrDefId
529          <> ", " <>  "arity: " <> TB.decimal tickyCtrDefArity
530          <> ", " <> "def kinds: " <> TB.fromText tickyCtrDefKinds
531          <> ", " <> "name: " <> TB.fromText tickyCtrDefName
532        TickyCounterSample {..}  ->
533          "ticky counter sample " <> TB.decimal tickyCtrSampleId
534          <> ": " <> "entry count: " <> TB.decimal tickyCtrSampleEntryCount
535          <> ", " <> TB.decimal tickyCtrSampleAllocs <> " allocs"
536          <> ", " <> TB.decimal tickyCtrSampleAllocd <> " allocd"
537        TickyBeginSample ->
538          "ticky begin counter sample"
539
540-- | Replace unprintable bytes in the message with the replacement character
541replaceUnprintableWith
542  :: Char -- ^ Replacement character
543  -> B.ByteString -- ^ Binary message which may contain unprintable bytes
544  -> T.Text
545replaceUnprintableWith replacement = TE.decodeUtf8 . B8.map replace
546  where
547    replace c
548      | isPrint c = c
549      | otherwise = replacement
550
551buildFilters :: [T.Text] -> Maybe TB.Builder
552buildFilters = foldr g Nothing
553  where
554    g f b
555      | T.null f = b
556      | otherwise = Just (TB.fromText f <> ", ") <> b
557
558buildCostCentreStack :: VU.Vector Word32 -> TB.Builder
559buildCostCentreStack = VU.ifoldl' go ""
560  where
561    go b i cc
562      | i == 0 = TB.decimal cc
563      | otherwise = b <> ", " <> TB.decimal cc
564
565showThreadStopStatus :: ThreadStopStatus -> String
566showThreadStopStatus HeapOverflow   = "heap overflow"
567showThreadStopStatus StackOverflow  = "stack overflow"
568showThreadStopStatus ThreadYielding = "thread yielding"
569showThreadStopStatus ThreadBlocked  = "thread blocked"
570showThreadStopStatus ThreadFinished = "thread finished"
571showThreadStopStatus ForeignCall    = "making a foreign call"
572showThreadStopStatus BlockedOnMVar  = "blocked on an MVar"
573showThreadStopStatus BlockedOnMVarRead = "blocked reading an MVar"
574showThreadStopStatus BlockedOnBlackHole = "blocked on a black hole"
575showThreadStopStatus BlockedOnRead = "blocked on I/O read"
576showThreadStopStatus BlockedOnWrite = "blocked on I/O write"
577showThreadStopStatus BlockedOnDelay = "blocked on threadDelay"
578showThreadStopStatus BlockedOnSTM = "blocked in STM retry"
579showThreadStopStatus BlockedOnDoProc = "blocked on asyncDoProc"
580showThreadStopStatus BlockedOnCCall = "blocked in a foreign call"
581showThreadStopStatus BlockedOnCCall_NoUnblockExc = "blocked in a foreign call"
582showThreadStopStatus BlockedOnMsgThrowTo = "blocked in throwTo"
583showThreadStopStatus ThreadMigrating = "thread migrating"
584showThreadStopStatus BlockedOnMsgGlobalise = "waiting for data to be globalised"
585showThreadStopStatus (BlockedOnBlackHoleOwnedBy target) =
586          "blocked on black hole owned by thread " ++ show target
587showThreadStopStatus NoStatus = "No stop thread status"
588
589showHeapProfBreakdown :: IsString s => HeapProfBreakdown -> s
590showHeapProfBreakdown breakdown = case breakdown of
591  HeapProfBreakdownCostCentre -> "cost centre"
592  HeapProfBreakdownModule -> "module"
593  HeapProfBreakdownClosureDescr -> "closure description"
594  HeapProfBreakdownTypeDescr -> "type description"
595  HeapProfBreakdownRetainer -> "retainer"
596  HeapProfBreakdownBiography -> "biography"
597  HeapProfBreakdownClosureType -> "closure type"
598  HeapProfBreakdownInfoTable -> "info table"
599
600ppEventLog :: EventLog -> String
601ppEventLog = TL.unpack . TB.toLazyText . buildEventLog
602
603buildEventLog :: EventLog -> TB.Builder
604buildEventLog (EventLog (Header ets) (Data es)) =
605  "Event Types:\n"
606  <> foldMap (\evType -> buildEventType evType <> "\n") ets
607  <> "\n"
608  <> "Events:\n"
609  <> foldMap (\ev -> buildEvent imap ev <> "\n") sorted
610  where
611    imap = buildEventTypeMap ets
612    sorted = sortEvents es
613
614ppEventType :: EventType -> String
615ppEventType = TL.unpack . TB.toLazyText . buildEventType
616
617buildEventType :: EventType -> TB.Builder
618buildEventType (EventType num dsc msz) =
619  TB.decimal num <> ": "
620  <> TB.fromText dsc <> " (size "
621  <> maybe "variable" TB.decimal msz <> ")"
622
623-- | Pretty prints an 'Event', with clean handling for 'UnknownEvent'
624ppEvent :: IntMap EventType -> Event -> String
625ppEvent imap = TL.unpack . TB.toLazyText . buildEvent imap
626
627buildEvent :: IntMap EventType -> Event -> TB.Builder
628buildEvent imap Event {..} =
629  TB.decimal evTime
630  <> ": "
631  <> maybe "" (\c -> "cap " <> TB.decimal c <> ": ") evCap
632  <> case evSpec of
633    UnknownEvent{ ref=ref } ->
634      maybe "" (TB.fromText . desc) $ IM.lookup (fromIntegral ref) imap
635    _ -> buildEventInfo evSpec
636
637buildEvent' :: Event -> TB.Builder
638buildEvent' Event {..} =
639   TB.decimal evTime
640   <> ": "
641   <> maybe "" (\c -> "cap " <> TB.decimal c <> ": ") evCap
642   <> case evSpec of
643     UnknownEvent{ ref=ref } ->
644      "Unknown Event (ref: " <> TB.decimal ref <> ")"
645     _ -> buildEventInfo evSpec
646