# LANGUAGE CPP , BangPatterns , PatternGuards #
{-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns -fno-warn-deprecations #-}

  -    Parser functions for GHC RTS EventLog framework . 
 
 -   Parser functions for GHC RTS EventLog framework.
 -}

module GHC.RTS.Events (
       main,
       -- * The event log types
       EventLog(..),
       EventType(..),
       Event(..),
       EventInfo(..),
       ThreadStopStatus(..),
       Header(..),
       Data(..),
       CapsetType(..),
       Timestamp,
       ThreadId,
       TaskId,
       KernelThreadId(..),

       -- * Reading and writing event logs
       readEventLogFromFile,
       writeEventLogToFile,

       -- * Utilities
       CapEvent(..), sortEvents, groupEvents, sortGroups,
       buildEventTypeMap,

       -- * Printing
       showEventInfo, showThreadStopStatus,
       ppEventLog, ppEventType, ppEvent,

       -- * Perf events
       nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT,
       sz_perf_num, sz_kernel_tid
  ) where

{- Libraries. -}
import Data.Binary
import Data.Binary.Get hiding (skip)
import qualified Data.Binary.Get as G
import Data.Binary.Put
import Control.Monad
import Data.IntMap (IntMap)
import qualified Data.IntMap as M
import Control.Monad.Reader
import Control.Monad.Error
import qualified Data.ByteString.Lazy as L
import Data.Function
import Data.List
import Data.Either
import Data.Maybe
import Text.Printf
import Data.Array

import GHC.RTS.EventTypes
import GHC.RTS.EventParserUtils

#define EVENTLOG_CONSTANTS_ONLY
#include "EventLogFormat.h"

main :: IO ()
main = return ()

------------------------------------------------------------------------------
-- Binary instances

getEventType :: GetHeader EventType
getEventType = do
           etNum <- getH
           size <- getH :: GetHeader EventTypeSize
           let etSize = if size == 0xffff then Nothing else Just size
           -- 0xffff indicates variable-sized event
           etDescLen <- getH :: GetHeader EventTypeDescLen
           etDesc <- getEtDesc (fromIntegral etDescLen)
           etExtraLen <- getH :: GetHeader Word32
           lift $ G.skip (fromIntegral etExtraLen)
           ete <- getH :: GetHeader Marker
           when (ete /= EVENT_ET_END) $
              throwError ("Event Type end marker not found.")
           return (EventType etNum etDesc etSize)
           where
             getEtDesc :: Int -> GetHeader [Char]
             getEtDesc s = replicateM s (getH :: GetHeader Char)

getHeader :: GetHeader Header
getHeader = do
           hdrb <- getH :: GetHeader Marker
           when (hdrb /= EVENT_HEADER_BEGIN) $
                throwError "Header begin marker not found"
           hetm <- getH :: GetHeader Marker
           when (hetm /= EVENT_HET_BEGIN) $
                throwError "Header Event Type begin marker not found"
           ets <- getEventTypes
           emark <- getH :: GetHeader Marker
           when (emark /= EVENT_HEADER_END) $
                throwError "Header end marker not found"
           return (Header ets)
     where
       getEventTypes :: GetHeader [EventType]
       getEventTypes = do
           m <- getH :: GetHeader Marker
           case () of
            _ | m == EVENT_ET_BEGIN -> do
                   et <- getEventType
                   nextET <- getEventTypes
                   return (et : nextET)
              | m == EVENT_HET_END ->
                   return []
              | otherwise ->
                   throwError "Malformed list of Event Types in header"

getEvent :: EventParsers -> GetEvents (Maybe Event)
getEvent (EventParsers parsers) = do
  etRef <- getE :: GetEvents EventTypeNum
  if (etRef == EVENT_DATA_END)
     then return Nothing
     else do !ts   <- getE
             -- trace ("event: " ++ show etRef) $ do
             spec <- parsers ! fromIntegral etRef
             return (Just (Event ts spec))

--
-- standardEventParsers.
--
standardParsers :: [EventParser EventInfo]
standardParsers = [
  ( n_caps )
      c <- getE :: GetEvents CapNo
      return Startup{ n_caps = fromIntegral c }
   )),

 (FixedSizeParser EVENT_BLOCK_MARKER (sz_block_size + sz_time + sz_cap) (do -- (size, end_time, cap)
      block_size <- getE :: GetEvents BlockSize
      end_time <- getE :: GetEvents Timestamp
      c <- getE :: GetEvents CapNo
      lbs <- lift . lift $ getLazyByteString ((fromIntegral block_size) -
                                              (fromIntegral sz_block_event))
      eparsers <- ask
      let e_events = runGet (runErrorT $ runReaderT (getEventBlock eparsers) eparsers) lbs
      return EventBlock{ end_time=end_time,
                         cap= fromIntegral c,
                         block_events=case e_events of
                                        Left s -> error s
                                        Right es -> es }
   )),

  EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6 +
 -- no longer generate the event; should be removed at some point
 (simpleEvent EVENT_SHUTDOWN Shutdown),

 (simpleEvent EVENT_REQUEST_SEQ_GC RequestSeqGC),

 (simpleEvent EVENT_REQUEST_PAR_GC RequestParGC),

 (simpleEvent EVENT_GC_START StartGC),

 (simpleEvent EVENT_GC_WORK GCWork),

 (simpleEvent EVENT_GC_IDLE GCIdle),

 (simpleEvent EVENT_GC_DONE GCDone),

 (simpleEvent EVENT_GC_END EndGC),

 (simpleEvent EVENT_GC_GLOBAL_SYNC GlobalSyncGC),

  ( heap_capset , generation , copied_bytes , slop_bytes , frag_bytes , par_n_threads , par_max_copied , par_tot_copied )
      heapCapset   <- getE
      gen          <- getE :: GetEvents Word16
      copied       <- getE :: GetEvents Word64
      slop         <- getE :: GetEvents Word64
      frag         <- getE :: GetEvents Word64
      parNThreads  <- getE :: GetEvents Word32
      parMaxCopied <- getE :: GetEvents Word64
      parTotCopied <- getE :: GetEvents Word64
      return GCStatsGHC{ gen = fromIntegral gen
                       , parNThreads = fromIntegral parNThreads
                       , ..}
 )),

  ( heap_capset , alloc_bytes )
      heapCapset <- getE
      allocBytes <- getE
      return HeapAllocated{..}
 )),

  ( heap_capset , size_bytes )
      heapCapset <- getE
      sizeBytes  <- getE
      return HeapSize{..}
 )),

  ( heap_capset , live_bytes )
      heapCapset <- getE
      liveBytes  <- getE
      return HeapLive{..}
 )),

  ( heap_capset , n_generations , max_heap_size , alloc_area_size , mblock_size , block_size )
      heapCapset    <- getE
      gens          <- getE :: GetEvents Word16
      maxHeapSize   <- getE :: GetEvents Word64
      allocAreaSize <- getE :: GetEvents Word64
      mblockSize    <- getE :: GetEvents Word64
      blockSize     <- getE :: GetEvents Word64
      return HeapInfoGHC{gens = fromIntegral gens, ..}
 )),

 (FixedSizeParser EVENT_CAP_CREATE (sz_cap) (do  -- (cap)
      cap <- getE :: GetEvents CapNo
      return CapCreate{cap = fromIntegral cap}
 )),

 (FixedSizeParser EVENT_CAP_DELETE (sz_cap) (do  -- (cap)
      cap <- getE :: GetEvents CapNo
      return CapDelete{cap = fromIntegral cap}
 )),

 (FixedSizeParser EVENT_CAP_DISABLE (sz_cap) (do  -- (cap)
      cap <- getE :: GetEvents CapNo
      return CapDisable{cap = fromIntegral cap}
 )),

 (FixedSizeParser EVENT_CAP_ENABLE (sz_cap) (do  -- (cap)
      cap <- getE :: GetEvents CapNo
      return CapEnable{cap = fromIntegral cap}
 )),

 (FixedSizeParser EVENT_CAPSET_CREATE (sz_capset + sz_capset_type) (do -- (capset, capset_type)
      cs <- getE
      ct <- fmap mkCapsetType getE
      return CapsetCreate{capset=cs,capsetType=ct}
   )),

 (FixedSizeParser EVENT_CAPSET_DELETE sz_capset (do -- (capset)
      cs <- getE
      return CapsetDelete{capset=cs}
   )),

 (FixedSizeParser EVENT_CAPSET_ASSIGN_CAP (sz_capset + sz_cap) (do -- (capset, cap)
      cs <- getE
      cp <- getE :: GetEvents CapNo
      return CapsetAssignCap{capset=cs,cap=fromIntegral cp}
   )),

 (FixedSizeParser EVENT_CAPSET_REMOVE_CAP (sz_capset + sz_cap) (do -- (capset, cap)
      cs <- getE
      cp <- getE :: GetEvents CapNo
      return CapsetRemoveCap{capset=cs,cap=fromIntegral cp}
   )),

 (FixedSizeParser EVENT_OSPROCESS_PID (sz_capset + sz_pid) (do -- (capset, pid)
      cs <- getE
      pd <- getE
      return OsProcessPid{capset=cs,pid=pd}
   )),

 (FixedSizeParser EVENT_OSPROCESS_PPID (sz_capset + sz_pid) (do -- (capset, ppid)
      cs <- getE
      pd <- getE
      return OsProcessParentPid{capset=cs,ppid=pd}
  )),

 (FixedSizeParser EVENT_WALL_CLOCK_TIME (sz_capset + 8 + 4) (do -- (capset, unix_epoch_seconds, nanoseconds)
      cs <- getE
      s  <- getE
      ns <- getE
      return WallClockTime{capset=cs,sec=s,nsec=ns}
  )),

 (VariableSizeParser EVENT_LOG_MSG (do -- (msg)
      num <- getE :: GetEvents Word16
      string <- getString num
      return Message{ msg = string }
   )),
 (VariableSizeParser EVENT_USER_MSG (do -- (msg)
      num <- getE :: GetEvents Word16
      string <- getString num
      return UserMessage{ msg = string }
   )),
  (  )
      num <- getE :: GetEvents Word16
      string <- getString num
      return UserMarker{ markername = string }
   )),
 (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg])
      num <- getE :: GetEvents Word16
      cs <- getE
      string <- getString (num - sz_capset)
      return ProgramArgs{ capset = cs
                        , args = splitNull string }
   )),
 (VariableSizeParser EVENT_PROGRAM_ENV (do -- (capset, [arg])
      num <- getE :: GetEvents Word16
      cs <- getE
      string <- getString (num - sz_capset)
      return ProgramEnv{ capset = cs
                       , env = splitNull string }
   )),
 (VariableSizeParser EVENT_RTS_IDENTIFIER (do -- (capset, str)
      num <- getE :: GetEvents Word16
      cs <- getE
      string <- getString (num - sz_capset)
      return RtsIdentifier{ capset = cs
                          , rtsident = string }
   )),

  ( str , i d )
      num <- getE :: GetEvents Word16
      string <- getString (num - sz_string_id)
      sId <- getE :: GetEvents StringId
      return (InternString string sId)
    )),

  ( thread ,  )
      num <- getE :: GetEvents Word16
      tid <- getE
      str <- getString (num - sz_tid)
      return ThreadLabel{ thread      = tid
                        , threadlabel = str }
    ))
 ]

  Parsers valid for GHC7 but not GHC6 .
