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        HeapAllocated{..} ->
299          "allocated on heap capset " <> TB.decimal heapCapset
300          <> ": " <> TB.decimal allocBytes <> " total bytes till now"
301        HeapSize{..} ->
302          "size of heap capset " <> TB.decimal heapCapset
303          <> ": " <> TB.decimal sizeBytes <> " bytes"
304        HeapLive{..} ->
305          "live data in heap capset " <> TB.decimal heapCapset
306          <> ": " <> TB.decimal liveBytes <> " bytes"
307        HeapInfoGHC{..} ->
308          "heap stats for heap capset " <> TB.decimal heapCapset
309          <> ": generations " <> TB.decimal gens <> ", "
310          <> TB.decimal maxHeapSize <> " bytes max heap size, "
311          <> TB.decimal allocAreaSize <> " bytes alloc area size, "
312          <> TB.decimal mblockSize <> " bytes mblock size, "
313          <> TB.decimal blockSize <> " bytes block size"
314        CapCreate{cap} ->
315          "created cap " <> TB.decimal cap
316        CapDelete{cap} ->
317          "deleted cap " <> TB.decimal cap
318        CapDisable{cap} ->
319          "disabled cap " <> TB.decimal cap
320        CapEnable{cap} ->
321          "enabled cap " <> TB.decimal cap
322        Message msg ->
323          TB.fromText msg
324        UserMessage msg ->
325          TB.fromText msg
326        UserMarker markername ->
327          "marker: " <> TB.fromText markername
328        CapsetCreate cs ct ->
329          "created capset " <> TB.decimal cs
330          <> " of type " <> TB.fromString (show ct)
331        CapsetDelete cs ->
332          "deleted capset " <> TB.decimal cs
333        CapsetAssignCap cs cp ->
334          "assigned cap " <> TB.decimal cp <> " to capset " <> TB.decimal cs
335        CapsetRemoveCap cs cp ->
336          "removed cap " <> TB.decimal cp <> " from capset " <> TB.decimal cs
337        OsProcessPid cs pid ->
338          "capset " <> TB.decimal cs <> ": pid " <> TB.decimal pid
339        OsProcessParentPid cs ppid ->
340          "capset " <> TB.decimal cs <> ": parent pid " <> TB.decimal ppid
341        WallClockTime cs sec nsec ->
342          "capset " <> TB.decimal cs <> ": wall clock time "
343          <> TB.decimal sec <> "s "
344          <> TB.decimal nsec <> "ns (unix epoch)"
345        RtsIdentifier cs i ->
346          "capset " <> TB.decimal cs
347          <> ": RTS version \"" <> TB.fromText i <> "\""
348        ProgramArgs cs args ->
349          "capset " <> TB.decimal cs
350          <> ": args: " <> TB.fromString (show args)
351        ProgramEnv cs env ->
352          "capset " <> TB.decimal cs
353          <> ": env: " <> TB.fromString (show env)
354        UnknownEvent n ->
355          "Unknown event type " <> TB.decimal n
356        InternString str sId ->
357          "Interned string: \"" <> TB.fromString str
358          <> "\" with id " <> TB.decimal sId
359        -- events for the parallel RTS
360        Version version ->
361          "compiler version is " <> TB.fromString version
362        ProgramInvocation  commandline ->
363          "program invocation: " <> TB.fromString commandline
364        EdenStartReceive ->
365          "starting to receive"
366        EdenEndReceive ->
367          "stop receiving"
368        CreateProcess  process ->
369          "creating process " <> TB.decimal process
370        KillProcess process ->
371          "killing process " <> TB.decimal process
372        AssignThreadToProcess thread process ->
373          "assigning thread " <> TB.decimal thread
374          <> " to process " <> TB.decimal process
375        CreateMachine machine realtime ->
376          "creating machine " <> TB.decimal machine
377          <> " at " <> TB.decimal realtime
378        KillMachine machine ->
379          "killing machine " <> TB.decimal machine
380        SendMessage mesTag senderProcess senderThread
381          receiverMachine receiverProcess receiverInport ->
382            "sending message with tag " <> TB.fromString (show mesTag)
383            <> " from process " <> TB.decimal senderProcess
384            <> ", thread " <> TB.decimal senderThread
385            <> " to machine " <> TB.decimal receiverMachine
386            <> ", process " <> TB.decimal receiverProcess
387            <> " on inport " <> TB.decimal receiverInport
388        ReceiveMessage mesTag receiverProcess receiverInport
389          senderMachine senderProcess senderThread messageSize ->
390            "receiving message with tag " <> TB.fromString (show mesTag)
391            <> " at process " <> TB.decimal receiverProcess
392            <> ", inport " <> TB.decimal receiverInport
393            <> " from machine " <> TB.decimal senderMachine
394            <> ", process " <> TB.decimal senderProcess
395            <> ", thread " <> TB.decimal senderThread
396            <> " with size " <> TB.decimal messageSize
397        SendReceiveLocalMessage mesTag senderProcess senderThread
398          receiverProcess receiverInport ->
399            "sending/receiving message with tag " <> TB.fromString (show mesTag)
400            <> " from process " <> TB.decimal senderProcess
401            <> ", thread " <> TB.decimal senderThread
402            <> " to process " <> TB.decimal receiverProcess
403            <> " on inport " <> TB.decimal receiverInport
404        MerStartParConjunction dyn_id static_id ->
405          "Start a parallel conjunction 0x" <> TB.hexadecimal dyn_id
406          <> ", static_id: " <> TB.decimal static_id
407        MerEndParConjunction dyn_id ->
408          "End par conjunction: 0x" <> TB.hexadecimal dyn_id
409        MerEndParConjunct dyn_id ->
410          "End par conjunct: 0x" <> TB.hexadecimal dyn_id
411        MerCreateSpark dyn_id spark_id ->
412          "Create spark for conjunction: 0x" <> TB.hexadecimal dyn_id
413          <> " spark: 0x" <> TB.hexadecimal spark_id
414        MerFutureCreate future_id name_id ->
415          "Create future 0x" <> TB.hexadecimal future_id
416          <> " named " <> TB.decimal name_id
417        MerFutureWaitNosuspend future_id ->
418          "Wait didn't suspend for future: 0x" <> TB.hexadecimal future_id
419        MerFutureWaitSuspended future_id ->
420          "Wait suspended on future: 0x" <> TB.hexadecimal future_id
421        MerFutureSignal future_id ->
422          "Signaled future 0x" <> TB.hexadecimal future_id
423        MerLookingForGlobalThread ->
424          "Looking for global thread to resume"
425        MerWorkStealing ->
426          "Trying to steal a spark"
427        MerLookingForLocalSpark ->
428          "Looking for a local spark to execute"
429        MerReleaseThread thread_id ->
430          "Releasing thread " <> TB.decimal thread_id <> " to the free pool"
431        MerCapSleeping ->
432          "Capability going to sleep"
433        MerCallingMain ->
434          "About to call the program entry point"
435        PerfName{perfNum, name} ->
436          "perf event " <> TB.decimal perfNum
437          <> " named \"" <> TB.fromText name <> "\""
438        PerfCounter{perfNum, tid, period} ->
439          "perf event counter " <> TB.decimal perfNum
440          <> " incremented by " <> TB.decimal (period + 1)
441          <> " in OS thread " <> TB.decimal (kernelThreadId tid)
442        PerfTracepoint{perfNum, tid} ->
443          "perf event tracepoint " <> TB.decimal perfNum
444          <> " reached in OS thread " <> TB.decimal (kernelThreadId tid)
445        HeapProfBegin {..} ->
446          "start heap profiling " <> TB.decimal heapProfId
447          <> " at sampling period " <> TB.decimal heapProfSamplingPeriod
448          <> " broken down by " <> showHeapProfBreakdown heapProfBreakdown
449          <> maybe "" (" filtered by " <>)
450            (buildFilters
451              [ heapProfModuleFilter
452              , heapProfClosureDescrFilter
453              , heapProfTypeDescrFilter
454              , heapProfCostCentreFilter
455              , heapProfCostCentreStackFilter
456              , heapProfRetainerFilter
457              , heapProfBiographyFilter
458              ])
459        HeapProfCostCentre {..} ->
460          "cost centre " <> TB.decimal heapProfCostCentreId
461          <> " " <> TB.fromText heapProfLabel
462          <> " in " <> TB.fromText heapProfModule
463          <> " at " <> TB.fromText heapProfSrcLoc
464          <> if isCaf heapProfFlags then " CAF" else ""
465        HeapProfSampleBegin {..} ->
466          "start heap prof sample " <> TB.decimal heapProfSampleEra
467        HeapProfSampleEnd {..} ->
468          "end prof sample " <> TB.decimal heapProfSampleEra
469        HeapBioProfSampleBegin {..} ->
470          "start heap prof sample " <> TB.decimal heapProfSampleEra
471            <> " at time " <> TB.decimal heapProfSampleTime
472
473
474        HeapProfSampleCostCentre {..} ->
475          "heap prof sample " <> TB.decimal heapProfId
476          <> ", residency " <> TB.decimal heapProfResidency
477          <> ", cost centre stack " <> buildCostCentreStack heapProfStack
478
479        HeapProfSampleString {..} ->
480          "heap prof sample " <> TB.decimal heapProfId
481          <> ", residency " <> TB.decimal heapProfResidency
482          <> ", label " <> TB.fromText heapProfLabel
483
484        ProfSampleCostCentre {..} ->
485          "cap no " <> TB.decimal profCapset
486          <> ", prof sample " <> TB.decimal profTicks
487          <> ", cost centre stack " <> buildCostCentreStack profCcsStack
488
489        ProfBegin {..} ->
490          "start time profiling, tick interval " <> TB.decimal profTickInterval <> " (ns)"
491
492        UserBinaryMessage {..} ->
493          "binary message " <> TB.fromText (replaceUnprintableWith '.' payload)
494
495        ConcMarkBegin    ->
496          "concurrent mark began"
497        ConcMarkEnd {..} ->
498          "concurrent mark ended: "
499          <> "marked " <> TB.decimal concMarkedObjectCount <> " objects"
500        ConcSyncBegin ->
501          "post-mark synchronization began"
502        ConcSyncEnd ->
503          "post-mark synchronization ended"
504        ConcSweepBegin ->
505          "concurrent sweep began"
506        ConcSweepEnd ->
507          "concurrent sweep ended"
508        ConcUpdRemSetFlush {..}  ->
509          "update remembered set flushed by " <> TB.decimal cap
510        NonmovingHeapCensus {..}  ->
511          "nonmoving heap census " <> TB.decimal (2^nonmovingCensusBlkSize :: Int)
512          <> ": " <> TB.decimal nonmovingCensusActiveSegs <> " active segments"
513          <> ", " <> TB.decimal nonmovingCensusFilledSegs <> " filled segments"
514          <> ", " <> TB.decimal nonmovingCensusLiveBlocks <> " live blocks"
515        TickyCounterDef {..}  ->
516          "ticky counter definition " <> TB.decimal tickyCtrDefId
517          <> ", " <>  "arity: " <> TB.decimal tickyCtrDefArity
518          <> ", " <> "def kinds: " <> TB.fromText tickyCtrDefKinds
519          <> ", " <> "name: " <> TB.fromText tickyCtrDefName
520        TickyCounterSample {..}  ->
521          "ticky counter sample " <> TB.decimal tickyCtrSampleId
522          <> ": " <> "entry count: " <> TB.decimal tickyCtrSampleEntryCount
523          <> ", " <> TB.decimal tickyCtrSampleAllocs <> " allocs"
524          <> ", " <> TB.decimal tickyCtrSampleAllocd <> " allocd"
525
526-- | Replace unprintable bytes in the message with the replacement character
527replaceUnprintableWith
528  :: Char -- ^ Replacement character
529  -> B.ByteString -- ^ Binary message which may contain unprintable bytes
530  -> T.Text
531replaceUnprintableWith replacement = TE.decodeUtf8 . B8.map replace
532  where
533    replace c
534      | isPrint c = c
535      | otherwise = replacement
536
537buildFilters :: [T.Text] -> Maybe TB.Builder
538buildFilters = foldr g Nothing
539  where
540    g f b
541      | T.null f = b
542      | otherwise = Just (TB.fromText f <> ", ") <> b
543
544buildCostCentreStack :: VU.Vector Word32 -> TB.Builder
545buildCostCentreStack = VU.ifoldl' go ""
546  where
547    go b i cc
548      | i == 0 = TB.decimal cc
549      | otherwise = b <> ", " <> TB.decimal cc
550
551showThreadStopStatus :: ThreadStopStatus -> String
552showThreadStopStatus HeapOverflow   = "heap overflow"
553showThreadStopStatus StackOverflow  = "stack overflow"
554showThreadStopStatus ThreadYielding = "thread yielding"
555showThreadStopStatus ThreadBlocked  = "thread blocked"
556showThreadStopStatus ThreadFinished = "thread finished"
557showThreadStopStatus ForeignCall    = "making a foreign call"
558showThreadStopStatus BlockedOnMVar  = "blocked on an MVar"
559showThreadStopStatus BlockedOnMVarRead = "blocked reading an MVar"
560showThreadStopStatus BlockedOnBlackHole = "blocked on a black hole"
561showThreadStopStatus BlockedOnRead = "blocked on I/O read"
562showThreadStopStatus BlockedOnWrite = "blocked on I/O write"
563showThreadStopStatus BlockedOnDelay = "blocked on threadDelay"
564showThreadStopStatus BlockedOnSTM = "blocked in STM retry"
565showThreadStopStatus BlockedOnDoProc = "blocked on asyncDoProc"
566showThreadStopStatus BlockedOnCCall = "blocked in a foreign call"
567showThreadStopStatus BlockedOnCCall_NoUnblockExc = "blocked in a foreign call"
568showThreadStopStatus BlockedOnMsgThrowTo = "blocked in throwTo"
569showThreadStopStatus ThreadMigrating = "thread migrating"
570showThreadStopStatus BlockedOnMsgGlobalise = "waiting for data to be globalised"
571showThreadStopStatus (BlockedOnBlackHoleOwnedBy target) =
572          "blocked on black hole owned by thread " ++ show target
573showThreadStopStatus NoStatus = "No stop thread status"
574
575showHeapProfBreakdown :: IsString s => HeapProfBreakdown -> s
576showHeapProfBreakdown breakdown = case breakdown of
577  HeapProfBreakdownCostCentre -> "cost centre"
578  HeapProfBreakdownModule -> "module"
579  HeapProfBreakdownClosureDescr -> "closure description"
580  HeapProfBreakdownTypeDescr -> "type description"
581  HeapProfBreakdownRetainer -> "retainer"
582  HeapProfBreakdownBiography -> "biography"
583  HeapProfBreakdownClosureType -> "closure type"
584
585ppEventLog :: EventLog -> String
586ppEventLog = TL.unpack . TB.toLazyText . buildEventLog
587
588buildEventLog :: EventLog -> TB.Builder
589buildEventLog (EventLog (Header ets) (Data es)) =
590  "Event Types:\n"
591  <> foldMap (\evType -> buildEventType evType <> "\n") ets
592  <> "\n"
593  <> "Events:\n"
594  <> foldMap (\ev -> buildEvent imap ev <> "\n") sorted
595  where
596    imap = buildEventTypeMap ets
597    sorted = sortEvents es
598
599ppEventType :: EventType -> String
600ppEventType = TL.unpack . TB.toLazyText . buildEventType
601
602buildEventType :: EventType -> TB.Builder
603buildEventType (EventType num dsc msz) =
604  TB.decimal num <> ": "
605  <> TB.fromText dsc <> " (size "
606  <> maybe "variable" TB.decimal msz <> ")"
607
608-- | Pretty prints an 'Event', with clean handling for 'UnknownEvent'
609ppEvent :: IntMap EventType -> Event -> String
610ppEvent imap = TL.unpack . TB.toLazyText . buildEvent imap
611
612buildEvent :: IntMap EventType -> Event -> TB.Builder
613buildEvent imap Event {..} =
614  TB.decimal evTime
615  <> ": "
616  <> maybe "" (\c -> "cap " <> TB.decimal c <> ": ") evCap
617  <> case evSpec of
618    UnknownEvent{ ref=ref } ->
619      maybe "" (TB.fromText . desc) $ IM.lookup (fromIntegral ref) imap
620    _ -> buildEventInfo evSpec
621
622buildEvent' :: Event -> TB.Builder
623buildEvent' Event {..} =
624   TB.decimal evTime
625   <> ": "
626   <> maybe "" (\c -> "cap " <> TB.decimal c <> ": ") evCap
627   <> case evSpec of
628     UnknownEvent{ ref=ref } ->
629      "Unknown Event (ref: " <> TB.decimal ref <> ")"
630     _ -> buildEventInfo evSpec
631