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