ghc7Parsers :: [EventParser EventInfo]
ghc7Parsers = [
 (FixedSizeParser EVENT_CREATE_THREAD sz_tid (do  -- (thread)
      t <- getE
      return CreateThread{thread=t}
   )),

 (FixedSizeParser EVENT_RUN_THREAD sz_tid (do  --  (thread)
      t <- getE
      return RunThread{thread=t}
   )),

 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status) (do
      -- (thread, status)
      t <- getE
      s <- getE :: GetEvents RawThreadStopStatus
      return StopThread{thread=t, status = if s > maxThreadStopStatus
                                              then NoStatus
                                              else mkStopStatus s}
   )),

 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do
      -- (thread, status, info)
      t <- getE
      s <- getE :: GetEvents RawThreadStopStatus
      i <- getE :: GetEvents ThreadId
      return StopThread{thread = t,
                        status = case () of
                                  _ | s > maxThreadStopStatus
                                    -> NoStatus
                                    | s == 8 {- XXX yeuch -}
                                    -> BlockedOnBlackHoleOwnedBy i
                                    | otherwise
                                    -> mkStopStatus s}
   )),

 (FixedSizeParser EVENT_THREAD_RUNNABLE sz_tid (do  -- (thread)
      t <- getE
      return ThreadRunnable{thread=t}
   )),

   ( thread ,  )
      t  <- getE
      nc <- getE :: GetEvents CapNo
      return MigrateThread{thread=t,newCap=fromIntegral nc}
   )),

  Yes , EVENT_RUN / STEAL_SPARK are deprecated , but see the explanation in the
  ' ghc6Parsers ' section below . Since we 're parsing them anyway , we might
  as well convert them to the new SparkRun / SparkSteal events .
 (FixedSizeParser EVENT_RUN_SPARK sz_tid (do  -- (thread)
      _ <- getE :: GetEvents ThreadId
      return SparkRun
   )),

 (FixedSizeParser EVENT_STEAL_SPARK (sz_tid + sz_cap) (do  -- (thread, victimCap)
      _  <- getE :: GetEvents ThreadId
      vc <- getE :: GetEvents CapNo
      return SparkSteal{victimCap=fromIntegral vc}
   )),

  ( sparkThread )
      st <- getE :: GetEvents ThreadId
      return CreateSparkThread{sparkThread=st}
   )),

  (  , dud , ovf , cnv , gcd , fiz , rem )
      crt <- getE :: GetEvents Word64
      dud <- getE :: GetEvents Word64
      ovf <- getE :: GetEvents Word64
      cnv <- getE :: GetEvents Word64
      gcd <- getE :: GetEvents Word64
      fiz <- getE :: GetEvents Word64
      rem <- getE :: GetEvents Word64
      return SparkCounters{sparksCreated    = crt, sparksDud       = dud,
                           sparksOverflowed = ovf, sparksConverted = cnv,
  Warning : order of fiz and gcd reversed !
                           sparksFizzled    = fiz, sparksGCd       = gcd,
                           sparksRemaining  = rem}
   )),

 (simpleEvent EVENT_SPARK_CREATE   SparkCreate),
 (simpleEvent EVENT_SPARK_DUD      SparkDud),
 (simpleEvent EVENT_SPARK_OVERFLOW SparkOverflow),
 (simpleEvent EVENT_SPARK_RUN      SparkRun),
 (FixedSizeParser EVENT_SPARK_STEAL sz_cap (do  -- (victimCap)
      vc <- getE :: GetEvents CapNo
      return SparkSteal{victimCap=fromIntegral vc}
   )),
 (simpleEvent EVENT_SPARK_FIZZLE   SparkFizzle),
 (simpleEvent EVENT_SPARK_GC       SparkGC),

  ( taskID , cap , tid )
      taskId <- getE :: GetEvents TaskId
      cap    <- getE :: GetEvents CapNo
      tid    <- getE :: GetEvents KernelThreadId
      return TaskCreate{ taskId, cap = fromIntegral cap, tid }
   )),
 (FixedSizeParser EVENT_TASK_MIGRATE (sz_taskid + sz_cap*2) (do  -- (taskID, cap, new_cap)
      taskId  <- getE :: GetEvents TaskId
      cap     <- getE :: GetEvents CapNo
      new_cap <- getE :: GetEvents CapNo
      return TaskMigrate{ taskId, cap = fromIntegral cap
                                , new_cap = fromIntegral new_cap
                        }
   )),
 (FixedSizeParser EVENT_TASK_DELETE (sz_taskid) (do  -- (taskID)
      taskId <- getE :: GetEvents TaskId
      return TaskDelete{ taskId }
   )),

  ( thread ,  )
      t <- getE
      oc <- getE :: GetEvents CapNo
      return WakeupThread{thread=t,otherCap=fromIntegral oc}
   ))
 ]

 -----------------------
  GHC 6.12 compat : GHC 6.12 reported the wrong sizes for some events ,
 -- so we have to recognise those wrong sizes here for backwards
 -- compatibility.
ghc6Parsers :: [EventParser EventInfo]
ghc6Parsers = [
 (FixedSizeParser EVENT_STARTUP 0 (do
  BUG in GHC 6.12 : the startup event was incorrectly
      -- declared as size 0, so we accept it here.
      c <- getE :: GetEvents CapNo
      return Startup{ n_caps = fromIntegral c }
   )),

 (FixedSizeParser EVENT_CREATE_THREAD sz_old_tid (do  -- (thread)
      t <- getE
      return CreateThread{thread=t}
   )),

 (FixedSizeParser EVENT_RUN_THREAD sz_old_tid (do  --  (thread)
      t <- getE
      return RunThread{thread=t}
   )),

 (FixedSizeParser EVENT_STOP_THREAD (sz_old_tid + 2) (do  -- (thread, status)
      t <- getE
      s <- getE :: GetEvents Word16
      let stat = fromIntegral s
      return StopThread{thread=t, status = if stat > maxBound
                                              then NoStatus
                                              else mkStopStatus stat}
   )),

 (FixedSizeParser EVENT_THREAD_RUNNABLE sz_old_tid (do  -- (thread)
      t <- getE
      return ThreadRunnable{thread=t}
   )),

   ( thread ,  )
      t  <- getE
      nc <- getE :: GetEvents CapNo
      return MigrateThread{thread=t,newCap=fromIntegral nc}
   )),

  Note : it is vital that these two ( EVENT_RUN / STEAL_SPARK ) remain here ( at
  least in the ghc6Parsers section ) even though both events are deprecated .
  The reason is that .eventlog files created by the buggy GHC-6.12
  mis - declare the size of these two events . So we have to handle them
 -- specially here otherwise we'll get the wrong size, leading to us getting
 -- out of sync and eventual parse failure. Since we're parsing them anyway,
  we might as well convert them to the new SparkRun / SparkSteal events .
 (FixedSizeParser EVENT_RUN_SPARK sz_old_tid (do  -- (thread)
      _ <- getE :: GetEvents ThreadId
      return SparkRun
   )),

 (FixedSizeParser EVENT_STEAL_SPARK (sz_old_tid + sz_cap) (do  -- (thread, victimCap)
      _  <- getE :: GetEvents ThreadId
      vc <- getE :: GetEvents CapNo
      return SparkSteal{victimCap=fromIntegral vc}
   )),

  ( sparkThread )
      st <- getE :: GetEvents ThreadId
      return CreateSparkThread{sparkThread=st}
   )),

  ( thread ,  )
      t <- getE
      oc <- getE :: GetEvents CapNo
      return WakeupThread{thread=t,otherCap=fromIntegral oc}
   ))
 ]

