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