{-# LANGUAGE CPP,BangPatterns,PatternGuards #-}
{-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-}
{-
- Authors: Donnie Jones, Simon Marlow, Paul Bone, Mischa Dieterle,
- Thomas Horstmeyer, Duncan Coutts, Jost Berthold
- Events.hs
- Parser functions for GHC RTS EventLog framework, parallel version.
-}
module GHC.RTS.Events (
-- * The event log types
EventLog(..),
EventType(..),
Event(..),
EventInfo(..),
ThreadStopStatus(..),
Header(..),
Data(..),
CapsetType(..),
Timestamp,
ThreadId,
-- some types for the parallel RTS
ProcessId,
MachineId,
PortId,
MessageSize,
MessageTag(..),
-- * Reading and writing event logs
readEventLogFromFile, getEventLog,
writeEventLogToFile,
-- * Utilities
CapEvent(..), sortEvents, groupEvents, sortGroups,
buildEventTypeMap,
-- * Printing
showEventInfo, showThreadStopStatus,
ppEventLog, ppEventType, ppEvent
) 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"
------------------------------------------------------------------------------
-- 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 = [
(FixedSizeParser EVENT_STARTUP sz_cap (do -- (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 }
)),
(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),
(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 }
)),
(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 }
)),
(VariableSizeParser EVENT_INTERN_STRING (do -- (str, id)
num <- getE :: GetEvents Word16
string <- getString (num - sz_string_id)
sId <- getE :: GetEvents StringId
return (InternString string sId)
)),
(VariableSizeParser EVENT_THREAD_LABEL (do -- (thread, str)
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}
)),
(FixedSizeParser EVENT_MIGRATE_THREAD (sz_tid + sz_cap) (do -- (thread, newCap)
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}
)),
(FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_tid (do -- (sparkThread)
st <- getE :: GetEvents ThreadId
return CreateSparkThread{sparkThread=st}
)),
(FixedSizeParser EVENT_SPARK_COUNTERS (7*8) (do -- (crt,dud,ovf,cnv,fiz,gcd,rem)
crt <- getE :: GetEvents Word64
dud <- getE :: GetEvents Word64
ovf <- getE :: GetEvents Word64
cnv <- getE :: GetEvents Word64
fiz <- getE :: GetEvents Word64
gcd <- getE :: GetEvents Word64
rem <- getE :: GetEvents Word64
return SparkCounters{sparksCreated = crt, sparksDud = dud,
sparksOverflowed = ovf, sparksConverted = cnv,
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),
(FixedSizeParser EVENT_THREAD_WAKEUP (sz_tid + sz_cap) (do -- (thread, other_cap)
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}
)),
(FixedSizeParser EVENT_MIGRATE_THREAD (sz_old_tid + sz_cap) (do -- (thread, newCap)
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}
)),
(FixedSizeParser EVENT_CREATE_SPARK_THREAD sz_old_tid (do -- (sparkThread)
st <- getE :: GetEvents ThreadId
return CreateSparkThread{sparkThread=st}
)),
(FixedSizeParser EVENT_THREAD_WAKEUP (sz_old_tid + sz_cap) (do -- (thread, other_cap)
t <- getE
oc <- getE :: GetEvents CapNo
return WakeupThread{thread=t,otherCap=fromIntegral oc}
))
]
-- Parsers for parallel events. Parameter is the thread_id size, to create
-- ghc6-parsers (using the wrong size) where necessary.
parRTSParsers :: EventTypeSize -> [EventParser EventInfo]
parRTSParsers sz_tid = [
(VariableSizeParser EVENT_VERSION (do -- (version)
num <- getE :: GetEvents Word16
string <- getString num
return Version{ version = string }
)),
(VariableSizeParser EVENT_PROGRAM_INVOCATION (do -- (cmd. line)
num <- getE :: GetEvents Word16
string <- getString num
return ProgramInvocation{ commandline = string }
)),
(simpleEvent EVENT_EDEN_START_RECEIVE EdenStartReceive),
(simpleEvent EVENT_EDEN_END_RECEIVE EdenEndReceive),
(FixedSizeParser EVENT_CREATE_PROCESS sz_procid
(do p <- getE
return CreateProcess{ process = p })
),
(FixedSizeParser EVENT_KILL_PROCESS sz_procid
(do p <- getE
return KillProcess{ process = p })
),
(FixedSizeParser EVENT_ASSIGN_THREAD_TO_PROCESS (sz_tid + sz_procid)
(do t <- getE
p <- getE
return AssignThreadToProcess { thread = t, process = p })
),
(FixedSizeParser EVENT_CREATE_MACHINE (sz_mid + sz_realtime)
(do m <- getE
t <- getE
return CreateMachine { machine = m, realtime = t })
),
(FixedSizeParser EVENT_KILL_MACHINE sz_mid
(do m <- getE :: GetEvents MachineId
return KillMachine { machine = m })
),
(FixedSizeParser EVENT_SEND_MESSAGE
(sz_msgtag + 2*sz_procid + 2*sz_tid + sz_mid)
(do tag <- getE :: GetEvents RawMsgTag
sP <- getE :: GetEvents ProcessId
sT <- getE :: GetEvents ThreadId
rM <- getE :: GetEvents MachineId
rP <- getE :: GetEvents ProcessId
rIP <- getE :: GetEvents PortId
return SendMessage { mesTag = toMsgTag tag,
senderProcess = sP,
senderThread = sT,
receiverMachine = rM,
receiverProcess = rP,
receiverInport = rIP
})
),
(FixedSizeParser EVENT_RECEIVE_MESSAGE
(sz_msgtag + 2*sz_procid + 2*sz_tid + sz_mid + sz_mes)
(do tag <- getE :: GetEvents Word8
rP <- getE :: GetEvents ProcessId
rIP <- getE :: GetEvents PortId
sM <- getE :: GetEvents MachineId
sP <- getE :: GetEvents ProcessId
sT <- getE :: GetEvents ThreadId
mS <- getE :: GetEvents MessageSize
return ReceiveMessage { mesTag = toMsgTag tag,
receiverProcess = rP,
receiverInport = rIP,
senderMachine = sM,
senderProcess = sP,
senderThread= sT,
messageSize = mS
})
),
(FixedSizeParser EVENT_SEND_RECEIVE_LOCAL_MESSAGE
(sz_msgtag + 2*sz_procid + 2*sz_tid)
(do tag <- getE :: GetEvents Word8
sP <- getE :: GetEvents ProcessId
sT <- getE :: GetEvents ThreadId
rP <- getE :: GetEvents ProcessId
rIP <- getE :: GetEvents PortId
return SendReceiveLocalMessage { mesTag = toMsgTag tag,
senderProcess = sP,
senderThread = sT,
receiverProcess = rP,
receiverInport = rIP
})
)]
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)
]
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.
-}
event_parsers = if is_ghc_6
then standardParsers ++ ghc6Parsers ++
parRTSParsers sz_old_tid
else standardParsers ++ ghc7Parsers ++
parRTSParsers sz_tid ++
mercuryParsers
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"
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"
Message msg ->
msg
UserMessage msg ->
msg
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
-- events for the parallel RTS
Version version ->
printf "compiler version is %s" version
ProgramInvocation commandline ->
printf "program invocation: %s" commandline
EdenStartReceive ->
printf "starting to receive"
EdenEndReceive ->
printf "stop receiving"
CreateProcess process ->
printf "creating process %d" process
KillProcess process ->
printf "killing process %d" process
AssignThreadToProcess thread process ->
printf "assigning thread %d to process %d" thread process
CreateMachine machine realtime ->
printf "creating machine %d at %d" machine realtime
KillMachine machine ->
printf "killing machine %d" machine
SendMessage mesTag senderProcess senderThread
receiverMachine receiverProcess receiverInport ->
printf "sending message with tag %s from process %d, thread %d to machine %d, process %d on inport %d"
(show mesTag) senderProcess senderThread receiverMachine receiverProcess receiverInport
ReceiveMessage mesTag receiverProcess receiverInport
senderMachine senderProcess senderThread messageSize ->
printf "receiving message with tag %s at process %d, inport %d from machine %d, process %d, thread %d with size %d"
(show mesTag) receiverProcess receiverInport
senderMachine senderProcess senderThread messageSize
SendReceiveLocalMessage mesTag senderProcess senderThread
receiverProcess receiverInport ->
printf "sending/receiving message with tag %s from process %d, thread %d to process %d on inport %d"
(show mesTag) senderProcess senderThread receiverProcess receiverInport
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"
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
putMarker EVENT_DATA_BEGIN -- Word32
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
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
Message {} -> EVENT_LOG_MSG
Startup {} -> EVENT_STARTUP
EventBlock {} -> EVENT_BLOCK_MARKER
UserMessage {} -> EVENT_USER_MSG
GCIdle {} -> EVENT_GC_IDLE
GCWork {} -> EVENT_GC_WORK
GCDone {} -> EVENT_GC_DONE
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
Version {} -> EVENT_VERSION
ProgramInvocation {} -> EVENT_PROGRAM_INVOCATION
EdenStartReceive {} -> EVENT_EDEN_START_RECEIVE
EdenEndReceive {} -> EVENT_EDEN_END_RECEIVE
CreateProcess {} -> EVENT_CREATE_PROCESS
KillProcess {} -> EVENT_KILL_PROCESS
AssignThreadToProcess {} -> EVENT_ASSIGN_THREAD_TO_PROCESS
CreateMachine {} -> EVENT_CREATE_MACHINE
KillMachine {} -> EVENT_KILL_MACHINE
SendMessage {} -> EVENT_SEND_MESSAGE
ReceiveMessage {} -> EVENT_RECEIVE_MESSAGE
SendReceiveLocalMessage {} -> EVENT_SEND_RECEIVE_LOCAL_MESSAGE
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
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
-- EventLogFormat.h
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
putE fiz
putE gcd
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 (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) + 4 :: Word16)
putE cs
putEStr rts
putEventSpec (ProgramArgs cs as) = do
let as' = unsep as
putE (fromIntegral (length as') + 4 :: Word16)
putE cs
mapM_ putE as'
putEventSpec (ProgramEnv cs es) = do
let es' = unsep es
putE (fromIntegral (length es') + 4 :: 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 (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 (Version s) = do
putE (fromIntegral (length s) :: Word16)
mapM_ putE s
putEventSpec (ProgramInvocation s) = do
putE (fromIntegral (length s) :: Word16)
mapM_ putE s
putEventSpec ( EdenStartReceive ) = return ()
putEventSpec ( EdenEndReceive ) = return ()
putEventSpec ( CreateProcess process ) = do
putE process
putEventSpec ( KillProcess process ) = do
putE process
putEventSpec ( AssignThreadToProcess thread process ) = do
putE thread
putE process
putEventSpec ( CreateMachine machine realtime ) = do
putE machine
putE realtime
putEventSpec ( KillMachine machine ) = do
putE machine
putEventSpec ( SendMessage mesTag senderProcess senderThread
receiverMachine receiverProcess receiverInport ) = do
putE (fromMsgTag mesTag)
putE senderProcess
putE senderThread
putE receiverMachine
putE receiverProcess
putE receiverInport
putEventSpec ( ReceiveMessage mesTag receiverProcess receiverInport
senderMachine senderProcess senderThread messageSize ) = do
putE (fromMsgTag mesTag)
putE receiverProcess
putE receiverInport
putE senderMachine
putE senderProcess
putE senderThread
putE messageSize
putEventSpec ( SendReceiveLocalMessage mesTag senderProcess senderThread
receiverProcess receiverInport ) = do
putE (fromMsgTag mesTag)
putE senderProcess
putE senderThread
putE receiverProcess
putE receiverInport
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 ()
-- [] == []
-- [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')