mercuryParsers = [
 (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION
    (sz_par_conj_dyn_id + sz_par_conj_static_id)
    (do dyn_id <- getE
        static_id <- getE
        return (MerStartParConjunction dyn_id static_id))
 ),

 (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCTION sz_par_conj_dyn_id
    (do dyn_id <- getE
        return (MerEndParConjunction dyn_id))
 ),

 (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCT sz_par_conj_dyn_id
    (do dyn_id <- getE
        return (MerEndParConjunct dyn_id))
 ),

 (FixedSizeParser EVENT_MER_CREATE_SPARK (sz_par_conj_dyn_id + sz_spark_id)
    (do dyn_id <- getE
        spark_id <- getE
        return (MerCreateSpark dyn_id spark_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_CREATE (sz_future_id + sz_string_id)
    (do future_id <- getE
        name_id <- getE
        return (MerFutureCreate future_id name_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_WAIT_NOSUSPEND (sz_future_id)
    (do future_id <- getE
        return (MerFutureWaitNosuspend future_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_WAIT_SUSPENDED (sz_future_id)
    (do future_id <- getE
        return (MerFutureWaitSuspended future_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_SIGNAL (sz_future_id)
    (do future_id <- getE
        return (MerFutureSignal future_id))
 ),

 (simpleEvent EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT MerLookingForGlobalThread),
 (simpleEvent EVENT_MER_WORK_STEALING MerWorkStealing),
 (simpleEvent EVENT_MER_LOOKING_FOR_LOCAL_SPARK MerLookingForLocalSpark),

 (FixedSizeParser EVENT_MER_RELEASE_CONTEXT sz_tid
    (do thread_id <- getE
        return (MerReleaseThread thread_id))
 ),

 (simpleEvent EVENT_MER_ENGINE_SLEEPING MerCapSleeping),
 (simpleEvent EVENT_MER_CALLING_MAIN MerCallingMain)

 ]

perfParsers = [
 (VariableSizeParser EVENT_PERF_NAME (do -- (perf_num, name)
      num     <- getE :: GetEvents Word16
      perfNum <- getE
      name    <- getString (num - sz_perf_num)
      return PerfName{perfNum, name}
   )),

 (FixedSizeParser EVENT_PERF_COUNTER (sz_perf_num + sz_kernel_tid + 8) (do -- (perf_num, tid, period)
      perfNum <- getE
      tid     <- getE
      period  <- getE
      return PerfCounter{perfNum, tid, period}
  )),

 (FixedSizeParser EVENT_PERF_TRACEPOINT (sz_perf_num + sz_kernel_tid) (do -- (perf_num, tid)
      perfNum <- getE
      tid     <- getE
      return PerfTracepoint{perfNum, tid}
  ))
 ]

getData :: GetEvents Data
getData = do
   db <- getE :: GetEvents Marker
   when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found"
   eparsers <- ask
   let
       getEvents :: [Event] -> GetEvents Data
       getEvents events = do
         mb_e <- getEvent eparsers
         case mb_e of
           Nothing -> return (Data (reverse events))
           Just e  -> getEvents (e:events)
   -- in
   getEvents []

getEventBlock :: EventParsers -> GetEvents [Event]
getEventBlock parsers = do
  b <- lift . lift $ isEmpty
  if b then return [] else do
   mb_e <- getEvent parsers
   case mb_e of
     Nothing -> return []
     Just e  -> do
       es <- getEventBlock parsers
       return (e:es)

getEventLog :: ErrorT String Get EventLog
getEventLog = do
    header <- getHeader
    let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header]
        -- This test is complete, no-one has extended this event yet and all future
        -- extensions will use newly allocated event IDs.
        is_ghc_6 = Just sz_old_tid == do create_et <- M.lookup EVENT_CREATE_THREAD imap
                                         size create_et

         -- GHC6 writes an invalid header , we handle it here by using a 
         -- different set of event parsers .   Note that the ghc7 event parsers 
         -- are standard events , and can be used by other runtime systems that 
         -- make use of threadscope . 
        
        -- GHC6 writes an invalid header, we handle it here by using a
        -- different set of event parsers.  Note that the ghc7 event parsers
        -- are standard events, and can be used by other runtime systems that
        -- make use of threadscope.
        -}
        event_parsers = if is_ghc_6
                            then standardParsers ++ ghc6Parsers
                            else standardParsers ++ ghc7Parsers
                                 ++ mercuryParsers ++ perfParsers
        parsers = mkEventTypeParsers imap event_parsers
    dat <- runReaderT getData (EventParsers parsers)
    return (EventLog header dat)

readEventLogFromFile :: FilePath -> IO (Either String EventLog)
readEventLogFromFile f = do
    s <- L.readFile f
    return $ runGet (do v <- runErrorT $ getEventLog
                        m <- isEmpty
                        m `seq` return v)  s

-- -----------------------------------------------------------------------------
  Utilities

sortEvents :: [Event] -> [CapEvent]
sortEvents = sortGroups . groupEvents

-- | Sort the raw event stream by time, annotating each event with the
-- capability that generated it.
sortGroups :: [(Maybe Int, [Event])] -> [CapEvent]
sortGroups groups = mergesort' (compare `on` (time . ce_event)) $
                      [ [ CapEvent cap e | e <- es ]
                      | (cap, es) <- groups ]
     -- sorting is made much faster by the way that the event stream is
     -- divided into blocks of events.
     --  - All events in a block belong to a particular capability
     --  - The events in a block are ordered by time
     --  - blocks for the same capability appear in time order in the event
     --    stream and do not overlap.
     --
  So to sort the events we make one list of events for each
     -- capability (basically just concat . filter), and then
     -- merge the resulting lists.

groupEvents :: [Event] -> [(Maybe Int, [Event])]
groupEvents es = (Nothing, n_events) :
                 [ (Just (cap (head blocks)), concatMap block_events blocks)
                 | blocks <- groups ]
  where
   (blocks, anon_events) = partitionEithers (map separate es)
      where separate e | b@EventBlock{} <- spec e = Left  b
                       | otherwise                = Right e

   (cap_blocks, gbl_blocks) = partition (is_cap . cap) blocks
      where is_cap c = fromIntegral c /= ((-1) :: Word16)

   groups = groupBy ((==) `on` cap) $ sortBy (compare `on` cap) cap_blocks

  There are two sources of events without a capability : events
  in the raw stream not inside an EventBlock , and EventBlocks
  with cap = = -1 .   We have to merge those two streams .
     -- In light of merged logs, global blocks may have overlapping
  time spans , thus the blocks are mergesorted
   n_events = mergesort' (compare `on` time) (anon_events : map block_events gbl_blocks)

mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]
mergesort' _   [] = []
mergesort' _   [xs] = xs
mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)

merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]
merge_pairs _   [] = []
merge_pairs _   [xs] = [xs]
merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss

merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
merge _   [] ys = ys
merge _   xs [] = xs
merge cmp (x:xs) (y:ys)
 = case x `cmp` y of
        GT -> y : merge cmp (x:xs)   ys
        _  -> x : merge cmp    xs (y:ys)


buildEventTypeMap :: [EventType] -> IntMap EventType
buildEventTypeMap etypes = M.fromList [ (fromIntegral (num t),t) | t <- etypes ]

-----------------------------------------------------------------------------
-- Some pretty-printing support

showEventInfo :: EventInfo -> String
showEventInfo spec =
    case spec of
        EventBlock end_time cap _block_events ->
          printf "event block: cap %d, end time: %d\n" cap end_time
        Startup n_caps ->
          printf "startup: %d capabilities" n_caps
        CreateThread thread ->
          printf "creating thread %d" thread
        RunThread thread ->
          printf "running thread %d" thread
        StopThread thread status ->
          printf "stopping thread %d (%s)" thread (showThreadStopStatus status)
        ThreadRunnable thread ->
          printf "thread %d is runnable" thread
        MigrateThread thread newCap  ->
          printf "migrating thread %d to cap %d" thread newCap
        CreateSparkThread sparkThread ->
          printf "creating spark thread %d" sparkThread
        SparkCounters crt dud ovf cnv fiz gcd rem ->
          printf "spark stats: %d created, %d converted, %d remaining (%d overflowed, %d dud, %d GC'd, %d fizzled)" crt cnv rem ovf dud gcd fiz
        SparkCreate ->
          printf "spark created"
        SparkDud ->
          printf "dud spark discarded"
        SparkOverflow ->
          printf "overflowed spark discarded"
        SparkRun ->
          printf "running a local spark"
        SparkSteal victimCap ->
          printf "stealing a spark from cap %d" victimCap
        SparkFizzle ->
          printf "spark fizzled"
        SparkGC ->
          printf "spark GCed"
        TaskCreate taskId cap tid ->
          printf "task 0x%x created on cap %d with OS kernel thread %d"
                 taskId cap (kernelThreadId tid)
        TaskMigrate taskId cap new_cap ->
          printf "task 0x%x migrated from cap %d to cap %d"
                 taskId cap new_cap
        TaskDelete taskId ->
          printf "task 0x%x deleted" taskId
        Shutdown ->
          printf "shutting down"
        WakeupThread thread otherCap ->
          printf "waking up thread %d on cap %d" thread otherCap
        ThreadLabel thread label ->
          printf "thread %d has label \"%s\"" thread label
        RequestSeqGC ->
          printf "requesting sequential GC"
        RequestParGC ->
          printf "requesting parallel GC"
        StartGC ->
          printf "starting GC"
        EndGC ->
          printf "finished GC"
        GCWork ->
          printf "GC working"
        GCIdle ->
          printf "GC idle"
        GCDone ->
          printf "GC done"
        GlobalSyncGC ->
          printf "all caps stopped for GC"
        GCStatsGHC{..} ->
          printf "GC stats for heap capset %d: generation %d, %d bytes copied, %d bytes slop, %d bytes fragmentation, %d par threads, %d bytes max par copied, %d bytes total par copied" heapCapset gen copied slop frag parNThreads parMaxCopied parTotCopied
        HeapAllocated{..} ->
          printf "allocated on heap capset %d: %d total bytes till now" heapCapset allocBytes
        HeapSize{..} ->
          printf "size of heap capset %d: %d bytes" heapCapset sizeBytes
        HeapLive{..} ->
          printf "live data in heap capset %d: %d bytes" heapCapset liveBytes
        HeapInfoGHC{..} ->
          printf "heap stats for heap capset %d: generations %d, %d bytes max heap size, %d bytes alloc area size, %d bytes mblock size, %d bytes block size" heapCapset gens maxHeapSize allocAreaSize mblockSize blockSize
        CapCreate{cap} ->
          printf "created cap %d" cap
        CapDelete{cap} ->
          printf "deleted cap %d" cap
        CapDisable{cap} ->
          printf "disabled cap %d" cap
        CapEnable{cap} ->
          printf "enabled cap %d" cap
        Message msg ->
          msg
        UserMessage msg ->
          msg
        UserMarker markername ->
          printf "marker: %s" markername
        CapsetCreate cs ct ->
          printf "created capset %d of type %s" cs (show ct)
        CapsetDelete cs ->
          printf "deleted capset %d" cs
        CapsetAssignCap cs cp ->
          printf "assigned cap %d to capset %d" cp cs
        CapsetRemoveCap cs cp ->
          printf "removed cap %d from capset %d" cp cs
        OsProcessPid cs pid ->
          printf "capset %d: pid %d" cs pid
        OsProcessParentPid cs ppid ->
          printf "capset %d: parent pid %d" cs ppid
        WallClockTime cs sec nsec ->
          printf "capset %d: wall clock time %ds %dns (unix epoch)" cs sec nsec
        RtsIdentifier cs i ->
          printf "capset %d: RTS version \"%s\"" cs i
        ProgramArgs cs args ->
          printf "capset %d: args: %s" cs (show args)
        ProgramEnv cs env ->
          printf "capset %d: env: %s" cs (show env)
        UnknownEvent n ->
          printf "Unknown event type %d" n
        InternString str sId ->
          printf "Interned string: \"%s\" with id %d" str sId
        MerStartParConjunction dyn_id static_id ->
          printf "Start a parallel conjunction 0x%x, static_id: %d" dyn_id static_id
        MerEndParConjunction dyn_id ->
          printf "End par conjunction: 0x%x" dyn_id
        MerEndParConjunct dyn_id ->
          printf "End par conjunct: 0x%x" dyn_id
        MerCreateSpark dyn_id spark_id ->
          printf "Create spark for conjunction: 0x%x spark: 0x%x" dyn_id spark_id
        MerFutureCreate future_id name_id ->
          printf "Create future 0x%x named %d" future_id name_id
        MerFutureWaitNosuspend future_id ->
          printf "Wait didn't suspend for future: 0x%x" future_id
        MerFutureWaitSuspended future_id ->
          printf "Wait suspended on future: 0x%x" future_id
        MerFutureSignal future_id ->
          printf "Signaled future 0x%x" future_id
        MerLookingForGlobalThread ->
          "Looking for global thread to resume"
        MerWorkStealing ->
          "Trying to steal a spark"
        MerLookingForLocalSpark ->
          "Looking for a local spark to execute"
        MerReleaseThread thread_id ->
          printf "Releasing thread %d to the free pool" thread_id
        MerCapSleeping ->
          "Capability going to sleep"
        MerCallingMain ->
          "About to call the program entry point"
        PerfName{perfNum, name} ->
          printf "perf event %d named \"%s\"" perfNum name
        PerfCounter{perfNum, tid, period} ->
          printf "perf event counter %d incremented by %d in OS thread %d"
                 perfNum (period + 1) (kernelThreadId tid)
        PerfTracepoint{perfNum, tid} ->
          printf "perf event tracepoint %d reached in OS thread %d"
                 perfNum (kernelThreadId tid)

showThreadStopStatus :: ThreadStopStatus -> String
showThreadStopStatus HeapOverflow   = "heap overflow"
showThreadStopStatus StackOverflow  = "stack overflow"
showThreadStopStatus ThreadYielding = "thread yielding"
showThreadStopStatus ThreadBlocked  = "thread blocked"
showThreadStopStatus ThreadFinished = "thread finished"
showThreadStopStatus ForeignCall    = "making a foreign call"
showThreadStopStatus BlockedOnMVar  = "blocked on an MVar"
showThreadStopStatus BlockedOnBlackHole = "blocked on a black hole"
showThreadStopStatus BlockedOnRead = "blocked on I/O read"
showThreadStopStatus BlockedOnWrite = "blocked on I/O write"
showThreadStopStatus BlockedOnDelay = "blocked on threadDelay"
showThreadStopStatus BlockedOnSTM = "blocked in STM retry"
showThreadStopStatus BlockedOnDoProc = "blocked on asyncDoProc"
showThreadStopStatus BlockedOnCCall = "blocked in a foreign call"
showThreadStopStatus BlockedOnCCall_NoUnblockExc = "blocked in a foreign call"
showThreadStopStatus BlockedOnMsgThrowTo = "blocked in throwTo"
showThreadStopStatus ThreadMigrating = "thread migrating"
showThreadStopStatus BlockedOnMsgGlobalise = "waiting for data to be globalised"
showThreadStopStatus (BlockedOnBlackHoleOwnedBy target) =
          "blocked on black hole owned by thread " ++ show target
showThreadStopStatus NoStatus = "No stop thread status"

ppEventLog :: EventLog -> String
ppEventLog (EventLog (Header ets) (Data es)) = unlines $ concat (
    [ ["Event Types:"]
    , map ppEventType ets
    , [""] -- newline
    , ["Events:"]
    , map (ppEvent imap) sorted
    , [""] ]) -- extra trailing newline
 where
    imap = buildEventTypeMap ets
    sorted = sortEvents es

ppEventType :: EventType -> String
ppEventType (EventType num dsc msz) = printf "%4d: %s (size %s)" num dsc
   (case msz of Nothing -> "variable"; Just x -> show x)

ppEvent :: IntMap EventType -> CapEvent -> String
ppEvent imap (CapEvent cap (Event time spec)) =
  printf "%9d: " time ++
  (case cap of
    Nothing -> ""
    Just c  -> printf "cap %d: " c) ++
  case spec of
    UnknownEvent{ ref=ref } ->
      printf (desc (fromJust (M.lookup (fromIntegral ref) imap)))

    other -> showEventInfo spec

type PutEvents a = PutM a

putE :: Binary a => a -> PutEvents ()
putE = put

runPutEBS :: PutEvents () -> L.ByteString
runPutEBS = runPut

writeEventLogToFile f el = L.writeFile f $ runPutEBS $ putEventLog el

putType :: EventTypeNum -> PutEvents ()
putType = putE

putCap :: Int -> PutEvents ()
putCap c = putE (fromIntegral c :: CapNo)

putMarker :: Word32 -> PutEvents ()
putMarker = putE

putEStr :: String -> PutEvents ()
putEStr = mapM_ putE

putEventLog :: EventLog -> PutEvents ()
putEventLog (EventLog hdr es) = do
    putHeader hdr
    putData es

putHeader :: Header -> PutEvents ()
putHeader (Header ets) = do
    putMarker EVENT_HEADER_BEGIN
    putMarker EVENT_HET_BEGIN
    mapM_ putEventType ets
    putMarker EVENT_HET_END
    putMarker EVENT_HEADER_END
 where
    putEventType (EventType n d msz) = do
        putMarker EVENT_ET_BEGIN
        putType n
        putE $ fromMaybe 0xffff msz
        putE (fromIntegral $ length d :: EventTypeDescLen)
        mapM_ put d
        -- the event type header allows for extra data, which we don't use:
        putE (0 :: Word32)
        putMarker EVENT_ET_END

putData :: Data -> PutEvents ()
putData (Data es) = do
  
    mapM_ putEvent es
    putType EVENT_DATA_END -- Word16

eventTypeNum :: EventInfo -> EventTypeNum
eventTypeNum e = case e of
    CreateThread {} -> EVENT_CREATE_THREAD
    RunThread {} -> EVENT_RUN_THREAD
    StopThread {} -> EVENT_STOP_THREAD
    ThreadRunnable {} -> EVENT_THREAD_RUNNABLE
    MigrateThread {} -> EVENT_MIGRATE_THREAD
    Shutdown {} -> EVENT_SHUTDOWN
    WakeupThread {} -> EVENT_THREAD_WAKEUP
    ThreadLabel {}  -> EVENT_THREAD_LABEL
    StartGC {} -> EVENT_GC_START
    EndGC {} -> EVENT_GC_END
    GlobalSyncGC {} -> EVENT_GC_GLOBAL_SYNC
    RequestSeqGC {} -> EVENT_REQUEST_SEQ_GC
    RequestParGC {} -> EVENT_REQUEST_PAR_GC
    CreateSparkThread {} -> EVENT_CREATE_SPARK_THREAD
    SparkCounters {} -> EVENT_SPARK_COUNTERS
    SparkCreate   {} -> EVENT_SPARK_CREATE
    SparkDud      {} -> EVENT_SPARK_DUD
    SparkOverflow {} -> EVENT_SPARK_OVERFLOW
    SparkRun      {} -> EVENT_SPARK_RUN
    SparkSteal    {} -> EVENT_SPARK_STEAL
    SparkFizzle   {} -> EVENT_SPARK_FIZZLE
    SparkGC       {} -> EVENT_SPARK_GC
    TaskCreate  {} -> EVENT_TASK_CREATE
    TaskMigrate {} -> EVENT_TASK_MIGRATE
    TaskDelete  {} -> EVENT_TASK_DELETE
    Message {} -> EVENT_LOG_MSG
    Startup {} -> EVENT_STARTUP
    EventBlock {} -> EVENT_BLOCK_MARKER
    UserMessage {} -> EVENT_USER_MSG
    UserMarker  {} -> EVENT_USER_MARKER
    GCIdle {} -> EVENT_GC_IDLE
    GCWork {} -> EVENT_GC_WORK
    GCDone {} -> EVENT_GC_DONE
    GCStatsGHC{} -> EVENT_GC_STATS_GHC
    HeapAllocated{} -> EVENT_HEAP_ALLOCATED
    HeapSize{} -> EVENT_HEAP_SIZE
    HeapLive{} -> EVENT_HEAP_LIVE
    HeapInfoGHC{} -> EVENT_HEAP_INFO_GHC
    CapCreate{} -> EVENT_CAP_CREATE
    CapDelete{} -> EVENT_CAP_DELETE
    CapDisable{} -> EVENT_CAP_DISABLE
    CapEnable{} -> EVENT_CAP_ENABLE
    CapsetCreate {} -> EVENT_CAPSET_CREATE
    CapsetDelete {} -> EVENT_CAPSET_DELETE
    CapsetAssignCap {} -> EVENT_CAPSET_ASSIGN_CAP
    CapsetRemoveCap {} -> EVENT_CAPSET_REMOVE_CAP
    RtsIdentifier {} -> EVENT_RTS_IDENTIFIER
    ProgramArgs {} -> EVENT_PROGRAM_ARGS
    ProgramEnv {} -> EVENT_PROGRAM_ENV
    OsProcessPid {} -> EVENT_OSPROCESS_PID
    OsProcessParentPid{} -> EVENT_OSPROCESS_PPID
    WallClockTime{} -> EVENT_WALL_CLOCK_TIME
    UnknownEvent {} -> error "eventTypeNum UnknownEvent"
    InternString {} -> EVENT_INTERN_STRING
    MerStartParConjunction {} -> EVENT_MER_START_PAR_CONJUNCTION
    MerEndParConjunction _ -> EVENT_MER_STOP_PAR_CONJUNCTION
    MerEndParConjunct _ -> EVENT_MER_STOP_PAR_CONJUNCT
    MerCreateSpark {} -> EVENT_MER_CREATE_SPARK
    MerFutureCreate {} -> EVENT_MER_FUT_CREATE
    MerFutureWaitNosuspend _ -> EVENT_MER_FUT_WAIT_NOSUSPEND
    MerFutureWaitSuspended _ -> EVENT_MER_FUT_WAIT_SUSPENDED
    MerFutureSignal _ -> EVENT_MER_FUT_SIGNAL
    MerLookingForGlobalThread -> EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT
    MerWorkStealing -> EVENT_MER_WORK_STEALING
    MerLookingForLocalSpark -> EVENT_MER_LOOKING_FOR_LOCAL_SPARK
    MerReleaseThread _ -> EVENT_MER_RELEASE_CONTEXT
    MerCapSleeping -> EVENT_MER_ENGINE_SLEEPING
    MerCallingMain -> EVENT_MER_CALLING_MAIN
    PerfName       {} -> nEVENT_PERF_NAME
    PerfCounter    {} -> nEVENT_PERF_COUNTER
    PerfTracepoint {} -> nEVENT_PERF_TRACEPOINT

nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT :: EventTypeNum
nEVENT_PERF_NAME = EVENT_PERF_NAME
nEVENT_PERF_COUNTER = EVENT_PERF_COUNTER
nEVENT_PERF_TRACEPOINT = EVENT_PERF_TRACEPOINT

putEvent :: Event -> PutEvents ()
putEvent (Event t spec) = do
    putType (eventTypeNum spec)
    put t
    putEventSpec spec

putEventSpec (Startup caps) = do
    putCap (fromIntegral caps)

putEventSpec (EventBlock end cap es) = do
    let block = runPutEBS (mapM_ putEvent es)
    put (fromIntegral (L.length block) + 24 :: Word32)
    putE end
    putE (fromIntegral cap :: CapNo)
    putLazyByteString block

putEventSpec (CreateThread t) = do
    putE t

putEventSpec (RunThread t) = do
    putE t

-- here we assume that ThreadStopStatus fromEnum matches the definitions in
  
putEventSpec (StopThread t s) = do
    putE t
    putE $ case s of
            NoStatus -> 0 :: Word16
            HeapOverflow -> 1
            StackOverflow -> 2
            ThreadYielding -> 3
            ThreadBlocked -> 4
            ThreadFinished -> 5
            ForeignCall -> 6
            BlockedOnMVar -> 7
            BlockedOnBlackHole -> 8
            BlockedOnBlackHoleOwnedBy _ -> 8
            BlockedOnRead -> 9
            BlockedOnWrite -> 10
            BlockedOnDelay -> 11
            BlockedOnSTM -> 12
            BlockedOnDoProc -> 13
            BlockedOnCCall -> 14
            BlockedOnCCall_NoUnblockExc -> 15
            BlockedOnMsgThrowTo -> 16
            ThreadMigrating -> 17
            BlockedOnMsgGlobalise -> 18
    putE $ case s of
            BlockedOnBlackHoleOwnedBy i -> i
            _                           -> 0

putEventSpec (ThreadRunnable t) = do
    putE t

putEventSpec (MigrateThread t c) = do
    putE t
    putCap c

putEventSpec (CreateSparkThread t) = do
    putE t

putEventSpec (SparkCounters crt dud ovf cnv fiz gcd rem) = do
    putE crt
    putE dud
    putE ovf
    putE cnv
  Warning : order of fiz and gcd reversed !
    putE gcd
    putE fiz
    putE rem

putEventSpec SparkCreate = do
    return ()

putEventSpec SparkDud = do
    return ()

putEventSpec SparkOverflow = do
    return ()

putEventSpec SparkRun = do
    return ()

putEventSpec (SparkSteal c) = do
    putCap c

putEventSpec SparkFizzle = do
    return ()

putEventSpec SparkGC = do
    return ()

putEventSpec (WakeupThread t c) = do
    putE t
    putCap c

putEventSpec (ThreadLabel t l) = do
    putE (fromIntegral (length l) + sz_tid :: Word16)
    putE t
    putEStr l

putEventSpec Shutdown = do
    return ()

putEventSpec RequestSeqGC = do
    return ()

putEventSpec RequestParGC = do
    return ()

putEventSpec StartGC = do
    return ()

putEventSpec GCWork = do
    return ()

putEventSpec GCIdle = do
    return ()

putEventSpec GCDone = do
    return ()

putEventSpec EndGC = do
    return ()

putEventSpec GlobalSyncGC = do
    return ()

putEventSpec (TaskCreate taskId cap tid) = do
    putE taskId
    putCap cap
    putE tid

putEventSpec (TaskMigrate taskId cap new_cap) = do
    putE taskId
    putCap cap
    putCap new_cap

putEventSpec (TaskDelete taskId) = do
    putE taskId

putEventSpec GCStatsGHC{..} = do
    putE heapCapset
    putE (fromIntegral gen :: Word16)
    putE copied
    putE slop
    putE frag
    putE (fromIntegral parNThreads :: Word32)
    putE parMaxCopied
    putE parTotCopied

putEventSpec HeapAllocated{..} = do
    putE heapCapset
    putE allocBytes

putEventSpec HeapSize{..} = do
    putE heapCapset
    putE sizeBytes

putEventSpec HeapLive{..} = do
    putE heapCapset
    putE liveBytes

putEventSpec HeapInfoGHC{..} = do
    putE heapCapset
    putE (fromIntegral gens :: Word16)
    putE maxHeapSize
    putE allocAreaSize
    putE mblockSize
    putE blockSize

putEventSpec CapCreate{cap} = do
    putCap cap

putEventSpec CapDelete{cap} = do
    putCap cap

putEventSpec CapDisable{cap} = do
    putCap cap

putEventSpec CapEnable{cap} = do
    putCap cap

putEventSpec (CapsetCreate cs ct) = do
    putE cs
    putE $ case ct of
            CapsetCustom -> 1 :: Word16
            CapsetOsProcess -> 2
            CapsetClockDomain -> 3
            CapsetUnknown -> 0

putEventSpec (CapsetDelete cs) = do
    putE cs

putEventSpec (CapsetAssignCap cs cp) = do
    putE cs
    putCap cp

putEventSpec (CapsetRemoveCap cs cp) = do
    putE cs
    putCap cp

putEventSpec (RtsIdentifier cs rts) = do
    putE (fromIntegral (length rts) + sz_capset :: Word16)
    putE cs
    putEStr rts

putEventSpec (ProgramArgs cs as) = do
    let as' = unsep as
    putE (fromIntegral (length as') + sz_capset :: Word16)
    putE cs
    mapM_ putE as'

putEventSpec (ProgramEnv cs es) = do
    let es' = unsep es
    putE (fromIntegral (length es') + sz_capset :: Word16)
    putE cs
    mapM_ putE es'

putEventSpec (OsProcessPid cs pid) = do
    putE cs
    putE pid

putEventSpec (OsProcessParentPid cs ppid) = do
    putE cs
    putE ppid

putEventSpec (WallClockTime cs sec nsec) = do
    putE cs
    putE sec
    putE nsec

putEventSpec (Message s) = do
    putE (fromIntegral (length s) :: Word16)
    mapM_ putE s

putEventSpec (UserMessage s) = do
    putE (fromIntegral (length s) :: Word16)
    mapM_ putE s

putEventSpec (UserMarker s) = do
    putE (fromIntegral (length s) :: Word16)
    mapM_ putE s

putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent"

putEventSpec (InternString str id) = do
    putE len
    mapM_ putE str
    putE id
  where len = (fromIntegral (length str) :: Word16) + sz_string_id

putEventSpec (MerStartParConjunction dyn_id static_id) = do
    putE dyn_id
    putE static_id

putEventSpec (MerEndParConjunction dyn_id) = do
    putE dyn_id

putEventSpec (MerEndParConjunct dyn_id) = do
    putE dyn_id

putEventSpec (MerCreateSpark dyn_id spark_id) = do
    putE dyn_id
    putE spark_id

putEventSpec (MerFutureCreate future_id name_id) = do
    putE future_id
    putE name_id

putEventSpec (MerFutureWaitNosuspend future_id) = do
    putE future_id

putEventSpec (MerFutureWaitSuspended future_id) = do
    putE future_id

putEventSpec (MerFutureSignal future_id) = do
    putE future_id

putEventSpec MerLookingForGlobalThread = return ()
putEventSpec MerWorkStealing = return ()
putEventSpec MerLookingForLocalSpark = return ()

putEventSpec (MerReleaseThread thread_id) = do
    putE thread_id

putEventSpec MerCapSleeping = return ()
putEventSpec MerCallingMain = return ()

putEventSpec PerfName{..} = do
    putE (fromIntegral (length name) + sz_perf_num :: Word16)
    putE perfNum
    mapM_ putE name

putEventSpec PerfCounter{..} = do
    putE perfNum
    putE tid
    putE period

putEventSpec PerfTracepoint{..} = do
    putE perfNum
    putE tid

-- [] == []
-- [x] == x\0
-- [x, y, z] == x\0y\0
unsep :: [String] -> String
unsep = concatMap (++"\0") -- not the most efficient, but should be ok

splitNull :: String -> [String]
splitNull [] = []
splitNull xs = case span (/= '\0') xs of
                (x, xs') -> x : splitNull (drop 1 xs')

# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns -fno-warn-deprecations #
 * The event log types
 * Reading and writing event logs
 * Utilities
 * Printing
 * Perf events
 Libraries. 
----------------------------------------------------------------------------
 Binary instances
 0xffff indicates variable-sized event
 trace ("event: " ++ show etRef) $ do

 standardEventParsers.

 (size, end_time, cap)
 no longer generate the event; should be removed at some point
 (cap)
 (cap)
 (cap)
 (cap)
 (capset, capset_type)
 (capset)
 (capset, cap)
 (capset, cap)
 (capset, pid)
 (capset, ppid)
 (capset, unix_epoch_seconds, nanoseconds)
 (msg)
 (msg)
 (capset, [arg])
 (capset, [arg])
 (capset, str)
 (thread)
  (thread)
 (thread, status)
 (thread, status, info)
 XXX yeuch 
 (thread)
 (thread)
 (thread, victimCap)
 (victimCap)
 (taskID, cap, new_cap)
 (taskID)
---------------------
 so we have to recognise those wrong sizes here for backwards
 compatibility.
 declared as size 0, so we accept it here.
 (thread)
  (thread)
 (thread, status)
 (thread)
 specially here otherwise we'll get the wrong size, leading to us getting
 out of sync and eventual parse failure. Since we're parsing them anyway,
 (thread)
 (thread, victimCap)
 (perf_num, name)
 (perf_num, tid, period)
 (perf_num, tid)
 in
 This test is complete, no-one has extended this event yet and all future
 extensions will use newly allocated event IDs.
 GHC6 writes an invalid header , we handle it here by using a 
 different set of event parsers .   Note that the ghc7 event parsers 
 are standard events , and can be used by other runtime systems that 
 make use of threadscope . 
 GHC6 writes an invalid header, we handle it here by using a
 different set of event parsers.  Note that the ghc7 event parsers
 are standard events, and can be used by other runtime systems that
 make use of threadscope.
 -----------------------------------------------------------------------------
 | Sort the raw event stream by time, annotating each event with the
 capability that generated it.
 sorting is made much faster by the way that the event stream is
 divided into blocks of events.
  - All events in a block belong to a particular capability
  - The events in a block are ordered by time
  - blocks for the same capability appear in time order in the event
    stream and do not overlap.

 capability (basically just concat . filter), and then
 merge the resulting lists.
 In light of merged logs, global blocks may have overlapping
---------------------------------------------------------------------------
 Some pretty-printing support
 newline
 extra trailing newline
 the event type header allows for extra data, which we don't use:
 Word16
 here we assume that ThreadStopStatus fromEnum matches the definitions in
 [] == []
 [x] == x\0
 [x, y, z] == x\0y\0
 not the most efficient, but should be ok
# LANGUAGE CPP , BangPatterns , PatternGuards #

  -    Parser functions for GHC RTS EventLog framework . 
 
 -   Parser functions for GHC RTS EventLog framework.
 -}

module GHC.RTS.Events (
       main,
       EventLog(..),
       EventType(..),
       Event(..),
       EventInfo(..),
       ThreadStopStatus(..),
       Header(..),
       Data(..),
       CapsetType(..),
       Timestamp,
       ThreadId,
       TaskId,
       KernelThreadId(..),

       readEventLogFromFile,
       writeEventLogToFile,

       CapEvent(..), sortEvents, groupEvents, sortGroups,
       buildEventTypeMap,

       showEventInfo, showThreadStopStatus,
       ppEventLog, ppEventType, ppEvent,

       nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT,
       sz_perf_num, sz_kernel_tid
  ) where

import Data.Binary
import Data.Binary.Get hiding (skip)
import qualified Data.Binary.Get as G
import Data.Binary.Put
import Control.Monad
import Data.IntMap (IntMap)
import qualified Data.IntMap as M
import Control.Monad.Reader
import Control.Monad.Error
import qualified Data.ByteString.Lazy as L
import Data.Function
import Data.List
import Data.Either
import Data.Maybe
import Text.Printf
import Data.Array

import GHC.RTS.EventTypes
import GHC.RTS.EventParserUtils

#define EVENTLOG_CONSTANTS_ONLY
#include "EventLogFormat.h"

main :: IO ()
main = return ()


getEventType :: GetHeader EventType
getEventType = do
           etNum <- getH
           size <- getH :: GetHeader EventTypeSize
           let etSize = if size == 0xffff then Nothing else Just size
           etDescLen <- getH :: GetHeader EventTypeDescLen
           etDesc <- getEtDesc (fromIntegral etDescLen)
           etExtraLen <- getH :: GetHeader Word32
           lift $ G.skip (fromIntegral etExtraLen)
           ete <- getH :: GetHeader Marker
           when (ete /= EVENT_ET_END) $
              throwError ("Event Type end marker not found.")
           return (EventType etNum etDesc etSize)
           where
             getEtDesc :: Int -> GetHeader [Char]
             getEtDesc s = replicateM s (getH :: GetHeader Char)

getHeader :: GetHeader Header
getHeader = do
           hdrb <- getH :: GetHeader Marker
           when (hdrb /= EVENT_HEADER_BEGIN) $
                throwError "Header begin marker not found"
           hetm <- getH :: GetHeader Marker
           when (hetm /= EVENT_HET_BEGIN) $
                throwError "Header Event Type begin marker not found"
           ets <- getEventTypes
           emark <- getH :: GetHeader Marker
           when (emark /= EVENT_HEADER_END) $
                throwError "Header end marker not found"
           return (Header ets)
     where
       getEventTypes :: GetHeader [EventType]
       getEventTypes = do
           m <- getH :: GetHeader Marker
           case () of
            _ | m == EVENT_ET_BEGIN -> do
                   et <- getEventType
                   nextET <- getEventTypes
                   return (et : nextET)
              | m == EVENT_HET_END ->
                   return []
              | otherwise ->
                   throwError "Malformed list of Event Types in header"

getEvent :: EventParsers -> GetEvents (Maybe Event)
getEvent (EventParsers parsers) = do
  etRef <- getE :: GetEvents EventTypeNum
  if (etRef == EVENT_DATA_END)
     then return Nothing
     else do !ts   <- getE
             spec <- parsers ! fromIntegral etRef
             return (Just (Event ts spec))

standardParsers :: [EventParser EventInfo]
standardParsers = [
  ( n_caps )
      c <- getE :: GetEvents CapNo
      return Startup{ n_caps = fromIntegral c }
   )),

      block_size <- getE :: GetEvents BlockSize
      end_time <- getE :: GetEvents Timestamp
      c <- getE :: GetEvents CapNo
      lbs <- lift . lift $ getLazyByteString ((fromIntegral block_size) -
                                              (fromIntegral sz_block_event))
      eparsers <- ask
      let e_events = runGet (runErrorT $ runReaderT (getEventBlock eparsers) eparsers) lbs
      return EventBlock{ end_time=end_time,
                         cap= fromIntegral c,
                         block_events=case e_events of
                                        Left s -> error s
                                        Right es -> es }
   )),

  EVENT_SHUTDOWN is replaced by EVENT_CAP_DELETE and GHC 7.6 +
 (simpleEvent EVENT_SHUTDOWN Shutdown),

 (simpleEvent EVENT_REQUEST_SEQ_GC RequestSeqGC),

 (simpleEvent EVENT_REQUEST_PAR_GC RequestParGC),

 (simpleEvent EVENT_GC_START StartGC),

 (simpleEvent EVENT_GC_WORK GCWork),

 (simpleEvent EVENT_GC_IDLE GCIdle),

 (simpleEvent EVENT_GC_DONE GCDone),

 (simpleEvent EVENT_GC_END EndGC),

 (simpleEvent EVENT_GC_GLOBAL_SYNC GlobalSyncGC),

  ( heap_capset , generation , copied_bytes , slop_bytes , frag_bytes , par_n_threads , par_max_copied , par_tot_copied )
      heapCapset   <- getE
      gen          <- getE :: GetEvents Word16
      copied       <- getE :: GetEvents Word64
      slop         <- getE :: GetEvents Word64
      frag         <- getE :: GetEvents Word64
      parNThreads  <- getE :: GetEvents Word32
      parMaxCopied <- getE :: GetEvents Word64
      parTotCopied <- getE :: GetEvents Word64
      return GCStatsGHC{ gen = fromIntegral gen
                       , parNThreads = fromIntegral parNThreads
                       , ..}
 )),

  ( heap_capset , alloc_bytes )
      heapCapset <- getE
      allocBytes <- getE
      return HeapAllocated{..}
 )),

  ( heap_capset , size_bytes )
      heapCapset <- getE
      sizeBytes  <- getE
      return HeapSize{..}
 )),

  ( heap_capset , live_bytes )
      heapCapset <- getE
      liveBytes  <- getE
      return HeapLive{..}
 )),

  ( heap_capset , n_generations , max_heap_size , alloc_area_size , mblock_size , block_size )
      heapCapset    <- getE
      gens          <- getE :: GetEvents Word16
      maxHeapSize   <- getE :: GetEvents Word64
      allocAreaSize <- getE :: GetEvents Word64
      mblockSize    <- getE :: GetEvents Word64
      blockSize     <- getE :: GetEvents Word64
      return HeapInfoGHC{gens = fromIntegral gens, ..}
 )),

      cap <- getE :: GetEvents CapNo
      return CapCreate{cap = fromIntegral cap}
 )),

      cap <- getE :: GetEvents CapNo
      return CapDelete{cap = fromIntegral cap}
 )),

      cap <- getE :: GetEvents CapNo
      return CapDisable{cap = fromIntegral cap}
 )),

      cap <- getE :: GetEvents CapNo
      return CapEnable{cap = fromIntegral cap}
 )),

      cs <- getE
      ct <- fmap mkCapsetType getE
      return CapsetCreate{capset=cs,capsetType=ct}
   )),

      cs <- getE
      return CapsetDelete{capset=cs}
   )),

      cs <- getE
      cp <- getE :: GetEvents CapNo
      return CapsetAssignCap{capset=cs,cap=fromIntegral cp}
   )),

      cs <- getE
      cp <- getE :: GetEvents CapNo
      return CapsetRemoveCap{capset=cs,cap=fromIntegral cp}
   )),

      cs <- getE
      pd <- getE
      return OsProcessPid{capset=cs,pid=pd}
   )),

      cs <- getE
      pd <- getE
      return OsProcessParentPid{capset=cs,ppid=pd}
  )),

      cs <- getE
      s  <- getE
      ns <- getE
      return WallClockTime{capset=cs,sec=s,nsec=ns}
  )),

      num <- getE :: GetEvents Word16
      string <- getString num
      return Message{ msg = string }
   )),
      num <- getE :: GetEvents Word16
      string <- getString num
      return UserMessage{ msg = string }
   )),
  (  )
      num <- getE :: GetEvents Word16
      string <- getString num
      return UserMarker{ markername = string }
   )),
      num <- getE :: GetEvents Word16
      cs <- getE
      string <- getString (num - sz_capset)
      return ProgramArgs{ capset = cs
                        , args = splitNull string }
   )),
      num <- getE :: GetEvents Word16
      cs <- getE
      string <- getString (num - sz_capset)
      return ProgramEnv{ capset = cs
                       , env = splitNull string }
   )),
      num <- getE :: GetEvents Word16
      cs <- getE
      string <- getString (num - sz_capset)
      return RtsIdentifier{ capset = cs
                          , rtsident = string }
   )),

  ( str , i d )
      num <- getE :: GetEvents Word16
      string <- getString (num - sz_string_id)
      sId <- getE :: GetEvents StringId
      return (InternString string sId)
    )),

  ( thread ,  )
      num <- getE :: GetEvents Word16
      tid <- getE
      str <- getString (num - sz_tid)
      return ThreadLabel{ thread      = tid
                        , threadlabel = str }
    ))
 ]

  Parsers valid for GHC7 but not GHC6 .
