1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ViewPatterns #-}
4module GHC.RTS.Events.Binary
5  ( -- * Readers
6    getHeader
7  , getEvent
8  , standardParsers
9  , ghc6Parsers
10  , ghc7Parsers
11  , mercuryParsers
12  , perfParsers
13  , heapProfParsers
14  , timeProfParsers
15  , pre77StopParsers
16  , ghc782StopParser
17  , post782StopParser
18  , parRTSParsers
19  , binaryEventParsers
20  , tickyParsers
21
22  -- * Writers
23  , putEventLog
24  , putHeader
25  , putEvent
26
27  -- * Perf events
28  , nEVENT_PERF_NAME
29  , nEVENT_PERF_COUNTER
30  , nEVENT_PERF_TRACEPOINT
31
32  ) where
33import Control.Exception (assert)
34import Control.Monad
35import Data.List (intersperse)
36import Data.Maybe
37import Prelude hiding (gcd, rem, id)
38
39import Data.Array
40import Data.Binary
41import Data.Binary.Put
42import qualified Data.Binary.Get as G
43import qualified Data.ByteString as B
44import qualified Data.Text as T
45import qualified Data.Text.Encoding as TE
46import qualified Data.Vector.Unboxed as VU
47
48import GHC.RTS.EventTypes
49import GHC.RTS.EventParserUtils
50
51#define EVENTLOG_CONSTANTS_ONLY
52#include "EventLogFormat.h"
53
54getEventType :: Get EventType
55getEventType = do
56           etNum <- get
57           size <- get :: Get EventTypeSize
58           let etSize = if size == 0xffff then Nothing else Just size
59           -- 0xffff indicates variable-sized event
60           etDescLen <- get :: Get EventTypeDescLen
61           etDesc <- getText etDescLen
62           etExtraLen <- get :: Get Word32
63           G.skip (fromIntegral etExtraLen)
64           ete <- get :: Get Marker
65           when (ete /= EVENT_ET_END) $
66              fail "Event Type end marker not found."
67           return (EventType etNum etDesc etSize)
68
69getHeader :: Get Header
70getHeader = do
71            hdrb <- get :: Get Marker
72            when (hdrb /= EVENT_HEADER_BEGIN) $
73                 fail "Header begin marker not found"
74            hetm <- get :: Get Marker
75            when (hetm /= EVENT_HET_BEGIN) $
76                 fail "Header Event Type begin marker not found"
77            ets <- getEventTypes
78            emark <- get :: Get Marker
79            when (emark /= EVENT_HEADER_END) $
80                 fail "Header end marker not found"
81            db <- get :: Get Marker
82            when (db /= EVENT_DATA_BEGIN) $
83                  fail "My Data begin marker not found"
84            return $ Header ets
85     where
86      getEventTypes :: Get [EventType]
87      getEventTypes = do
88          m <- get :: Get Marker
89          case m of
90             EVENT_ET_BEGIN -> do
91                  et <- getEventType
92                  nextET <- getEventTypes
93                  return (et : nextET)
94             EVENT_HET_END ->
95                  return []
96             _ ->
97                  fail "Malformed list of Event Types in header"
98
99getEvent :: EventParsers -> Get (Maybe Event)
100getEvent (EventParsers parsers) = do
101  etRef <- get :: Get EventTypeNum
102  if etRef == EVENT_DATA_END
103     then return Nothing
104     else do !evTime   <- get
105             evSpec <- parsers ! fromIntegral etRef
106             return $ Just Event { evCap = undefined, .. }
107
108--
109-- standardEventParsers.
110--
111standardParsers :: [EventParser EventInfo]
112standardParsers = [
113 (FixedSizeParser EVENT_STARTUP sz_cap (do -- (n_caps)
114      c <- get :: Get CapNo
115      return Startup{ n_caps = fromIntegral c }
116   )),
117
118 (FixedSizeParser EVENT_BLOCK_MARKER (sz_block_size + sz_time + sz_cap) (do -- (size, end_time, cap)
119      block_size <- get :: Get BlockSize
120      end_time <- get :: Get Timestamp
121      c <- get :: Get CapNo
122      return EventBlock { end_time   = end_time,
123                          cap        = fromIntegral c,
124                          block_size = ((fromIntegral block_size) -
125                                        (fromIntegral sz_block_event))
126                        }
127   )),
128
129 -- EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6+
130 -- no longer generate the event; should be removed at some point
131 (simpleEvent EVENT_SHUTDOWN Shutdown),
132
133 (simpleEvent EVENT_REQUEST_SEQ_GC RequestSeqGC),
134
135 (simpleEvent EVENT_REQUEST_PAR_GC RequestParGC),
136
137 (simpleEvent EVENT_GC_START StartGC),
138
139 (simpleEvent EVENT_GC_WORK GCWork),
140
141 (simpleEvent EVENT_GC_IDLE GCIdle),
142
143 (simpleEvent EVENT_GC_DONE GCDone),
144
145 (simpleEvent EVENT_GC_END EndGC),
146
147 (simpleEvent EVENT_GC_GLOBAL_SYNC GlobalSyncGC),
148
149 (FixedSizeParser EVENT_GC_STATS_GHC (sz_capset + 2 + 5*8 + 4) (do  -- (heap_capset, generation, copied_bytes, slop_bytes, frag_bytes, par_n_threads, par_max_copied, par_tot_copied)
150      heapCapset   <- get
151      gen          <- get :: Get Word16
152      copied       <- get :: Get Word64
153      slop         <- get :: Get Word64
154      frag         <- get :: Get Word64
155      parNThreads  <- get :: Get Word32
156      parMaxCopied <- get :: Get Word64
157      parTotCopied <- get :: Get Word64
158      return GCStatsGHC{ gen = fromIntegral gen
159                       , parNThreads = fromIntegral parNThreads
160                       , parBalancedCopied = Nothing
161                       , ..}
162 )),
163
164 (FixedSizeParser EVENT_GC_STATS_GHC (sz_capset + 2 + 5*8 + 4 + 8) (do  -- (heap_capset, generation, copied_bytes, slop_bytes, frag_bytes, par_n_threads, par_max_copied, par_tot_copied, par_balanced_copied)
165      heapCapset   <- get
166      gen          <- get :: Get Word16
167      copied       <- get :: Get Word64
168      slop         <- get :: Get Word64
169      frag         <- get :: Get Word64
170      parNThreads  <- get :: Get Word32
171      parMaxCopied <- get :: Get Word64
172      parTotCopied <- get :: Get Word64
173      parBalancedCopied <- get :: Get Word64
174      return GCStatsGHC{ gen = fromIntegral gen
175                       , parNThreads = fromIntegral parNThreads
176                       , parBalancedCopied = Just parBalancedCopied
177                       , ..}
178 )),
179
180 (FixedSizeParser EVENT_HEAP_ALLOCATED (sz_capset + 8) (do  -- (heap_capset, alloc_bytes)
181      heapCapset <- get
182      allocBytes <- get
183      return HeapAllocated{..}
184 )),
185
186 (FixedSizeParser EVENT_HEAP_SIZE (sz_capset + 8) (do  -- (heap_capset, size_bytes)
187      heapCapset <- get
188      sizeBytes  <- get
189      return HeapSize{..}
190 )),
191
192 (FixedSizeParser EVENT_HEAP_LIVE (sz_capset + 8) (do  -- (heap_capset, live_bytes)
193      heapCapset <- get
194      liveBytes  <- get
195      return HeapLive{..}
196 )),
197
198 (FixedSizeParser EVENT_HEAP_INFO_GHC (sz_capset + 2 + 4*8) (do  -- (heap_capset, n_generations, max_heap_size, alloc_area_size, mblock_size, block_size)
199      heapCapset    <- get
200      gens          <- get :: Get Word16
201      maxHeapSize   <- get :: Get Word64
202      allocAreaSize <- get :: Get Word64
203      mblockSize    <- get :: Get Word64
204      blockSize     <- get :: Get Word64
205      return HeapInfoGHC{gens = fromIntegral gens, ..}
206 )),
207
208 (FixedSizeParser EVENT_CAP_CREATE (sz_cap) (do  -- (cap)
209      cap <- get :: Get CapNo
210      return CapCreate{cap = fromIntegral cap}
211 )),
212
213 (FixedSizeParser EVENT_CAP_DELETE (sz_cap) (do  -- (cap)
214      cap <- get :: Get CapNo
215      return CapDelete{cap = fromIntegral cap}
216 )),
217
218 (FixedSizeParser EVENT_CAP_DISABLE (sz_cap) (do  -- (cap)
219      cap <- get :: Get CapNo
220      return CapDisable{cap = fromIntegral cap}
221 )),
222
223 (FixedSizeParser EVENT_CAP_ENABLE (sz_cap) (do  -- (cap)
224      cap <- get :: Get CapNo
225      return CapEnable{cap = fromIntegral cap}
226 )),
227
228 (FixedSizeParser EVENT_CAPSET_CREATE (sz_capset + sz_capset_type) (do -- (capset, capset_type)
229      cs <- get
230      ct <- fmap mkCapsetType get
231      return CapsetCreate{capset=cs,capsetType=ct}
232   )),
233
234 (FixedSizeParser EVENT_CAPSET_DELETE sz_capset (do -- (capset)
235      cs <- get
236      return CapsetDelete{capset=cs}
237   )),
238
239 (FixedSizeParser EVENT_CAPSET_ASSIGN_CAP (sz_capset + sz_cap) (do -- (capset, cap)
240      cs <- get
241      cp <- get :: Get CapNo
242      return CapsetAssignCap{capset=cs,cap=fromIntegral cp}
243   )),
244
245 (FixedSizeParser EVENT_CAPSET_REMOVE_CAP (sz_capset + sz_cap) (do -- (capset, cap)
246      cs <- get
247      cp <- get :: Get CapNo
248      return CapsetRemoveCap{capset=cs,cap=fromIntegral cp}
249   )),
250
251 (FixedSizeParser EVENT_OSPROCESS_PID (sz_capset + sz_pid) (do -- (capset, pid)
252      cs <- get
253      pd <- get
254      return OsProcessPid{capset=cs,pid=pd}
255   )),
256
257 (FixedSizeParser EVENT_OSPROCESS_PPID (sz_capset + sz_pid) (do -- (capset, ppid)
258      cs <- get
259      pd <- get
260      return OsProcessParentPid{capset=cs,ppid=pd}
261  )),
262
263 (FixedSizeParser EVENT_WALL_CLOCK_TIME (sz_capset + 8 + 4) (do -- (capset, unix_epoch_seconds, nanoseconds)
264      cs <- get
265      s  <- get
266      ns <- get
267      return WallClockTime{capset=cs,sec=s,nsec=ns}
268  )),
269
270 (VariableSizeParser EVENT_LOG_MSG (do -- (msg)
271      num <- get :: Get Word16
272      string <- getText num
273      return Message{ msg = string }
274   )),
275 (VariableSizeParser EVENT_USER_MSG (do -- (msg)
276      num <- get :: Get Word16
277      string <- getText num
278      return UserMessage{ msg = string }
279   )),
280    (VariableSizeParser EVENT_USER_MARKER (do -- (markername)
281      num <- get :: Get Word16
282      string <- getText num
283      return UserMarker{ markername = string }
284   )),
285 (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg])
286      num <- get :: Get Word16
287      cs <- get
288      string <- getText (num - sz_capset)
289      return ProgramArgs
290        { capset = cs
291        , args = T.splitOn "\0" $ T.dropWhileEnd (== '\0') string }
292   )),
293 (VariableSizeParser EVENT_PROGRAM_ENV (do -- (capset, [arg])
294      num <- get :: Get Word16
295      cs <- get
296      string <- getText (num - sz_capset)
297      return ProgramEnv
298        { capset = cs
299        , env = T.splitOn "\0" $ T.dropWhileEnd (== '\0') string }
300   )),
301 (VariableSizeParser EVENT_RTS_IDENTIFIER (do -- (capset, str)
302      num <- get :: Get Word16
303      cs <- get
304      string <- getText (num - sz_capset)
305      return RtsIdentifier{ capset = cs
306                          , rtsident = string }
307   )),
308
309 (VariableSizeParser EVENT_INTERN_STRING (do -- (str, id)
310      num <- get :: Get Word16
311      string <- getString (num - sz_string_id)
312      sId <- get :: Get StringId
313      return (InternString string sId)
314    )),
315
316 (VariableSizeParser EVENT_THREAD_LABEL (do -- (thread, str)
317      num <- get :: Get Word16
318      tid <- get
319      str <- getText (num - sz_tid)
320      return ThreadLabel{ thread      = tid
321                        , threadlabel = str }
322    )),
323
324 (simpleEvent EVENT_CONC_MARK_BEGIN ConcMarkBegin),
325 (FixedSizeParser EVENT_CONC_MARK_END 4 (do -- (marked_object_count)
326      num <- get :: Get Word32
327      return ConcMarkEnd{ concMarkedObjectCount = num }
328    )),
329 (simpleEvent EVENT_CONC_SYNC_BEGIN ConcSyncBegin),
330 (simpleEvent EVENT_CONC_SYNC_END ConcSyncEnd),
331 (simpleEvent EVENT_CONC_SWEEP_BEGIN ConcSweepBegin),
332 (simpleEvent EVENT_CONC_SWEEP_END ConcSweepEnd),
333 (FixedSizeParser EVENT_CONC_UPD_REM_SET_FLUSH sz_cap (do -- (cap)
334      cap <- get :: Get CapNo
335      return ConcUpdRemSetFlush{ cap = fromIntegral cap }
336    )),
337 (FixedSizeParser EVENT_NONMOVING_HEAP_CENSUS 13 (do -- (blk_size, active_segs, filled_segs, live_blks)
338      nonmovingCensusBlkSize <- get :: Get Word8
339      nonmovingCensusActiveSegs <- get :: Get Word32
340      nonmovingCensusFilledSegs <- get :: Get Word32
341      nonmovingCensusLiveBlocks <- get :: Get Word32
342      return NonmovingHeapCensus{..}
343    ))
344 ]
345
346-- Parsers valid for GHC7 but not GHC6.
347ghc7Parsers :: [EventParser EventInfo]
348ghc7Parsers = [
349 (FixedSizeParser EVENT_CREATE_THREAD sz_tid (do  -- (thread)
350      t <- get
351      return CreateThread{thread=t}
352   )),
353
354 (FixedSizeParser EVENT_RUN_THREAD sz_tid (do  --  (thread)
355      t <- get
356      return RunThread{thread=t}
357   )),
358
359 (FixedSizeParser EVENT_THREAD_RUNNABLE sz_tid (do  -- (thread)
360      t <- get
361      return ThreadRunnable{thread=t}
362   )),
363
364 (FixedSizeParser EVENT_MIGRATE_THREAD (sz_tid + sz_cap) (do  --  (thread, newCap)
365      t  <- get
366      nc <- get :: Get CapNo
367      return MigrateThread{thread=t,newCap=fromIntegral nc}
368   )),
369
370 -- Yes, EVENT_RUN/STEAL_SPARK are deprecated, but see the explanation in the
371 -- 'ghc6Parsers' section below. Since we're parsing them anyway, we might
372 -- as well convert them to the new SparkRun/SparkSteal events.
373 (FixedSizeParser EVENT_RUN_SPARK sz_tid (do  -- (thread)
374      _ <- get :: Get ThreadId
375      return SparkRun
376   )),
377
378 (FixedSizeParser EVENT_STEAL_SPARK (sz_tid + sz_cap) (do  -- (thread, victimCap)
379      _  <- get :: Get ThreadId
380      vc <- get :: Get CapNo
381      return SparkSteal{victimCap=fromIntegral vc}
382   )),
383
384 (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_tid (do  -- (sparkThread)
385      st <- get :: Get ThreadId
386      return CreateSparkThread{sparkThread=st}
387   )),
388
389 (FixedSizeParser EVENT_SPARK_COUNTERS (7*8) (do -- (crt,dud,ovf,cnv,gcd,fiz,rem)
390      crt <- get :: Get Word64
391      dud <- get :: Get Word64
392      ovf <- get :: Get Word64
393      cnv <- get :: Get Word64
394      gcd <- get :: Get Word64
395      fiz <- get :: Get Word64
396      rem <- get :: Get Word64
397      return SparkCounters{sparksCreated    = crt, sparksDud       = dud,
398                           sparksOverflowed = ovf, sparksConverted = cnv,
399                           -- Warning: order of fiz and gcd reversed!
400                           sparksFizzled    = fiz, sparksGCd       = gcd,
401                           sparksRemaining  = rem}
402   )),
403
404 (simpleEvent EVENT_SPARK_CREATE   SparkCreate),
405 (simpleEvent EVENT_SPARK_DUD      SparkDud),
406 (simpleEvent EVENT_SPARK_OVERFLOW SparkOverflow),
407 (simpleEvent EVENT_SPARK_RUN      SparkRun),
408 (FixedSizeParser EVENT_SPARK_STEAL sz_cap (do  -- (victimCap)
409      vc <- get :: Get CapNo
410      return SparkSteal{victimCap=fromIntegral vc}
411   )),
412 (simpleEvent EVENT_SPARK_FIZZLE   SparkFizzle),
413 (simpleEvent EVENT_SPARK_GC       SparkGC),
414
415 (FixedSizeParser EVENT_TASK_CREATE (sz_taskid + sz_cap + sz_kernel_tid) (do  -- (taskID, cap, tid)
416      taskId <- get :: Get TaskId
417      cap    <- get :: Get CapNo
418      tid    <- get :: Get KernelThreadId
419      return TaskCreate{ taskId, cap = fromIntegral cap, tid }
420   )),
421 (FixedSizeParser EVENT_TASK_MIGRATE (sz_taskid + sz_cap*2) (do  -- (taskID, cap, new_cap)
422      taskId  <- get :: Get TaskId
423      cap     <- get :: Get CapNo
424      new_cap <- get :: Get CapNo
425      return TaskMigrate{ taskId, cap = fromIntegral cap
426                                , new_cap = fromIntegral new_cap
427                        }
428   )),
429 (FixedSizeParser EVENT_TASK_DELETE (sz_taskid) (do  -- (taskID)
430      taskId <- get :: Get TaskId
431      return TaskDelete{ taskId }
432   )),
433
434 (FixedSizeParser EVENT_THREAD_WAKEUP (sz_tid + sz_cap) (do  -- (thread, other_cap)
435      t <- get
436      oc <- get :: Get CapNo
437      return WakeupThread{thread=t,otherCap=fromIntegral oc}
438   ))
439 ]
440
441-- special thread stop event parsers for GHC version 7.8.2
442-- see [Stop status in GHC-7.8.2] in EventTypes.hs
443ghc782StopParser :: EventParser EventInfo
444ghc782StopParser =
445 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do
446      -- (thread, status, info)
447      t <- get
448      s <- get :: Get RawThreadStopStatus
449      i <- get :: Get ThreadId
450      return StopThread{thread = t,
451                        status = case () of
452                                  _ | s > maxThreadStopStatus782
453                                    -> NoStatus
454                                    | s == 9 {- XXX yeuch -}
455                                      -- GHC-7.8.2: 9 == BlockedOnBlackHole
456                                    -> BlockedOnBlackHoleOwnedBy i
457                                    | otherwise
458                                    -> mkStopStatus782 s}
459   ))
460
461-- parsers for GHC < 7.8.2. Older versions do not use block info
462-- (different length).  See [Stop status in GHC-7.8.2] in
463-- EventTypes.hs
464pre77StopParsers :: [EventParser EventInfo]
465pre77StopParsers = [
466 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status) (do
467      -- (thread, status)
468      t <- get
469      s <- get :: Get RawThreadStopStatus
470      return StopThread{thread=t, status = if s > maxThreadStopStatusPre77
471                                              then NoStatus
472                                              else mkStopStatus s}
473                        -- older version of the event, no block info
474   )),
475
476 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid)
477    (do
478      -- (thread, status, info)
479      t <- get
480      s <- get :: Get RawThreadStopStatus
481      i <- get :: Get ThreadId
482      return StopThread{thread = t,
483                        status = case () of
484                                  _ | s > maxThreadStopStatusPre77
485                                    -> NoStatus
486                                    | s == 8 {- XXX yeuch -}
487                                      -- pre-7.7: 8==BlockedOnBlackhole
488                                    -> BlockedOnBlackHoleOwnedBy i
489                                    | otherwise
490                                    -> mkStopStatus s}
491    ))
492  ]
493
494-- parsers for GHC >= 7.8.3, always using block info field parser.
495-- See [Stop status in GHC-7.8.2] in EventTypes.hs
496post782StopParser :: EventParser EventInfo
497post782StopParser =
498 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid)
499    (do
500      -- (thread, status, info)
501      t <- get
502      s <- get :: Get RawThreadStopStatus
503      i <- get :: Get ThreadId
504      return StopThread{thread = t,
505                        status = case () of
506                                  _ | s > maxThreadStopStatus
507                                    -> NoStatus
508                                    | s == 8 {- XXX yeuch -}
509                                      -- post-7.8.2: 8==BlockedOnBlackhole
510                                    -> BlockedOnBlackHoleOwnedBy i
511                                    | otherwise
512                                    -> mkStopStatus s}
513    ))
514
515 -----------------------
516 -- GHC 6.12 compat: GHC 6.12 reported the wrong sizes for some events,
517 -- so we have to recognise those wrong sizes here for backwards
518 -- compatibility.
519ghc6Parsers :: [EventParser EventInfo]
520ghc6Parsers = [
521 (FixedSizeParser EVENT_STARTUP 0 (do
522      -- BUG in GHC 6.12: the startup event was incorrectly
523      -- declared as size 0, so we accept it here.
524      c <- get :: Get CapNo
525      return Startup{ n_caps = fromIntegral c }
526   )),
527
528 (FixedSizeParser EVENT_CREATE_THREAD sz_old_tid (do  -- (thread)
529      t <- get
530      return CreateThread{thread=t}
531   )),
532
533 (FixedSizeParser EVENT_RUN_THREAD sz_old_tid (do  --  (thread)
534      t <- get
535      return RunThread{thread=t}
536   )),
537
538 (FixedSizeParser EVENT_STOP_THREAD (sz_old_tid + 2) (do  -- (thread, status)
539      t <- get
540      s <- get :: Get RawThreadStopStatus
541      return StopThread{thread=t, status = if s > maxThreadStopStatusPre77
542                                              then NoStatus
543                                              else mkStopStatus s}
544                        -- older version of the event uses pre-77 encoding
545                        -- (actually, it only uses encodings 0 to 5)
546                        -- see [Stop status in GHC-7.8.2] in EventTypes.hs
547   )),
548
549 (FixedSizeParser EVENT_THREAD_RUNNABLE sz_old_tid (do  -- (thread)
550      t <- get
551      return ThreadRunnable{thread=t}
552   )),
553
554 (FixedSizeParser EVENT_MIGRATE_THREAD (sz_old_tid + sz_cap) (do  --  (thread, newCap)
555      t  <- get
556      nc <- get :: Get CapNo
557      return MigrateThread{thread=t,newCap=fromIntegral nc}
558   )),
559
560 -- Note: it is vital that these two (EVENT_RUN/STEAL_SPARK) remain here (at
561 -- least in the ghc6Parsers section) even though both events are deprecated.
562 -- The reason is that .eventlog files created by the buggy GHC-6.12
563 -- mis-declare the size of these two events. So we have to handle them
564 -- specially here otherwise we'll get the wrong size, leading to us getting
565 -- out of sync and eventual parse failure. Since we're parsing them anyway,
566 -- we might as well convert them to the new SparkRun/SparkSteal events.
567 (FixedSizeParser EVENT_RUN_SPARK sz_old_tid (do  -- (thread)
568      _ <- get :: Get ThreadId
569      return SparkRun
570   )),
571
572 (FixedSizeParser EVENT_STEAL_SPARK (sz_old_tid + sz_cap) (do  -- (thread, victimCap)
573      _  <- get :: Get ThreadId
574      vc <- get :: Get CapNo
575      return SparkSteal{victimCap=fromIntegral vc}
576   )),
577
578 (FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_old_tid (do  -- (sparkThread)
579      st <- get :: Get ThreadId
580      return CreateSparkThread{sparkThread=st}
581   )),
582
583 (FixedSizeParser EVENT_THREAD_WAKEUP (sz_old_tid + sz_cap) (do  -- (thread, other_cap)
584      t <- get
585      oc <- get :: Get CapNo
586      return WakeupThread{thread=t,otherCap=fromIntegral oc}
587   ))
588 ]
589
590-- Parsers for parallel events. Parameter is the thread_id size, to create
591-- ghc6-parsers (using the wrong size) where necessary.
592parRTSParsers :: EventTypeSize -> [EventParser EventInfo]
593parRTSParsers sz_tid' = [
594 (VariableSizeParser EVENT_VERSION (do -- (version)
595      num <- get :: Get Word16
596      string <- getString num
597      return Version{ version = string }
598   )),
599
600 (VariableSizeParser EVENT_PROGRAM_INVOCATION (do -- (cmd. line)
601      num <- get :: Get Word16
602      string <- getString num
603      return ProgramInvocation{ commandline = string }
604   )),
605
606 (simpleEvent EVENT_EDEN_START_RECEIVE EdenStartReceive),
607 (simpleEvent EVENT_EDEN_END_RECEIVE   EdenEndReceive),
608
609 (FixedSizeParser EVENT_CREATE_PROCESS sz_procid
610    (do p <- get
611        return CreateProcess{ process = p })
612 ),
613
614 (FixedSizeParser EVENT_KILL_PROCESS sz_procid
615    (do p <- get
616        return KillProcess{ process = p })
617 ),
618
619 (FixedSizeParser EVENT_ASSIGN_THREAD_TO_PROCESS (sz_tid' + sz_procid)
620    (do t <- get
621        p <- get
622        return AssignThreadToProcess { thread = t, process = p })
623 ),
624
625 (FixedSizeParser EVENT_CREATE_MACHINE (sz_mid + sz_realtime)
626    (do m <- get
627        t <- get
628        return CreateMachine { machine = m, realtime = t })
629 ),
630
631 (FixedSizeParser EVENT_KILL_MACHINE sz_mid
632    (do m <- get :: Get MachineId
633        return KillMachine { machine = m })
634 ),
635
636 (FixedSizeParser EVENT_SEND_MESSAGE
637    (sz_msgtag + 2*sz_procid + 2*sz_tid' + sz_mid)
638    (do tag <- get :: Get RawMsgTag
639        sP  <- get :: Get ProcessId
640        sT  <- get :: Get ThreadId
641        rM  <- get :: Get MachineId
642        rP  <- get :: Get ProcessId
643        rIP <- get :: Get PortId
644        return SendMessage { mesTag = toMsgTag tag,
645                             senderProcess = sP,
646                             senderThread = sT,
647                             receiverMachine = rM,
648                             receiverProcess = rP,
649                             receiverInport = rIP
650                           })
651 ),
652
653 (FixedSizeParser EVENT_RECEIVE_MESSAGE
654    (sz_msgtag + 2*sz_procid + 2*sz_tid' + sz_mid + sz_mes)
655    (do tag <- get :: Get Word8
656        rP  <- get :: Get ProcessId
657        rIP <- get :: Get PortId
658        sM  <- get :: Get MachineId
659        sP  <- get :: Get ProcessId
660        sT  <- get :: Get ThreadId
661        mS  <- get :: Get MessageSize
662        return  ReceiveMessage { mesTag = toMsgTag tag,
663                                 receiverProcess = rP,
664                                 receiverInport = rIP,
665                                 senderMachine = sM,
666                                 senderProcess = sP,
667                                 senderThread= sT,
668                                 messageSize = mS
669                               })
670 ),
671
672 (FixedSizeParser EVENT_SEND_RECEIVE_LOCAL_MESSAGE
673    (sz_msgtag + 2*sz_procid + 2*sz_tid')
674    (do tag <- get :: Get Word8
675        sP  <- get :: Get ProcessId
676        sT  <- get :: Get ThreadId
677        rP  <- get :: Get ProcessId
678        rIP <- get :: Get PortId
679        return SendReceiveLocalMessage { mesTag = toMsgTag tag,
680                                         senderProcess = sP,
681                                         senderThread = sT,
682                                         receiverProcess = rP,
683                                         receiverInport = rIP
684                                       })
685 )]
686
687mercuryParsers :: [EventParser EventInfo]
688mercuryParsers = [
689 (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION
690    (sz_par_conj_dyn_id + sz_par_conj_static_id)
691    (do dyn_id <- get
692        static_id <- get
693        return (MerStartParConjunction dyn_id static_id))
694 ),
695
696 (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCTION sz_par_conj_dyn_id
697    (do dyn_id <- get
698        return (MerEndParConjunction dyn_id))
699 ),
700
701 (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCT sz_par_conj_dyn_id
702    (do dyn_id <- get
703        return (MerEndParConjunct dyn_id))
704 ),
705
706 (FixedSizeParser EVENT_MER_CREATE_SPARK (sz_par_conj_dyn_id + sz_spark_id)
707    (do dyn_id <- get
708        spark_id <- get
709        return (MerCreateSpark dyn_id spark_id))
710 ),
711
712 (FixedSizeParser EVENT_MER_FUT_CREATE (sz_future_id + sz_string_id)
713    (do future_id <- get
714        name_id <- get
715        return (MerFutureCreate future_id name_id))
716 ),
717
718 (FixedSizeParser EVENT_MER_FUT_WAIT_NOSUSPEND (sz_future_id)
719    (do future_id <- get
720        return (MerFutureWaitNosuspend future_id))
721 ),
722
723 (FixedSizeParser EVENT_MER_FUT_WAIT_SUSPENDED (sz_future_id)
724    (do future_id <- get
725        return (MerFutureWaitSuspended future_id))
726 ),
727
728 (FixedSizeParser EVENT_MER_FUT_SIGNAL (sz_future_id)
729    (do future_id <- get
730        return (MerFutureSignal future_id))
731 ),
732
733 (simpleEvent EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT MerLookingForGlobalThread),
734 (simpleEvent EVENT_MER_WORK_STEALING MerWorkStealing),
735 (simpleEvent EVENT_MER_LOOKING_FOR_LOCAL_SPARK MerLookingForLocalSpark),
736
737 (FixedSizeParser EVENT_MER_RELEASE_CONTEXT sz_tid
738    (do thread_id <- get
739        return (MerReleaseThread thread_id))
740 ),
741
742 (simpleEvent EVENT_MER_ENGINE_SLEEPING MerCapSleeping),
743 (simpleEvent EVENT_MER_CALLING_MAIN MerCallingMain)
744
745 ]
746
747perfParsers :: [EventParser EventInfo]
748perfParsers = [
749 (VariableSizeParser EVENT_PERF_NAME (do -- (perf_num, name)
750      num     <- get :: Get Word16
751      perfNum <- get
752      name    <- getText (num - sz_perf_num)
753      return PerfName{perfNum, name}
754   )),
755
756 (FixedSizeParser EVENT_PERF_COUNTER (sz_perf_num + sz_kernel_tid + 8) (do -- (perf_num, tid, period)
757      perfNum <- get
758      tid     <- get
759      period  <- get
760      return PerfCounter{perfNum, tid, period}
761  )),
762
763 (FixedSizeParser EVENT_PERF_TRACEPOINT (sz_perf_num + sz_kernel_tid) (do -- (perf_num, tid)
764      perfNum <- get
765      tid     <- get
766      return PerfTracepoint{perfNum, tid}
767  ))
768 ]
769
770heapProfParsers :: [EventParser EventInfo]
771heapProfParsers =
772  [ VariableSizeParser EVENT_HEAP_PROF_BEGIN $ do
773    payloadLen <- get :: Get Word16
774    heapProfId <- get
775    heapProfSamplingPeriod <- get
776    heapProfBreakdown <- get
777    heapProfModuleFilter <- getTextNul
778    heapProfClosureDescrFilter <- getTextNul
779    heapProfTypeDescrFilter <- getTextNul
780    heapProfCostCentreFilter <- getTextNul
781    heapProfCostCentreStackFilter <- getTextNul
782    heapProfRetainerFilter <- getTextNul
783    heapProfBiographyFilter <- getTextNul
784    assert
785      (fromIntegral payloadLen == sum
786        [ 1 -- heapProfId
787        , 8 -- heapProfSamplingPeriod
788        , 4 -- heapProfBreakdown
789        , textByteLen heapProfModuleFilter
790        , textByteLen heapProfClosureDescrFilter
791        , textByteLen heapProfTypeDescrFilter
792        , textByteLen heapProfCostCentreFilter
793        , textByteLen heapProfCostCentreStackFilter
794        , textByteLen heapProfRetainerFilter
795        , textByteLen heapProfBiographyFilter
796        ])
797      (return ())
798    return $! HeapProfBegin {..}
799  , VariableSizeParser EVENT_HEAP_PROF_COST_CENTRE $ do
800    payloadLen <- get :: Get Word16
801    heapProfCostCentreId <- get
802    heapProfLabel <- getTextNul
803    heapProfModule <- getTextNul
804    heapProfSrcLoc <- getTextNul
805    heapProfFlags <- get
806    assert
807      (fromIntegral payloadLen == sum
808        [ 4 -- heapProfCostCentreId
809        , textByteLen heapProfLabel
810        , textByteLen heapProfModule
811        , textByteLen heapProfSrcLoc
812        , 1 -- heapProfFlags
813        ])
814      (return ())
815    return $! HeapProfCostCentre {..}
816  , FixedSizeParser EVENT_HEAP_PROF_SAMPLE_BEGIN 8 $ do
817    heapProfSampleEra <- get
818    return $! HeapProfSampleBegin {..}
819  , FixedSizeParser EVENT_HEAP_PROF_SAMPLE_END 8 $ do
820    heapProfSampleEra <- get
821    return $! HeapProfSampleEnd {..}
822  , FixedSizeParser EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN 16 $ do
823    heapProfSampleEra <- get
824    heapProfSampleTime <- get
825    return $! HeapBioProfSampleBegin {..}
826  , VariableSizeParser EVENT_HEAP_PROF_SAMPLE_COST_CENTRE $ do
827    payloadLen <- get :: Get Word16
828    heapProfId <- get
829    heapProfResidency <- get
830    heapProfStackDepth <- get
831    heapProfStack <- VU.replicateM (fromIntegral heapProfStackDepth) get
832    assert
833      ((fromIntegral payloadLen :: Int) == sum
834        [ 1 -- heapProfId
835        , 8 -- heapProfResidency
836        , 1 -- heapProfStackDepth
837        , fromIntegral heapProfStackDepth * 4
838        ])
839      (return ())
840    return $! HeapProfSampleCostCentre {..}
841  , VariableSizeParser EVENT_HEAP_PROF_SAMPLE_STRING $ do
842    payloadLen <- get :: Get Word16
843    heapProfId <- get
844    heapProfResidency <- get
845    heapProfLabel <- getTextNul
846    assert
847      (fromIntegral payloadLen == sum
848        [ 1 -- heapProfId
849        , 8 -- heapProfResidency
850        , textByteLen heapProfLabel
851        ])
852      (return ())
853    return $! HeapProfSampleString {..}
854  ]
855
856timeProfParsers :: [EventParser EventInfo]
857timeProfParsers = [
858  FixedSizeParser EVENT_PROF_BEGIN 8 $ do
859    profTickInterval <- get
860    return $! ProfBegin{..}
861  , VariableSizeParser EVENT_PROF_SAMPLE_COST_CENTRE $ do
862    payloadLen <- get :: Get Word16
863    profCapset <- get
864    profTicks <- get
865    profStackDepth <- get
866    profCcsStack <- VU.replicateM (fromIntegral profStackDepth) get
867    assert
868      ((fromIntegral payloadLen :: Int) == sum
869        [ 4
870        , 8 -- ticks
871        , 1 -- stack depth
872        , fromIntegral profStackDepth * 4
873        ])
874      (return ())
875    return $! ProfSampleCostCentre {..} ]
876
877binaryEventParsers :: [EventParser EventInfo]
878binaryEventParsers =
879  [ VariableSizeParser EVENT_USER_BINARY_MSG $ do
880    payloadLen <- get :: Get Word16
881    payload <- G.getByteString $ fromIntegral payloadLen
882    return $! UserBinaryMessage { payload }
883  ]
884
885tickyParsers :: [EventParser EventInfo]
886tickyParsers =
887  [ VariableSizeParser EVENT_TICKY_COUNTER_DEF $ do
888    payloadLen         <- get :: Get Word16
889    tickyCtrDefId      <- get
890    tickyCtrDefArity   <- get
891    tickyCtrDefKinds   <- getTextNul
892    tickyCtrDefName    <- getTextNul
893    assert
894      (fromIntegral payloadLen == sum
895        [ 8 -- tickyCtrDefId
896        , 2 -- tickyCtrDefArity
897        , textByteLen tickyCtrDefKinds
898        , textByteLen tickyCtrDefName
899        ])
900      (return ())
901    return $! TickyCounterDef{..}
902  , FixedSizeParser EVENT_TICKY_COUNTER_SAMPLE (8*4) $ do
903    tickyCtrSampleId         <- get
904    tickyCtrSampleEntryCount <- get
905    tickyCtrSampleAllocs     <- get
906    tickyCtrSampleAllocd     <- get
907    return $! TickyCounterSample{..}
908  ]
909
910-- | String byte length in the eventlog format. It includes
911-- 1 byte for NUL.
912textByteLen :: T.Text -> Int
913textByteLen = (+1) . B.length . TE.encodeUtf8
914
915-----------------------------------------------------------
916
917putE :: Binary a => a -> PutM ()
918putE = put
919
920putType :: EventTypeNum -> PutM ()
921putType = putE
922
923putCap :: Int -> PutM ()
924putCap c = putE (fromIntegral c :: CapNo)
925
926putMarker :: Word32 -> PutM ()
927putMarker = putE
928
929putEventLog :: EventLog -> PutM ()
930putEventLog (EventLog hdr es) = do
931    putHeader hdr
932    putData es
933
934putHeader :: Header -> PutM ()
935putHeader (Header ets) = do
936    putMarker EVENT_HEADER_BEGIN
937    putMarker EVENT_HET_BEGIN
938    mapM_ putEventType ets
939    putMarker EVENT_HET_END
940    putMarker EVENT_HEADER_END
941 where
942    putEventType (EventType n (TE.encodeUtf8 -> d) msz) = do
943        putMarker EVENT_ET_BEGIN
944        putType n
945        putE $ fromMaybe 0xffff msz
946        putE (fromIntegral $ B.length d :: EventTypeDescLen)
947        putByteString d
948        -- the event type header allows for extra data, which we don't use:
949        putE (0 :: Word32)
950        putMarker EVENT_ET_END
951
952putData :: Data -> PutM ()
953putData (Data es) = do
954    putMarker EVENT_DATA_BEGIN -- Word32
955    mapM_ putEvent es
956    putType EVENT_DATA_END -- Word16
957
958eventTypeNum :: EventInfo -> EventTypeNum
959eventTypeNum e = case e of
960    CreateThread {} -> EVENT_CREATE_THREAD
961    RunThread {} -> EVENT_RUN_THREAD
962    StopThread {} -> EVENT_STOP_THREAD
963    ThreadRunnable {} -> EVENT_THREAD_RUNNABLE
964    MigrateThread {} -> EVENT_MIGRATE_THREAD
965    Shutdown {} -> EVENT_SHUTDOWN
966    WakeupThread {} -> EVENT_THREAD_WAKEUP
967    ThreadLabel {}  -> EVENT_THREAD_LABEL
968    StartGC {} -> EVENT_GC_START
969    EndGC {} -> EVENT_GC_END
970    GlobalSyncGC {} -> EVENT_GC_GLOBAL_SYNC
971    RequestSeqGC {} -> EVENT_REQUEST_SEQ_GC
972    RequestParGC {} -> EVENT_REQUEST_PAR_GC
973    CreateSparkThread {} -> EVENT_CREATE_SPARK_THREAD
974    SparkCounters {} -> EVENT_SPARK_COUNTERS
975    SparkCreate   {} -> EVENT_SPARK_CREATE
976    SparkDud      {} -> EVENT_SPARK_DUD
977    SparkOverflow {} -> EVENT_SPARK_OVERFLOW
978    SparkRun      {} -> EVENT_SPARK_RUN
979    SparkSteal    {} -> EVENT_SPARK_STEAL
980    SparkFizzle   {} -> EVENT_SPARK_FIZZLE
981    SparkGC       {} -> EVENT_SPARK_GC
982    TaskCreate  {} -> EVENT_TASK_CREATE
983    TaskMigrate {} -> EVENT_TASK_MIGRATE
984    TaskDelete  {} -> EVENT_TASK_DELETE
985    Message {} -> EVENT_LOG_MSG
986    Startup {} -> EVENT_STARTUP
987    EventBlock {} -> EVENT_BLOCK_MARKER
988    UserMessage {} -> EVENT_USER_MSG
989    UserMarker  {} -> EVENT_USER_MARKER
990    GCIdle {} -> EVENT_GC_IDLE
991    GCWork {} -> EVENT_GC_WORK
992    GCDone {} -> EVENT_GC_DONE
993    GCStatsGHC{} -> EVENT_GC_STATS_GHC
994    HeapAllocated{} -> EVENT_HEAP_ALLOCATED
995    HeapSize{} -> EVENT_HEAP_SIZE
996    HeapLive{} -> EVENT_HEAP_LIVE
997    HeapInfoGHC{} -> EVENT_HEAP_INFO_GHC
998    CapCreate{} -> EVENT_CAP_CREATE
999    CapDelete{} -> EVENT_CAP_DELETE
1000    CapDisable{} -> EVENT_CAP_DISABLE
1001    CapEnable{} -> EVENT_CAP_ENABLE
1002    CapsetCreate {} -> EVENT_CAPSET_CREATE
1003    CapsetDelete {} -> EVENT_CAPSET_DELETE
1004    CapsetAssignCap {} -> EVENT_CAPSET_ASSIGN_CAP
1005    CapsetRemoveCap {} -> EVENT_CAPSET_REMOVE_CAP
1006    RtsIdentifier {} -> EVENT_RTS_IDENTIFIER
1007    ProgramArgs {} -> EVENT_PROGRAM_ARGS
1008    ProgramEnv {} -> EVENT_PROGRAM_ENV
1009    OsProcessPid {} -> EVENT_OSPROCESS_PID
1010    OsProcessParentPid{} -> EVENT_OSPROCESS_PPID
1011    WallClockTime{} -> EVENT_WALL_CLOCK_TIME
1012    UnknownEvent {} -> error "eventTypeNum UnknownEvent"
1013    InternString {} -> EVENT_INTERN_STRING
1014    Version {} -> EVENT_VERSION
1015    ProgramInvocation {} -> EVENT_PROGRAM_INVOCATION
1016    EdenStartReceive {} -> EVENT_EDEN_START_RECEIVE
1017    EdenEndReceive {} -> EVENT_EDEN_END_RECEIVE
1018    CreateProcess {} -> EVENT_CREATE_PROCESS
1019    KillProcess {} -> EVENT_KILL_PROCESS
1020    AssignThreadToProcess {} -> EVENT_ASSIGN_THREAD_TO_PROCESS
1021    CreateMachine {} -> EVENT_CREATE_MACHINE
1022    KillMachine {} -> EVENT_KILL_MACHINE
1023    SendMessage {} -> EVENT_SEND_MESSAGE
1024    ReceiveMessage {} -> EVENT_RECEIVE_MESSAGE
1025    SendReceiveLocalMessage {} -> EVENT_SEND_RECEIVE_LOCAL_MESSAGE
1026    MerStartParConjunction {} -> EVENT_MER_START_PAR_CONJUNCTION
1027    MerEndParConjunction _ -> EVENT_MER_STOP_PAR_CONJUNCTION
1028    MerEndParConjunct _ -> EVENT_MER_STOP_PAR_CONJUNCT
1029    MerCreateSpark {} -> EVENT_MER_CREATE_SPARK
1030    MerFutureCreate {} -> EVENT_MER_FUT_CREATE
1031    MerFutureWaitNosuspend _ -> EVENT_MER_FUT_WAIT_NOSUSPEND
1032    MerFutureWaitSuspended _ -> EVENT_MER_FUT_WAIT_SUSPENDED
1033    MerFutureSignal _ -> EVENT_MER_FUT_SIGNAL
1034    MerLookingForGlobalThread -> EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT
1035    MerWorkStealing -> EVENT_MER_WORK_STEALING
1036    MerLookingForLocalSpark -> EVENT_MER_LOOKING_FOR_LOCAL_SPARK
1037    MerReleaseThread _ -> EVENT_MER_RELEASE_CONTEXT
1038    MerCapSleeping -> EVENT_MER_ENGINE_SLEEPING
1039    MerCallingMain -> EVENT_MER_CALLING_MAIN
1040    PerfName       {} -> nEVENT_PERF_NAME
1041    PerfCounter    {} -> nEVENT_PERF_COUNTER
1042    PerfTracepoint {} -> nEVENT_PERF_TRACEPOINT
1043    HeapProfBegin {} -> EVENT_HEAP_PROF_BEGIN
1044    HeapProfCostCentre {} -> EVENT_HEAP_PROF_COST_CENTRE
1045    HeapProfSampleBegin {} -> EVENT_HEAP_PROF_SAMPLE_BEGIN
1046    HeapProfSampleEnd {} -> EVENT_HEAP_PROF_SAMPLE_END
1047    HeapBioProfSampleBegin {} -> EVENT_HEAP_BIO_PROF_SAMPLE_BEGIN
1048    HeapProfSampleCostCentre {} -> EVENT_HEAP_PROF_SAMPLE_COST_CENTRE
1049    HeapProfSampleString {} -> EVENT_HEAP_PROF_SAMPLE_STRING
1050    ProfSampleCostCentre {} -> EVENT_PROF_SAMPLE_COST_CENTRE
1051    ProfBegin {}            -> EVENT_PROF_BEGIN
1052    UserBinaryMessage {} -> EVENT_USER_BINARY_MSG
1053    ConcMarkBegin {} -> EVENT_CONC_MARK_BEGIN
1054    ConcMarkEnd {} -> EVENT_CONC_MARK_END
1055    ConcSyncBegin {} -> EVENT_CONC_SYNC_BEGIN
1056    ConcSyncEnd {} -> EVENT_CONC_SYNC_END
1057    ConcSweepBegin {} -> EVENT_CONC_SWEEP_BEGIN
1058    ConcSweepEnd {} -> EVENT_CONC_SWEEP_END
1059    ConcUpdRemSetFlush {} -> EVENT_CONC_UPD_REM_SET_FLUSH
1060    NonmovingHeapCensus {} -> EVENT_NONMOVING_HEAP_CENSUS
1061    TickyCounterDef {} -> EVENT_TICKY_COUNTER_DEF
1062    TickyCounterSample {} -> EVENT_TICKY_COUNTER_SAMPLE
1063
1064nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT :: EventTypeNum
1065nEVENT_PERF_NAME = EVENT_PERF_NAME
1066nEVENT_PERF_COUNTER = EVENT_PERF_COUNTER
1067nEVENT_PERF_TRACEPOINT = EVENT_PERF_TRACEPOINT
1068
1069putEvent :: Event -> PutM ()
1070putEvent Event {..} = do
1071    putType (eventTypeNum evSpec)
1072    put evTime
1073    putEventSpec evSpec
1074
1075putEventSpec :: EventInfo -> PutM ()
1076putEventSpec (Startup caps) = do
1077    putCap (fromIntegral caps)
1078
1079putEventSpec (EventBlock end cap sz) = do
1080    putE (fromIntegral (sz+24) :: BlockSize)
1081    putE end
1082    putE (fromIntegral cap :: CapNo)
1083
1084putEventSpec (CreateThread t) =
1085    putE t
1086
1087putEventSpec (RunThread t) =
1088    putE t
1089
1090-- here we assume that ThreadStopStatus fromEnum matches the definitions in
1091-- EventLogFormat.h
1092-- The standard encoding is used here, which is wrong for eventlogs
1093-- produced by GHC-7.8.2 ([Stop status in GHC-7.8.2] in EventTypes.hs
1094putEventSpec (StopThread t s) = do
1095    putE t
1096    putE $ case s of
1097            NoStatus -> 0 :: Word16
1098            HeapOverflow -> 1
1099            StackOverflow -> 2
1100            ThreadYielding -> 3
1101            ThreadBlocked -> 4
1102            ThreadFinished -> 5
1103            ForeignCall -> 6
1104            BlockedOnMVar -> 7
1105            BlockedOnMVarRead -> 20 -- since GHC-7.8.3
1106            BlockedOnBlackHole -> 8
1107            BlockedOnBlackHoleOwnedBy _ -> 8
1108            BlockedOnRead -> 9
1109            BlockedOnWrite -> 10
1110            BlockedOnDelay -> 11
1111            BlockedOnSTM -> 12
1112            BlockedOnDoProc -> 13
1113            BlockedOnCCall -> 14
1114            BlockedOnCCall_NoUnblockExc -> 15
1115            BlockedOnMsgThrowTo -> 16
1116            ThreadMigrating -> 17
1117            BlockedOnMsgGlobalise -> 18
1118    putE $ case s of
1119            BlockedOnBlackHoleOwnedBy i -> i
1120            _                           -> 0
1121
1122putEventSpec (ThreadRunnable t) =
1123    putE t
1124
1125putEventSpec (MigrateThread t c) = do
1126    putE t
1127    putCap c
1128
1129putEventSpec (CreateSparkThread t) =
1130    putE t
1131
1132putEventSpec (SparkCounters crt dud ovf cnv fiz gcd rem) = do
1133    putE crt
1134    putE dud
1135    putE ovf
1136    putE cnv
1137    -- Warning: order of fiz and gcd reversed!
1138    putE gcd
1139    putE fiz
1140    putE rem
1141
1142putEventSpec SparkCreate =
1143    return ()
1144
1145putEventSpec SparkDud =
1146    return ()
1147
1148putEventSpec SparkOverflow =
1149    return ()
1150
1151putEventSpec SparkRun =
1152    return ()
1153
1154putEventSpec (SparkSteal c) =
1155    putCap c
1156
1157putEventSpec SparkFizzle =
1158    return ()
1159
1160putEventSpec SparkGC =
1161    return ()
1162
1163putEventSpec (WakeupThread t c) = do
1164    putE t
1165    putCap c
1166
1167putEventSpec (ThreadLabel t (TE.encodeUtf8 -> l)) = do
1168    putE (fromIntegral (B.length l) + sz_tid :: Word16)
1169    putE t
1170    putByteString l
1171
1172putEventSpec Shutdown =
1173    return ()
1174
1175putEventSpec RequestSeqGC =
1176    return ()
1177
1178putEventSpec RequestParGC =
1179    return ()
1180
1181putEventSpec StartGC =
1182    return ()
1183
1184putEventSpec GCWork =
1185    return ()
1186
1187putEventSpec GCIdle =
1188    return ()
1189
1190putEventSpec GCDone =
1191    return ()
1192
1193putEventSpec EndGC =
1194    return ()
1195
1196putEventSpec GlobalSyncGC =
1197    return ()
1198
1199putEventSpec (TaskCreate taskId cap tid) = do
1200    putE taskId
1201    putCap cap
1202    putE tid
1203
1204putEventSpec (TaskMigrate taskId cap new_cap) = do
1205    putE taskId
1206    putCap cap
1207    putCap new_cap
1208
1209putEventSpec (TaskDelete taskId) =
1210    putE taskId
1211
1212putEventSpec GCStatsGHC{..} = do
1213    putE heapCapset
1214    putE (fromIntegral gen :: Word16)
1215    putE copied
1216    putE slop
1217    putE frag
1218    putE (fromIntegral parNThreads :: Word32)
1219    putE parMaxCopied
1220    putE parTotCopied
1221    case parBalancedCopied of
1222      Nothing -> return ()
1223      Just v  -> putE v
1224
1225putEventSpec HeapAllocated{..} = do
1226    putE heapCapset
1227    putE allocBytes
1228
1229putEventSpec HeapSize{..} = do
1230    putE heapCapset
1231    putE sizeBytes
1232
1233putEventSpec HeapLive{..} = do
1234    putE heapCapset
1235    putE liveBytes
1236
1237putEventSpec HeapInfoGHC{..} = do
1238    putE heapCapset
1239    putE (fromIntegral gens :: Word16)
1240    putE maxHeapSize
1241    putE allocAreaSize
1242    putE mblockSize
1243    putE blockSize
1244
1245putEventSpec CapCreate{cap} =
1246    putCap cap
1247
1248putEventSpec CapDelete{cap} =
1249    putCap cap
1250
1251putEventSpec CapDisable{cap} =
1252    putCap cap
1253
1254putEventSpec CapEnable{cap} =
1255    putCap cap
1256
1257putEventSpec (CapsetCreate cs ct) = do
1258    putE cs
1259    putE $ case ct of
1260            CapsetCustom -> 1 :: Word16
1261            CapsetOsProcess -> 2
1262            CapsetClockDomain -> 3
1263            CapsetUnknown -> 0
1264
1265putEventSpec (CapsetDelete cs) =
1266    putE cs
1267
1268putEventSpec (CapsetAssignCap cs cp) = do
1269    putE cs
1270    putCap cp
1271
1272putEventSpec (CapsetRemoveCap cs cp) = do
1273    putE cs
1274    putCap cp
1275
1276putEventSpec (RtsIdentifier cs (TE.encodeUtf8 -> rts)) = do
1277    putE (fromIntegral (B.length rts) + sz_capset :: Word16)
1278    putE cs
1279    putByteString rts
1280
1281putEventSpec (ProgramArgs cs (map TE.encodeUtf8 -> as)) = do
1282    let sz_args = sum (map ((+ 1) {- for \0 -} . B.length) as) - 1
1283    putE (fromIntegral sz_args + sz_capset :: Word16)
1284    putE cs
1285    mapM_ putByteString (intersperse "\0" as)
1286
1287putEventSpec (ProgramEnv cs (map TE.encodeUtf8 -> es)) = do
1288    let sz_env = sum (map ((+ 1) {- for \0 -} . B.length) es) - 1
1289    putE (fromIntegral sz_env + sz_capset :: Word16)
1290    putE cs
1291    mapM_ putByteString $ intersperse "\0" es
1292
1293putEventSpec (OsProcessPid cs pid) = do
1294    putE cs
1295    putE pid
1296
1297putEventSpec (OsProcessParentPid cs ppid) = do
1298    putE cs
1299    putE ppid
1300
1301putEventSpec (WallClockTime cs sec nsec) = do
1302    putE cs
1303    putE sec
1304    putE nsec
1305
1306putEventSpec (Message (TE.encodeUtf8 -> s)) = do
1307    putE (fromIntegral (B.length s) :: Word16)
1308    putByteString s
1309
1310putEventSpec (UserMessage (TE.encodeUtf8 -> s)) = do
1311    putE (fromIntegral (B.length s) :: Word16)
1312    putByteString s
1313
1314putEventSpec (UserMarker (TE.encodeUtf8 -> s)) = do
1315    putE (fromIntegral (B.length s) :: Word16)
1316    putByteString s
1317
1318putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent"
1319
1320putEventSpec (InternString str id) = do
1321    putE len
1322    mapM_ putE str
1323    putE id
1324  where len = (fromIntegral (length str) :: Word16) + sz_string_id
1325
1326putEventSpec (Version s) = do
1327    putE (fromIntegral (length s) :: Word16)
1328    mapM_ putE s
1329
1330putEventSpec (ProgramInvocation s) = do
1331    putE (fromIntegral (length s) :: Word16)
1332    mapM_ putE s
1333
1334putEventSpec ( EdenStartReceive ) = return ()
1335
1336putEventSpec ( EdenEndReceive ) = return ()
1337
1338putEventSpec ( CreateProcess  process ) = do
1339    putE process
1340
1341putEventSpec ( KillProcess process ) = do
1342    putE process
1343
1344putEventSpec ( AssignThreadToProcess thread process ) = do
1345    putE thread
1346    putE process
1347
1348putEventSpec ( CreateMachine machine realtime ) = do
1349    putE machine
1350    putE realtime
1351
1352putEventSpec ( KillMachine machine ) = do
1353    putE machine
1354
1355putEventSpec ( SendMessage mesTag senderProcess senderThread
1356                 receiverMachine receiverProcess receiverInport ) = do
1357    putE (fromMsgTag mesTag)
1358    putE senderProcess
1359    putE senderThread
1360    putE receiverMachine
1361    putE receiverProcess
1362    putE receiverInport
1363
1364putEventSpec ( ReceiveMessage mesTag receiverProcess receiverInport
1365                 senderMachine senderProcess senderThread messageSize ) = do
1366    putE (fromMsgTag mesTag)
1367    putE receiverProcess
1368    putE receiverInport
1369    putE senderMachine
1370    putE senderProcess
1371    putE senderThread
1372    putE messageSize
1373
1374putEventSpec ( SendReceiveLocalMessage mesTag senderProcess senderThread
1375                 receiverProcess receiverInport ) = do
1376    putE (fromMsgTag mesTag)
1377    putE senderProcess
1378    putE senderThread
1379    putE receiverProcess
1380    putE receiverInport
1381
1382putEventSpec (MerStartParConjunction dyn_id static_id) = do
1383    putE dyn_id
1384    putE static_id
1385
1386putEventSpec (MerEndParConjunction dyn_id) =
1387    putE dyn_id
1388
1389putEventSpec (MerEndParConjunct dyn_id) =
1390    putE dyn_id
1391
1392putEventSpec (MerCreateSpark dyn_id spark_id) = do
1393    putE dyn_id
1394    putE spark_id
1395
1396putEventSpec (MerFutureCreate future_id name_id) = do
1397    putE future_id
1398    putE name_id
1399
1400putEventSpec (MerFutureWaitNosuspend future_id) =
1401    putE future_id
1402
1403putEventSpec (MerFutureWaitSuspended future_id) =
1404    putE future_id
1405
1406putEventSpec (MerFutureSignal future_id) =
1407    putE future_id
1408
1409putEventSpec MerLookingForGlobalThread = return ()
1410putEventSpec MerWorkStealing = return ()
1411putEventSpec MerLookingForLocalSpark = return ()
1412
1413putEventSpec (MerReleaseThread thread_id) =
1414    putE thread_id
1415
1416putEventSpec MerCapSleeping = return ()
1417putEventSpec MerCallingMain = return ()
1418
1419putEventSpec PerfName{name = (TE.encodeUtf8 -> name), ..} = do
1420    putE (fromIntegral (B.length name) + sz_perf_num :: Word16)
1421    putE perfNum
1422    putByteString name
1423
1424putEventSpec PerfCounter{..} = do
1425    putE perfNum
1426    putE tid
1427    putE period
1428
1429putEventSpec PerfTracepoint{..} = do
1430    putE perfNum
1431    putE tid
1432
1433putEventSpec HeapProfBegin {..} = do
1434    putE heapProfId
1435    putE heapProfSamplingPeriod
1436    putE heapProfBreakdown
1437    mapM_ (putE . T.unpack)
1438      [ heapProfModuleFilter
1439      , heapProfClosureDescrFilter
1440      , heapProfTypeDescrFilter
1441      , heapProfCostCentreFilter
1442      , heapProfCostCentreStackFilter
1443      , heapProfRetainerFilter
1444      , heapProfBiographyFilter
1445      ]
1446
1447putEventSpec HeapProfCostCentre {..} = do
1448    putE heapProfCostCentreId
1449    putE $ T.unpack heapProfLabel
1450    putE $ T.unpack heapProfModule
1451    putE $ T.unpack heapProfSrcLoc
1452    putE heapProfFlags
1453
1454putEventSpec HeapProfSampleBegin {..} =
1455    putE heapProfSampleEra
1456
1457putEventSpec HeapProfSampleEnd {..} =
1458    putE heapProfSampleEra
1459
1460putEventSpec HeapBioProfSampleBegin {..} = do
1461    putE heapProfSampleEra
1462    putE heapProfSampleTime
1463
1464
1465putEventSpec HeapProfSampleCostCentre {..} = do
1466    putE heapProfId
1467    putE heapProfResidency
1468    putE heapProfStackDepth
1469    VU.mapM_ putE heapProfStack
1470
1471putEventSpec HeapProfSampleString {..} = do
1472    putE heapProfId
1473    putE heapProfResidency
1474    putE $ T.unpack heapProfLabel
1475
1476putEventSpec ProfSampleCostCentre {..} = do
1477    putE profCapset
1478    putE profTicks
1479    putE profStackDepth
1480    VU.mapM_ putE profCcsStack
1481
1482putEventSpec ProfBegin {..} = do
1483    putE profTickInterval
1484
1485putEventSpec UserBinaryMessage {..} = do
1486    putE (fromIntegral (B.length payload) :: Word16)
1487    putByteString payload
1488
1489putEventSpec ConcMarkBegin = return ()
1490putEventSpec ConcMarkEnd {..} = do
1491    putE concMarkedObjectCount
1492putEventSpec ConcSyncBegin = return ()
1493putEventSpec ConcSyncEnd = return ()
1494putEventSpec ConcSweepBegin = return ()
1495putEventSpec ConcSweepEnd = return ()
1496putEventSpec ConcUpdRemSetFlush {..} = do
1497    putCap cap
1498putEventSpec NonmovingHeapCensus {..} = do
1499    putE nonmovingCensusBlkSize
1500    putE nonmovingCensusActiveSegs
1501    putE nonmovingCensusFilledSegs
1502    putE nonmovingCensusLiveBlocks
1503putEventSpec TickyCounterDef {..} = do
1504    putE tickyCtrDefId
1505    putE tickyCtrDefArity
1506    putE (T.unpack tickyCtrDefKinds)
1507    putE (T.unpack tickyCtrDefName)
1508putEventSpec TickyCounterSample {..} = do
1509    putE tickyCtrSampleId
1510    putE tickyCtrSampleEntryCount
1511    putE tickyCtrSampleAllocs
1512    putE tickyCtrSampleAllocd
1513