ghc7Parsers :: [EventParser EventInfo]
ghc7Parsers = [
      t <- getE
      return CreateThread{thread=t}
   )),

      t <- getE
      return RunThread{thread=t}
   )),

 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status) (do
      t <- getE
      s <- getE :: GetEvents RawThreadStopStatus
      return StopThread{thread=t, status = if s > maxThreadStopStatus
                                              then NoStatus
                                              else mkStopStatus s}
   )),

 (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do
      t <- getE
      s <- getE :: GetEvents RawThreadStopStatus
      i <- getE :: GetEvents ThreadId
      return StopThread{thread = t,
                        status = case () of
                                  _ | s > maxThreadStopStatus
                                    -> NoStatus
                                    -> BlockedOnBlackHoleOwnedBy i
                                    | otherwise
                                    -> mkStopStatus s}
   )),

      t <- getE
      return ThreadRunnable{thread=t}
   )),

   ( thread ,  )
      t  <- getE
      nc <- getE :: GetEvents CapNo
      return MigrateThread{thread=t,newCap=fromIntegral nc}
   )),

  Yes , EVENT_RUN / STEAL_SPARK are deprecated , but see the explanation in the
  ' ghc6Parsers ' section below . Since we 're parsing them anyway , we might
  as well convert them to the new SparkRun / SparkSteal events .
      _ <- getE :: GetEvents ThreadId
      return SparkRun
   )),

      _  <- getE :: GetEvents ThreadId
      vc <- getE :: GetEvents CapNo
      return SparkSteal{victimCap=fromIntegral vc}
   )),

  ( sparkThread )
      st <- getE :: GetEvents ThreadId
      return CreateSparkThread{sparkThread=st}
   )),

  (  , dud , ovf , cnv , gcd , fiz , rem )
      crt <- getE :: GetEvents Word64
      dud <- getE :: GetEvents Word64
      ovf <- getE :: GetEvents Word64
      cnv <- getE :: GetEvents Word64
      gcd <- getE :: GetEvents Word64
      fiz <- getE :: GetEvents Word64
      rem <- getE :: GetEvents Word64
      return SparkCounters{sparksCreated    = crt, sparksDud       = dud,
                           sparksOverflowed = ovf, sparksConverted = cnv,
  Warning : order of fiz and gcd reversed !
                           sparksFizzled    = fiz, sparksGCd       = gcd,
                           sparksRemaining  = rem}
   )),

 (simpleEvent EVENT_SPARK_CREATE   SparkCreate),
 (simpleEvent EVENT_SPARK_DUD      SparkDud),
 (simpleEvent EVENT_SPARK_OVERFLOW SparkOverflow),
 (simpleEvent EVENT_SPARK_RUN      SparkRun),
      vc <- getE :: GetEvents CapNo
      return SparkSteal{victimCap=fromIntegral vc}
   )),
 (simpleEvent EVENT_SPARK_FIZZLE   SparkFizzle),
 (simpleEvent EVENT_SPARK_GC       SparkGC),

  ( taskID , cap , tid )
      taskId <- getE :: GetEvents TaskId
      cap    <- getE :: GetEvents CapNo
      tid    <- getE :: GetEvents KernelThreadId
      return TaskCreate{ taskId, cap = fromIntegral cap, tid }
   )),
      taskId  <- getE :: GetEvents TaskId
      cap     <- getE :: GetEvents CapNo
      new_cap <- getE :: GetEvents CapNo
      return TaskMigrate{ taskId, cap = fromIntegral cap
                                , new_cap = fromIntegral new_cap
                        }
   )),
      taskId <- getE :: GetEvents TaskId
      return TaskDelete{ taskId }
   )),

  ( thread ,  )
      t <- getE
      oc <- getE :: GetEvents CapNo
      return WakeupThread{thread=t,otherCap=fromIntegral oc}
   ))
 ]

  GHC 6.12 compat : GHC 6.12 reported the wrong sizes for some events ,
ghc6Parsers :: [EventParser EventInfo]
ghc6Parsers = [
 (FixedSizeParser EVENT_STARTUP 0 (do
  BUG in GHC 6.12 : the startup event was incorrectly
      c <- getE :: GetEvents CapNo
      return Startup{ n_caps = fromIntegral c }
   )),

      t <- getE
      return CreateThread{thread=t}
   )),

      t <- getE
      return RunThread{thread=t}
   )),

      t <- getE
      s <- getE :: GetEvents Word16
      let stat = fromIntegral s
      return StopThread{thread=t, status = if stat > maxBound
                                              then NoStatus
                                              else mkStopStatus stat}
   )),

      t <- getE
      return ThreadRunnable{thread=t}
   )),

   ( thread ,  )
      t  <- getE
      nc <- getE :: GetEvents CapNo
      return MigrateThread{thread=t,newCap=fromIntegral nc}
   )),

  Note : it is vital that these two ( EVENT_RUN / STEAL_SPARK ) remain here ( at
  least in the ghc6Parsers section ) even though both events are deprecated .
  The reason is that .eventlog files created by the buggy GHC-6.12
  mis - declare the size of these two events . So we have to handle them
  we might as well convert them to the new SparkRun / SparkSteal events .
      _ <- getE :: GetEvents ThreadId
      return SparkRun
   )),

      _  <- getE :: GetEvents ThreadId
      vc <- getE :: GetEvents CapNo
      return SparkSteal{victimCap=fromIntegral vc}
   )),

  ( sparkThread )
      st <- getE :: GetEvents ThreadId
      return CreateSparkThread{sparkThread=st}
   )),

  ( thread ,  )
      t <- getE
      oc <- getE :: GetEvents CapNo
      return WakeupThread{thread=t,otherCap=fromIntegral oc}
   ))
 ]

mercuryParsers = [
 (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION
    (sz_par_conj_dyn_id + sz_par_conj_static_id)
    (do dyn_id <- getE
        static_id <- getE
        return (MerStartParConjunction dyn_id static_id))
 ),

 (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCTION sz_par_conj_dyn_id
    (do dyn_id <- getE
        return (MerEndParConjunction dyn_id))
 ),

 (FixedSizeParser EVENT_MER_STOP_PAR_CONJUNCT sz_par_conj_dyn_id
    (do dyn_id <- getE
        return (MerEndParConjunct dyn_id))
 ),

 (FixedSizeParser EVENT_MER_CREATE_SPARK (sz_par_conj_dyn_id + sz_spark_id)
    (do dyn_id <- getE
        spark_id <- getE
        return (MerCreateSpark dyn_id spark_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_CREATE (sz_future_id + sz_string_id)
    (do future_id <- getE
        name_id <- getE
        return (MerFutureCreate future_id name_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_WAIT_NOSUSPEND (sz_future_id)
    (do future_id <- getE
        return (MerFutureWaitNosuspend future_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_WAIT_SUSPENDED (sz_future_id)
    (do future_id <- getE
        return (MerFutureWaitSuspended future_id))
 ),

 (FixedSizeParser EVENT_MER_FUT_SIGNAL (sz_future_id)
    (do future_id <- getE
        return (MerFutureSignal future_id))
 ),

 (simpleEvent EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT MerLookingForGlobalThread),
 (simpleEvent EVENT_MER_WORK_STEALING MerWorkStealing),
 (simpleEvent EVENT_MER_LOOKING_FOR_LOCAL_SPARK MerLookingForLocalSpark),

 (FixedSizeParser EVENT_MER_RELEASE_CONTEXT sz_tid
    (do thread_id <- getE
        return (MerReleaseThread thread_id))
 ),

 (simpleEvent EVENT_MER_ENGINE_SLEEPING MerCapSleeping),
 (simpleEvent EVENT_MER_CALLING_MAIN MerCallingMain)

 ]

perfParsers = [
      num     <- getE :: GetEvents Word16
      perfNum <- getE
      name    <- getString (num - sz_perf_num)
      return PerfName{perfNum, name}
   )),

      perfNum <- getE
      tid     <- getE
      period  <- getE
      return PerfCounter{perfNum, tid, period}
  )),

      perfNum <- getE
      tid     <- getE
      return PerfTracepoint{perfNum, tid}
  ))
 ]

getData :: GetEvents Data
getData = do
   db <- getE :: GetEvents Marker
   when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found"
   eparsers <- ask
   let
       getEvents :: [Event] -> GetEvents Data
       getEvents events = do
         mb_e <- getEvent eparsers
         case mb_e of
           Nothing -> return (Data (reverse events))
           Just e  -> getEvents (e:events)
   getEvents []

getEventBlock :: EventParsers -> GetEvents [Event]
getEventBlock parsers = do
  b <- lift . lift $ isEmpty
  if b then return [] else do
   mb_e <- getEvent parsers
   case mb_e of
     Nothing -> return []
     Just e  -> do
       es <- getEventBlock parsers
       return (e:es)

getEventLog :: ErrorT String Get EventLog
getEventLog = do
    header <- getHeader
    let imap = M.fromList [ (fromIntegral (num t),t) | t <- eventTypes header]
        is_ghc_6 = Just sz_old_tid == do create_et <- M.lookup EVENT_CREATE_THREAD imap
                                         size create_et

        
        -}
        event_parsers = if is_ghc_6
                            then standardParsers ++ ghc6Parsers
                            else standardParsers ++ ghc7Parsers
                                 ++ mercuryParsers ++ perfParsers
        parsers = mkEventTypeParsers imap event_parsers
    dat <- runReaderT getData (EventParsers parsers)
    return (EventLog header dat)

readEventLogFromFile :: FilePath -> IO (Either String EventLog)
readEventLogFromFile f = do
    s <- L.readFile f
    return $ runGet (do v <- runErrorT $ getEventLog
                        m <- isEmpty
                        m `seq` return v)  s

  Utilities

sortEvents :: [Event] -> [CapEvent]
sortEvents = sortGroups . groupEvents

sortGroups :: [(Maybe Int, [Event])] -> [CapEvent]
sortGroups groups = mergesort' (compare `on` (time . ce_event)) $
                      [ [ CapEvent cap e | e <- es ]
                      | (cap, es) <- groups ]
  So to sort the events we make one list of events for each

groupEvents :: [Event] -> [(Maybe Int, [Event])]
groupEvents es = (Nothing, n_events) :
                 [ (Just (cap (head blocks)), concatMap block_events blocks)
                 | blocks <- groups ]
  where
   (blocks, anon_events) = partitionEithers (map separate es)
      where separate e | b@EventBlock{} <- spec e = Left  b
                       | otherwise                = Right e

   (cap_blocks, gbl_blocks) = partition (is_cap . cap) blocks
      where is_cap c = fromIntegral c /= ((-1) :: Word16)

   groups = groupBy ((==) `on` cap) $ sortBy (compare `on` cap) cap_blocks

  There are two sources of events without a capability : events
  in the raw stream not inside an EventBlock , and EventBlocks
  with cap = = -1 .   We have to merge those two streams .
  time spans , thus the blocks are mergesorted
   n_events = mergesort' (compare `on` time) (anon_events : map block_events gbl_blocks)

mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]
mergesort' _   [] = []
mergesort' _   [xs] = xs
mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)

merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]
merge_pairs _   [] = []
merge_pairs _   [xs] = [xs]
merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss

merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
merge _   [] ys = ys
merge _   xs [] = xs
merge cmp (x:xs) (y:ys)
 = case x `cmp` y of
        GT -> y : merge cmp (x:xs)   ys
        _  -> x : merge cmp    xs (y:ys)


buildEventTypeMap :: [EventType] -> IntMap EventType
buildEventTypeMap etypes = M.fromList [ (fromIntegral (num t),t) | t <- etypes ]


showEventInfo :: EventInfo -> String
showEventInfo spec =
    case spec of
        EventBlock end_time cap _block_events ->
          printf "event block: cap %d, end time: %d\n" cap end_time
        Startup n_caps ->
          printf "startup: %d capabilities" n_caps
        CreateThread thread ->
          printf "creating thread %d" thread
        RunThread thread ->
          printf "running thread %d" thread
        StopThread thread status ->
          printf "stopping thread %d (%s)" thread (showThreadStopStatus status)
        ThreadRunnable thread ->
          printf "thread %d is runnable" thread
        MigrateThread thread newCap  ->
          printf "migrating thread %d to cap %d" thread newCap
        CreateSparkThread sparkThread ->
          printf "creating spark thread %d" sparkThread
        SparkCounters crt dud ovf cnv fiz gcd rem ->
          printf "spark stats: %d created, %d converted, %d remaining (%d overflowed, %d dud, %d GC'd, %d fizzled)" crt cnv rem ovf dud gcd fiz
        SparkCreate ->
          printf "spark created"
        SparkDud ->
          printf "dud spark discarded"
        SparkOverflow ->
          printf "overflowed spark discarded"
        SparkRun ->
          printf "running a local spark"
        SparkSteal victimCap ->
          printf "stealing a spark from cap %d" victimCap
        SparkFizzle ->
          printf "spark fizzled"
        SparkGC ->
          printf "spark GCed"
        TaskCreate taskId cap tid ->
          printf "task 0x%x created on cap %d with OS kernel thread %d"
                 taskId cap (kernelThreadId tid)
        TaskMigrate taskId cap new_cap ->
          printf "task 0x%x migrated from cap %d to cap %d"
                 taskId cap new_cap
        TaskDelete taskId ->
          printf "task 0x%x deleted" taskId
        Shutdown ->
          printf "shutting down"
        WakeupThread thread otherCap ->
          printf "waking up thread %d on cap %d" thread otherCap
        ThreadLabel thread label ->
          printf "thread %d has label \"%s\"" thread label
        RequestSeqGC ->
          printf "requesting sequential GC"
        RequestParGC ->
          printf "requesting parallel GC"
        StartGC ->
          printf "starting GC"
        EndGC ->
          printf "finished GC"
        GCWork ->
          printf "GC working"
        GCIdle ->
          printf "GC idle"
        GCDone ->
          printf "GC done"
        GlobalSyncGC ->
          printf "all caps stopped for GC"
        GCStatsGHC{..} ->
          printf "GC stats for heap capset %d: generation %d, %d bytes copied, %d bytes slop, %d bytes fragmentation, %d par threads, %d bytes max par copied, %d bytes total par copied" heapCapset gen copied slop frag parNThreads parMaxCopied parTotCopied
        HeapAllocated{..} ->
          printf "allocated on heap capset %d: %d total bytes till now" heapCapset allocBytes
        HeapSize{..} ->
          printf "size of heap capset %d: %d bytes" heapCapset sizeBytes
        HeapLive{..} ->
          printf "live data in heap capset %d: %d bytes" heapCapset liveBytes
        HeapInfoGHC{..} ->
          printf "heap stats for heap capset %d: generations %d, %d bytes max heap size, %d bytes alloc area size, %d bytes mblock size, %d bytes block size" heapCapset gens maxHeapSize allocAreaSize mblockSize blockSize
        CapCreate{cap} ->
          printf "created cap %d" cap
        CapDelete{cap} ->
          printf "deleted cap %d" cap
        CapDisable{cap} ->
          printf "disabled cap %d" cap
        CapEnable{cap} ->
          printf "enabled cap %d" cap
        Message msg ->
          msg
        UserMessage msg ->
          msg
        UserMarker markername ->
          printf "marker: %s" markername
        CapsetCreate cs ct ->
          printf "created capset %d of type %s" cs (show ct)
        CapsetDelete cs ->
          printf "deleted capset %d" cs
        CapsetAssignCap cs cp ->
          printf "assigned cap %d to capset %d" cp cs
        CapsetRemoveCap cs cp ->
          printf "removed cap %d from capset %d" cp cs
        OsProcessPid cs pid ->
          printf "capset %d: pid %d" cs pid
        OsProcessParentPid cs ppid ->
          printf "capset %d: parent pid %d" cs ppid
        WallClockTime cs sec nsec ->
          printf "capset %d: wall clock time %ds %dns (unix epoch)" cs sec nsec
        RtsIdentifier cs i ->
          printf "capset %d: RTS version \"%s\"" cs i
        ProgramArgs cs args ->
          printf "capset %d: args: %s" cs (show args)
        ProgramEnv cs env ->
          printf "capset %d: env: %s" cs (show env)
        UnknownEvent n ->
          printf "Unknown event type %d" n
        InternString str sId ->
          printf "Interned string: \"%s\" with id %d" str sId
        MerStartParConjunction dyn_id static_id ->
          printf "Start a parallel conjunction 0x%x, static_id: %d" dyn_id static_id
        MerEndParConjunction dyn_id ->
          printf "End par conjunction: 0x%x" dyn_id
        MerEndParConjunct dyn_id ->
          printf "End par conjunct: 0x%x" dyn_id
        MerCreateSpark dyn_id spark_id ->
          printf "Create spark for conjunction: 0x%x spark: 0x%x" dyn_id spark_id
        MerFutureCreate future_id name_id ->
          printf "Create future 0x%x named %d" future_id name_id
        MerFutureWaitNosuspend future_id ->
          printf "Wait didn't suspend for future: 0x%x" future_id
        MerFutureWaitSuspended future_id ->
          printf "Wait suspended on future: 0x%x" future_id
        MerFutureSignal future_id ->
          printf "Signaled future 0x%x" future_id
        MerLookingForGlobalThread ->
          "Looking for global thread to resume"
        MerWorkStealing ->
          "Trying to steal a spark"
        MerLookingForLocalSpark ->
          "Looking for a local spark to execute"
        MerReleaseThread thread_id ->
          printf "Releasing thread %d to the free pool" thread_id
        MerCapSleeping ->
          "Capability going to sleep"
        MerCallingMain ->
          "About to call the program entry point"
        PerfName{perfNum, name} ->
          printf "perf event %d named \"%s\"" perfNum name
        PerfCounter{perfNum, tid, period} ->
          printf "perf event counter %d incremented by %d in OS thread %d"
                 perfNum (period + 1) (kernelThreadId tid)
        PerfTracepoint{perfNum, tid} ->
          printf "perf event tracepoint %d reached in OS thread %d"
                 perfNum (kernelThreadId tid)

showThreadStopStatus :: ThreadStopStatus -> String
showThreadStopStatus HeapOverflow   = "heap overflow"
showThreadStopStatus StackOverflow  = "stack overflow"
showThreadStopStatus ThreadYielding = "thread yielding"
showThreadStopStatus ThreadBlocked  = "thread blocked"
showThreadStopStatus ThreadFinished = "thread finished"
showThreadStopStatus ForeignCall    = "making a foreign call"
showThreadStopStatus BlockedOnMVar  = "blocked on an MVar"
showThreadStopStatus BlockedOnBlackHole = "blocked on a black hole"
showThreadStopStatus BlockedOnRead = "blocked on I/O read"
showThreadStopStatus BlockedOnWrite = "blocked on I/O write"
showThreadStopStatus BlockedOnDelay = "blocked on threadDelay"
showThreadStopStatus BlockedOnSTM = "blocked in STM retry"
showThreadStopStatus BlockedOnDoProc = "blocked on asyncDoProc"
showThreadStopStatus BlockedOnCCall = "blocked in a foreign call"
showThreadStopStatus BlockedOnCCall_NoUnblockExc = "blocked in a foreign call"
showThreadStopStatus BlockedOnMsgThrowTo = "blocked in throwTo"
showThreadStopStatus ThreadMigrating = "thread migrating"
showThreadStopStatus BlockedOnMsgGlobalise = "waiting for data to be globalised"
showThreadStopStatus (BlockedOnBlackHoleOwnedBy target) =
          "blocked on black hole owned by thread " ++ show target
showThreadStopStatus NoStatus = "No stop thread status"

ppEventLog :: EventLog -> String
ppEventLog (EventLog (Header ets) (Data es)) = unlines $ concat (
    [ ["Event Types:"]
    , map ppEventType ets
    , ["Events:"]
    , map (ppEvent imap) sorted
 where
    imap = buildEventTypeMap ets
    sorted = sortEvents es

ppEventType :: EventType -> String
ppEventType (EventType num dsc msz) = printf "%4d: %s (size %s)" num dsc
   (case msz of Nothing -> "variable"; Just x -> show x)

ppEvent :: IntMap EventType -> CapEvent -> String
ppEvent imap (CapEvent cap (Event time spec)) =
  printf "%9d: " time ++
  (case cap of
    Nothing -> ""
    Just c  -> printf "cap %d: " c) ++
  case spec of
    UnknownEvent{ ref=ref } ->
      printf (desc (fromJust (M.lookup (fromIntegral ref) imap)))

    other -> showEventInfo spec

type PutEvents a = PutM a

putE :: Binary a => a -> PutEvents ()
putE = put

runPutEBS :: PutEvents () -> L.ByteString
runPutEBS = runPut

writeEventLogToFile f el = L.writeFile f $ runPutEBS $ putEventLog el

putType :: EventTypeNum -> PutEvents ()
putType = putE

putCap :: Int -> PutEvents ()
putCap c = putE (fromIntegral c :: CapNo)

putMarker :: Word32 -> PutEvents ()
putMarker = putE

putEStr :: String -> PutEvents ()
putEStr = mapM_ putE

putEventLog :: EventLog -> PutEvents ()
putEventLog (EventLog hdr es) = do
    putHeader hdr
    putData es

putHeader :: Header -> PutEvents ()
putHeader (Header ets) = do
    putMarker EVENT_HEADER_BEGIN
    putMarker EVENT_HET_BEGIN
    mapM_ putEventType ets
    putMarker EVENT_HET_END
    putMarker EVENT_HEADER_END
 where
    putEventType (EventType n d msz) = do
        putMarker EVENT_ET_BEGIN
        putType n
        putE $ fromMaybe 0xffff msz
        putE (fromIntegral $ length d :: EventTypeDescLen)
        mapM_ put d
        putE (0 :: Word32)
        putMarker EVENT_ET_END

putData :: Data -> PutEvents ()
putData (Data es) = do
  
    mapM_ putEvent es

eventTypeNum :: EventInfo -> EventTypeNum
eventTypeNum e = case e of
    CreateThread {} -> EVENT_CREATE_THREAD
    RunThread {} -> EVENT_RUN_THREAD
    StopThread {} -> EVENT_STOP_THREAD
    ThreadRunnable {} -> EVENT_THREAD_RUNNABLE
    MigrateThread {} -> EVENT_MIGRATE_THREAD
    Shutdown {} -> EVENT_SHUTDOWN
    WakeupThread {} -> EVENT_THREAD_WAKEUP
    ThreadLabel {}  -> EVENT_THREAD_LABEL
    StartGC {} -> EVENT_GC_START
    EndGC {} -> EVENT_GC_END
    GlobalSyncGC {} -> EVENT_GC_GLOBAL_SYNC
    RequestSeqGC {} -> EVENT_REQUEST_SEQ_GC
    RequestParGC {} -> EVENT_REQUEST_PAR_GC
    CreateSparkThread {} -> EVENT_CREATE_SPARK_THREAD
    SparkCounters {} -> EVENT_SPARK_COUNTERS
    SparkCreate   {} -> EVENT_SPARK_CREATE
    SparkDud      {} -> EVENT_SPARK_DUD
    SparkOverflow {} -> EVENT_SPARK_OVERFLOW
    SparkRun      {} -> EVENT_SPARK_RUN
    SparkSteal    {} -> EVENT_SPARK_STEAL
    SparkFizzle   {} -> EVENT_SPARK_FIZZLE
    SparkGC       {} -> EVENT_SPARK_GC
    TaskCreate  {} -> EVENT_TASK_CREATE
    TaskMigrate {} -> EVENT_TASK_MIGRATE
    TaskDelete  {} -> EVENT_TASK_DELETE
    Message {} -> EVENT_LOG_MSG
    Startup {} -> EVENT_STARTUP
    EventBlock {} -> EVENT_BLOCK_MARKER
    UserMessage {} -> EVENT_USER_MSG
    UserMarker  {} -> EVENT_USER_MARKER
    GCIdle {} -> EVENT_GC_IDLE
    GCWork {} -> EVENT_GC_WORK
    GCDone {} -> EVENT_GC_DONE
    GCStatsGHC{} -> EVENT_GC_STATS_GHC
    HeapAllocated{} -> EVENT_HEAP_ALLOCATED
    HeapSize{} -> EVENT_HEAP_SIZE
    HeapLive{} -> EVENT_HEAP_LIVE
    HeapInfoGHC{} -> EVENT_HEAP_INFO_GHC
    CapCreate{} -> EVENT_CAP_CREATE
    CapDelete{} -> EVENT_CAP_DELETE
    CapDisable{} -> EVENT_CAP_DISABLE
    CapEnable{} -> EVENT_CAP_ENABLE
    CapsetCreate {} -> EVENT_CAPSET_CREATE
    CapsetDelete {} -> EVENT_CAPSET_DELETE
    CapsetAssignCap {} -> EVENT_CAPSET_ASSIGN_CAP
    CapsetRemoveCap {} -> EVENT_CAPSET_REMOVE_CAP
    RtsIdentifier {} -> EVENT_RTS_IDENTIFIER
    ProgramArgs {} -> EVENT_PROGRAM_ARGS
    ProgramEnv {} -> EVENT_PROGRAM_ENV
    OsProcessPid {} -> EVENT_OSPROCESS_PID
    OsProcessParentPid{} -> EVENT_OSPROCESS_PPID
    WallClockTime{} -> EVENT_WALL_CLOCK_TIME
    UnknownEvent {} -> error "eventTypeNum UnknownEvent"
    InternString {} -> EVENT_INTERN_STRING
    MerStartParConjunction {} -> EVENT_MER_START_PAR_CONJUNCTION
    MerEndParConjunction _ -> EVENT_MER_STOP_PAR_CONJUNCTION
    MerEndParConjunct _ -> EVENT_MER_STOP_PAR_CONJUNCT
    MerCreateSpark {} -> EVENT_MER_CREATE_SPARK
    MerFutureCreate {} -> EVENT_MER_FUT_CREATE
    MerFutureWaitNosuspend _ -> EVENT_MER_FUT_WAIT_NOSUSPEND
    MerFutureWaitSuspended _ -> EVENT_MER_FUT_WAIT_SUSPENDED
    MerFutureSignal _ -> EVENT_MER_FUT_SIGNAL
    MerLookingForGlobalThread -> EVENT_MER_LOOKING_FOR_GLOBAL_CONTEXT
    MerWorkStealing -> EVENT_MER_WORK_STEALING
    MerLookingForLocalSpark -> EVENT_MER_LOOKING_FOR_LOCAL_SPARK
    MerReleaseThread _ -> EVENT_MER_RELEASE_CONTEXT
    MerCapSleeping -> EVENT_MER_ENGINE_SLEEPING
    MerCallingMain -> EVENT_MER_CALLING_MAIN
    PerfName       {} -> nEVENT_PERF_NAME
    PerfCounter    {} -> nEVENT_PERF_COUNTER
    PerfTracepoint {} -> nEVENT_PERF_TRACEPOINT

nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT :: EventTypeNum
nEVENT_PERF_NAME = EVENT_PERF_NAME
nEVENT_PERF_COUNTER = EVENT_PERF_COUNTER
nEVENT_PERF_TRACEPOINT = EVENT_PERF_TRACEPOINT

putEvent :: Event -> PutEvents ()
putEvent (Event t spec) = do
    putType (eventTypeNum spec)
    put t
    putEventSpec spec

putEventSpec (Startup caps) = do
    putCap (fromIntegral caps)

putEventSpec (EventBlock end cap es) = do
    let block = runPutEBS (mapM_ putEvent es)
    put (fromIntegral (L.length block) + 24 :: Word32)
    putE end
    putE (fromIntegral cap :: CapNo)
    putLazyByteString block

putEventSpec (CreateThread t) = do
    putE t

putEventSpec (RunThread t) = do
    putE t

  
putEventSpec (StopThread t s) = do
    putE t
    putE $ case s of
            NoStatus -> 0 :: Word16
            HeapOverflow -> 1
            StackOverflow -> 2
            ThreadYielding -> 3
            ThreadBlocked -> 4
            ThreadFinished -> 5
            ForeignCall -> 6
            BlockedOnMVar -> 7
            BlockedOnBlackHole -> 8
            BlockedOnBlackHoleOwnedBy _ -> 8
            BlockedOnRead -> 9
            BlockedOnWrite -> 10
            BlockedOnDelay -> 11
            BlockedOnSTM -> 12
            BlockedOnDoProc -> 13
            BlockedOnCCall -> 14
            BlockedOnCCall_NoUnblockExc -> 15
            BlockedOnMsgThrowTo -> 16
            ThreadMigrating -> 17
            BlockedOnMsgGlobalise -> 18
    putE $ case s of
            BlockedOnBlackHoleOwnedBy i -> i
            _                           -> 0

putEventSpec (ThreadRunnable t) = do
    putE t

putEventSpec (MigrateThread t c) = do
    putE t
    putCap c

putEventSpec (CreateSparkThread t) = do
    putE t

putEventSpec (SparkCounters crt dud ovf cnv fiz gcd rem) = do
    putE crt
    putE dud
    putE ovf
    putE cnv
  Warning : order of fiz and gcd reversed !
    putE gcd
    putE fiz
    putE rem

putEventSpec SparkCreate = do
    return ()

putEventSpec SparkDud = do
    return ()

putEventSpec SparkOverflow = do
    return ()

putEventSpec SparkRun = do
    return ()

putEventSpec (SparkSteal c) = do
    putCap c

putEventSpec SparkFizzle = do
    return ()

putEventSpec SparkGC = do
    return ()

putEventSpec (WakeupThread t c) = do
    putE t
    putCap c

putEventSpec (ThreadLabel t l) = do
    putE (fromIntegral (length l) + sz_tid :: Word16)
    putE t
    putEStr l

putEventSpec Shutdown = do
    return ()

putEventSpec RequestSeqGC = do
    return ()

putEventSpec RequestParGC = do
    return ()

putEventSpec StartGC = do
    return ()

putEventSpec GCWork = do
    return ()

putEventSpec GCIdle = do
    return ()

putEventSpec GCDone = do
    return ()

putEventSpec EndGC = do
    return ()

putEventSpec GlobalSyncGC = do
    return ()

putEventSpec (TaskCreate taskId cap tid) = do
    putE taskId
    putCap cap
    putE tid

putEventSpec (TaskMigrate taskId cap new_cap) = do
    putE taskId
    putCap cap
    putCap new_cap

putEventSpec (TaskDelete taskId) = do
    putE taskId

putEventSpec GCStatsGHC{..} = do
    putE heapCapset
    putE (fromIntegral gen :: Word16)
    putE copied
    putE slop
    putE frag
    putE (fromIntegral parNThreads :: Word32)
    putE parMaxCopied
    putE parTotCopied

putEventSpec HeapAllocated{..} = do
    putE heapCapset
    putE allocBytes

putEventSpec HeapSize{..} = do
    putE heapCapset
    putE sizeBytes

putEventSpec HeapLive{..} = do
    putE heapCapset
    putE liveBytes

putEventSpec HeapInfoGHC{..} = do
    putE heapCapset
    putE (fromIntegral gens :: Word16)
    putE maxHeapSize
    putE allocAreaSize
    putE mblockSize
    putE blockSize

putEventSpec CapCreate{cap} = do
    putCap cap

putEventSpec CapDelete{cap} = do
    putCap cap

putEventSpec CapDisable{cap} = do
    putCap cap

putEventSpec CapEnable{cap} = do
    putCap cap

putEventSpec (CapsetCreate cs ct) = do
    putE cs
    putE $ case ct of
            CapsetCustom -> 1 :: Word16
            CapsetOsProcess -> 2
            CapsetClockDomain -> 3
            CapsetUnknown -> 0

putEventSpec (CapsetDelete cs) = do
    putE cs

putEventSpec (CapsetAssignCap cs cp) = do
    putE cs
    putCap cp

putEventSpec (CapsetRemoveCap cs cp) = do
    putE cs
    putCap cp

putEventSpec (RtsIdentifier cs rts) = do
    putE (fromIntegral (length rts) + sz_capset :: Word16)
    putE cs
    putEStr rts

putEventSpec (ProgramArgs cs as) = do
    let as' = unsep as
    putE (fromIntegral (length as') + sz_capset :: Word16)
    putE cs
    mapM_ putE as'

putEventSpec (ProgramEnv cs es) = do
    let es' = unsep es
    putE (fromIntegral (length es') + sz_capset :: Word16)
    putE cs
    mapM_ putE es'

putEventSpec (OsProcessPid cs pid) = do
    putE cs
    putE pid

putEventSpec (OsProcessParentPid cs ppid) = do
    putE cs
    putE ppid

putEventSpec (WallClockTime cs sec nsec) = do
    putE cs
    putE sec
    putE nsec

putEventSpec (Message s) = do
    putE (fromIntegral (length s) :: Word16)
    mapM_ putE s

putEventSpec (UserMessage s) = do
    putE (fromIntegral (length s) :: Word16)
    mapM_ putE s

putEventSpec (UserMarker s) = do
    putE (fromIntegral (length s) :: Word16)
    mapM_ putE s

putEventSpec (UnknownEvent {}) = error "putEventSpec UnknownEvent"

putEventSpec (InternString str id) = do
    putE len
    mapM_ putE str
    putE id
  where len = (fromIntegral (length str) :: Word16) + sz_string_id

putEventSpec (MerStartParConjunction dyn_id static_id) = do
    putE dyn_id
    putE static_id

putEventSpec (MerEndParConjunction dyn_id) = do
    putE dyn_id

putEventSpec (MerEndParConjunct dyn_id) = do
    putE dyn_id

putEventSpec (MerCreateSpark dyn_id spark_id) = do
    putE dyn_id
    putE spark_id

putEventSpec (MerFutureCreate future_id name_id) = do
    putE future_id
    putE name_id

putEventSpec (MerFutureWaitNosuspend future_id) = do
    putE future_id

putEventSpec (MerFutureWaitSuspended future_id) = do
    putE future_id

putEventSpec (MerFutureSignal future_id) = do
    putE future_id

putEventSpec MerLookingForGlobalThread = return ()
putEventSpec MerWorkStealing = return ()
putEventSpec MerLookingForLocalSpark = return ()

putEventSpec (MerReleaseThread thread_id) = do
    putE thread_id

putEventSpec MerCapSleeping = return ()
putEventSpec MerCallingMain = return ()

putEventSpec PerfName{..} = do
    putE (fromIntegral (length name) + sz_perf_num :: Word16)
    putE perfNum
    mapM_ putE name

putEventSpec PerfCounter{..} = do
    putE perfNum
    putE tid
    putE period

putEventSpec PerfTracepoint{..} = do
    putE perfNum
    putE tid

unsep :: [String] -> String

splitNull :: String -> [String]
splitNull [] = []
splitNull xs = case span (/= '\0') xs of
                (x, xs') -> x : splitNull (drop 1 xs')
