ghc-events 0.3.0.1 → 0.4.0.0
raw patch · 14 files changed
+960/−180 lines, 14 filesdep ~arraydep ~basedep ~binarynew-component:exe:ghc-events
Dependency ranges changed: array, base, binary, bytestring, containers, mtl
Files
- GHC/RTS/EventLogFormat.h +4/−3
- GHC/RTS/EventParserUtils.hs +1/−2
- GHC/RTS/EventTypes.hs +19/−11
- GHC/RTS/Events.hs +69/−35
- GHC/RTS/Events/Analysis.hs +283/−0
- GHC/RTS/Events/Analysis/Capability.hs +100/−0
- GHC/RTS/Events/Analysis/SparkThread.hs +114/−0
- GHC/RTS/Events/Analysis/Thread.hs +53/−0
- GHC/RTS/Events/Merge.hs +81/−0
- GhcEvents.hs +217/−0
- MergeGhcEvents.hs +0/−88
- ShowGhcEvents.hs +0/−25
- ghc-events.cabal +17/−14
- test/TestVersions.hs +2/−2
GHC/RTS/EventLogFormat.h view
@@ -141,9 +141,10 @@ #define EVENT_SPARK_FIZZLE 40 /* () */ #define EVENT_SPARK_GC 41 /* () */ #define EVENT_INTERN_STRING 42 /* (string, id) */-+#define EVENT_WALL_CLOCK_TIME 43 /* (capset, unix_epoch_seconds, nanoseconds) */+#define EVENT_THREAD_LABEL 44 /* (thread, name_string) */ -/* Range 43 - 59 is available for new GHC and common events */+/* Range 45 - 59 is available for new GHC and common events */ /* Range 60 - 80 is used by eden for parallel tracing * see http://www.mathematik.uni-marburg.de/~eden/@@ -156,7 +157,7 @@ * ranges higher than this are reserved but not currently emitted by ghc. * This must match the size of the EventDesc[] array in EventLog.c */-#define NUM_GHC_EVENT_TAGS 42+#define NUM_GHC_EVENT_TAGS 45 /* DEPRECATED EVENTS: */
GHC/RTS/EventParserUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, PatternGuards #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module GHC.RTS.EventParserUtils (@@ -196,4 +196,3 @@ Nothing -> getE :: GetEvents Word16 skip bytes return UnknownEvent{ ref = fromIntegral num }-
GHC/RTS/EventTypes.hs view
@@ -18,6 +18,7 @@ type BlockSize = Word32 type RawThreadStopStatus = Word16 type StringId = Word32+type Capset = Word32 -- These types are used by Mercury events. type ParConjDynId = Word64@@ -126,6 +127,9 @@ | WakeupThread { thread :: {-# UNPACK #-}!ThreadId, otherCap :: {-# UNPACK #-}!Int }+ | ThreadLabel { thread :: {-# UNPACK #-}!ThreadId,+ threadlabel :: String+ } -- par sparks | CreateSparkThread { sparkThread :: {-# UNPACK #-}!ThreadId@@ -152,34 +156,38 @@ | EndGC { } -- capability sets- | CapsetCreate { capset :: {-# UNPACK #-}!Word32+ | CapsetCreate { capset :: {-# UNPACK #-}!Capset , capsetType :: CapsetType }- | CapsetDelete { capset :: {-# UNPACK #-}!Word32+ | CapsetDelete { capset :: {-# UNPACK #-}!Capset }- | CapsetAssignCap { capset :: {-# UNPACK #-}!Word32+ | CapsetAssignCap { capset :: {-# UNPACK #-}!Capset , cap :: {-# UNPACK #-}!Int }- | CapsetRemoveCap { capset :: {-# UNPACK #-}!Word32+ | CapsetRemoveCap { capset :: {-# UNPACK #-}!Capset , cap :: {-# UNPACK #-}!Int } -- program/process info- | RtsIdentifier { capset :: {-# UNPACK #-}!Word32+ | RtsIdentifier { capset :: {-# UNPACK #-}!Capset , rtsident :: String }- | ProgramArgs { capset :: {-# UNPACK #-}!Word32+ | ProgramArgs { capset :: {-# UNPACK #-}!Capset , args :: [String] }- | ProgramEnv { capset :: {-# UNPACK #-}!Word32+ | ProgramEnv { capset :: {-# UNPACK #-}!Capset , env :: [String] }- | OsProcessPid { capset :: {-# UNPACK #-}!Word32+ | OsProcessPid { capset :: {-# UNPACK #-}!Capset , pid :: {-# UNPACK #-}!Word32 }- | OsProcessParentPid { capset :: {-# UNPACK #-}!Word32+ | OsProcessParentPid { capset :: {-# UNPACK #-}!Capset , ppid :: {-# UNPACK #-}!Word32 }+ | WallClockTime { capset :: {-# UNPACK #-}!Capset+ , sec :: {-# UNPACK #-}!Word64+ , nsec :: {-# UNPACK #-}!Word32+ } -- messages | Message { msg :: String }@@ -187,7 +195,7 @@ -- These events have been added for Mercury's benifit but are generally -- useful.- | InternString { str :: String, id :: {-# UNPACK #-}!StringId }+ | InternString { str :: String, sId :: {-# UNPACK #-}!StringId } -- Mercury specific events. | MerStartParConjunction {@@ -299,5 +307,5 @@ -- we could UNPACK ce_event, but the Event constructor -- might be shared, in which case we could end up -- increasing the space usage.- }+ } deriving Show
GHC/RTS/Events.hs view
@@ -5,9 +5,9 @@ - Events.hs - Parser functions for GHC RTS EventLog framework. -}- + module GHC.RTS.Events (- -- * The event log types + -- * The event log types EventLog(..), EventType(..), Event(..),@@ -60,41 +60,41 @@ -- Binary instances getEventType :: GetHeader EventType-getEventType = do +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) + 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 + where getEtDesc :: Int -> GetHeader [Char] getEtDesc s = replicateM s (getH :: GetHeader Char) getHeader :: GetHeader Header-getHeader = do +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) $ + 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 + where getEventTypes :: GetHeader [EventType] getEventTypes = do m <- getH :: GetHeader Marker- case () of + case () of _ | m == EVENT_ET_BEGIN -> do et <- getEventType nextET <- getEventTypes@@ -105,9 +105,9 @@ throwError "Malformed list of Event Types in header" getEvent :: EventParsers -> GetEvents (Maybe Event)-getEvent (EventParsers parsers) = do +getEvent (EventParsers parsers) = do etRef <- getE :: GetEvents EventTypeNum- if (etRef == EVENT_DATA_END) + if (etRef == EVENT_DATA_END) then return Nothing else do !ts <- getE -- trace ("event: " ++ show etRef) $ do@@ -128,17 +128,17 @@ block_size <- getE :: GetEvents BlockSize end_time <- getE :: GetEvents Timestamp c <- getE :: GetEvents CapNo- lbs <- lift . lift $ getLazyByteString ((fromIntegral block_size) - + 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, + 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),@@ -154,18 +154,18 @@ (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@@ -190,6 +190,14 @@ 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@@ -225,8 +233,16 @@ (VariableSizeParser EVENT_INTERN_STRING (do -- (str, id) num <- getE :: GetEvents Word16 string <- getString (num - sz_string_id)- id <- getE :: GetEvents StringId- return (InternString 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 } )) ] @@ -247,7 +263,7 @@ -- (thread, status) t <- getE s <- getE :: GetEvents RawThreadStopStatus- return StopThread{thread=t, status = if s > maxThreadStopStatus + return StopThread{thread=t, status = if s > maxThreadStopStatus then NoStatus else mkStopStatus s} )),@@ -255,7 +271,7 @@ (FixedSizeParser EVENT_STOP_THREAD (sz_tid + sz_th_stop_status + sz_tid) (do -- (thread, status, info) t <- getE- s <- getE :: GetEvents RawThreadStopStatus + s <- getE :: GetEvents RawThreadStopStatus i <- getE :: GetEvents ThreadId return StopThread{thread = t, status = case () of@@ -331,12 +347,12 @@ ----------------------- -- 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 + -- 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 + -- 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 }@@ -403,7 +419,7 @@ ] mercuryParsers = [- (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION + (FixedSizeParser EVENT_MER_START_PAR_CONJUNCTION (sz_par_conj_dyn_id + sz_par_conj_static_id) (do dyn_id <- getE static_id <- getE@@ -458,7 +474,7 @@ (simpleEvent EVENT_MER_ENGINE_SLEEPING MerCapSleeping), (simpleEvent EVENT_MER_CALLING_MAIN MerCallingMain)- + ] getData :: GetEvents Data@@ -466,7 +482,7 @@ db <- getE :: GetEvents Marker when (db /= EVENT_DATA_BEGIN) $ throwError "Data begin marker not found" eparsers <- ask- let + let getEvents :: [Event] -> GetEvents Data getEvents events = do mb_e <- getEvent eparsers@@ -494,7 +510,7 @@ -- 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 + 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@@ -526,10 +542,10 @@ -- capability that generated it. sortGroups :: [(Maybe Int, [Event])] -> [CapEvent] sortGroups groups = mergesort' (compare `on` (time . ce_event)) $- [ [ CapEvent cap e | e <- es ] + [ [ 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. + -- 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@@ -540,7 +556,7 @@ -- merge the resulting lists. groupEvents :: [Event] -> [(Maybe Int, [Event])]-groupEvents es = (Nothing, n_events) : +groupEvents es = (Nothing, n_events) : [ (Just (cap (head blocks)), concatMap block_events blocks) | blocks <- groups ] where@@ -624,6 +640,8 @@ 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 ->@@ -654,16 +672,18 @@ 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+ 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 id ->- printf "Interned string: \"%s\" with id %d" str id+ 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 ->@@ -763,6 +783,9 @@ putMarker :: Word32 -> PutEvents () putMarker = putE +putEStr :: String -> PutEvents ()+putEStr = mapM_ putE+ putEventLog :: EventLog -> PutEvents () putEventLog (EventLog hdr es) = do putHeader hdr@@ -801,6 +824,7 @@ 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@@ -830,6 +854,7 @@ 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@@ -942,6 +967,11 @@ putE t putCap c +putEventSpec (ThreadLabel t l) = do+ putE (fromIntegral (length l) + sz_tid :: Word16)+ putE t+ putEStr l+ putEventSpec Shutdown = do return () @@ -988,7 +1018,7 @@ putEventSpec (RtsIdentifier cs rts) = do putE (fromIntegral (length rts) + 4 :: Word16) putE cs- mapM_ putE rts+ putEStr rts putEventSpec (ProgramArgs cs as) = do let as' = unsep as@@ -1010,6 +1040,11 @@ 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@@ -1073,4 +1108,3 @@ splitNull [] = [] splitNull xs = case span (/= '\0') xs of (x, xs') -> x : splitNull (drop 1 xs')-
+ GHC/RTS/Events/Analysis.hs view
@@ -0,0 +1,283 @@+module GHC.RTS.Events.Analysis+ ( Machine (..)+ , validate+ , validates+ , simulate+ , Profile (..)+ , profile+ , profileIndexed+ , profileRouted+ , extractIndexed+ , refineM+ , profileM+ , indexM+ , toList+ , toMaybe+ , Process (..)+ , routeM+ )+ where++import GHC.RTS.Events++import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, catMaybes)+import Data.Either (rights)++--------------------------------------------------------------------------------+-- | This is based on a simple finite state machine hence the names `delta`+-- for the state transition function.+-- Since states might be more than simple pattern matched constructors, we+-- use `finals :: state -> Bool`, rather than `Set state`, to indicate that+-- the machine is in some final state. Similarly for `alpha`, which+-- indicates the alphabet of inputs to a machine.+-- The function `delta` returns `Maybe` values, where `Nothing`+-- indicates that no valid transition is possible: ie, there has been an+-- error.+data Machine s i = Machine+ { initial :: s -- ^ Initial state+ , final :: s -> Bool -- ^ Valid final states+ , alpha :: i -> Bool -- ^ Valid input alphabet+ , delta :: s -> i -> Maybe s -- ^ State transition function+ }++-- | This machine always accepts, never terminates, and always has unit state.+unitMachine :: Machine () i+unitMachine = Machine+ { initial = ()+ , final = const False+ , alpha = const True+ , delta = (\s i -> Just ())+ }++-- | The `step` function runs a machine in a state against a single input.+-- The state remains fixed once a final state is encountered. The+-- result is `Left state input` if some `state` failed for an `ìnput`, and+-- `Right state` for a successful state.+step :: Machine s i -> s -> i -> Either (s, i) s+step m s i+ | final m s = Right s+ | alpha m i = case delta m s i of+ Just s' -> Right s'+ Nothing -> Left (s, i)+ | otherwise = Right s++-- | The `validate` function takes a machine and a list of inputs. The machine+-- is started from its initial state and run agains the inputs in turn.+-- It returns the state and input on failure, and just the state on success.+validate :: Machine s i -> [i] -> Either (s, i) s+validate m = foldl (>>=) (Right (initial m)) . map (flip (step m))++-- | This function is similar to `validate`, but outputs each intermediary+-- state as well. For an incremental version, use `simulate`.+validates :: Machine s i -> [i] -> [Either (s, i) s]+validates m = scanl (>>=) (Right (initial m)) . map (flip (step m))++--------------------------------------------------------------------------------+-- A Process is a list of successful values, followed by an error if one+-- occured. This captures the idea that a computation may produce a list of+-- elements before possibly failing. This gives us an incremental interface+-- to data processed from machine transitions.+data Process e a+ = Done+ | Fail e+ | Prod a (Process e a)+ deriving Show++toList :: Process e a -> [a]+toList (Fail _) = []+toList Done = []+toList (Prod a as) = a : toList as++toMaybe :: Process e a -> Maybe e+toMaybe (Fail e) = Just e+toMaybe Done = Nothing+toMaybe (Prod _ as) = toMaybe as++-- | A machine can be analysed while it is accepting input in order to extract+-- some information. This function takes a machine and a function that extracts+-- data and produces output. On failure, the machine state and input are+-- produced. Note that when an input is not in the machine's alphabet,+-- then there is no transition, and so no output is produced in response+-- to that input.+analyse :: Machine s i -- ^ The machine used+ -> (s -> i -> Maybe o) -- ^ An extraction function that may produce output+ -> [i] -- ^ A list of input+ -> Process (s, i) o -- ^ A process that produces output+analyse machine extract is = go (initial machine) is+ where+ -- go :: s -> [i] -> Process (s, i) o+ go _ [] = Done+ go s (i:is)+ | final machine s = Done+ | alpha machine i =+ case delta machine s i of+ Nothing -> Fail (s, i)+ Just s' ->+ case extract s i of+ Nothing -> go s' is+ Just o -> Prod o (go s' is)+ | otherwise = go s is++-- | Machines sometimes need to operate on coarser input than they are defined+-- for. This function takes a function that refines input and a machine that+-- works on refined input, and produces a machine that can work on coarse input.+refineM :: (i -> j) -> Machine s j -> Machine s i+refineM refine machine = Machine+ { initial = initial machine+ , final = final machine+ , alpha = alpha machine . refine+ , delta = \s -> delta machine s . refine+ }++--------------------------------------------------------------------------------+-- | This function produces a process that outputs all the states that a+-- machine goes through.+simulate :: Machine s i -> [i] -> Process (s, i) (s, i)+simulate machine = analyse machine (\s i -> delta machine s i >>= \s' -> return (s', i))++--------------------------------------------------------------------------------+-- | A state augmented by Timestamp information is held in `profileState`.+-- When the state changes, `profileMap` stores a map between each state+-- and its cumulative time.+data Profile s = Profile+ { profileState :: s -- ^ The current state+ , profileTime :: Timestamp -- ^ The entry time of the state+ } deriving (Show)++-- | This function takes a machine and profiles its state.+profileM :: Ord s+ => (i -> Timestamp)+ -> Machine s i+ -> Machine (Profile s) i+profileM timer machine = Machine+ { initial = Profile (initial machine) 0+ , final = final machine . profileState+ , alpha = alpha machine+ , delta = profileMDelta+ }+ where+ profileMDelta (Profile s _) i = do+ s' <- delta machine s i+ return $ Profile s' (timer i)++-- | extractProfile returns the state, the time this state was made,+-- and the time spent in this state.+extractProfile :: (i -> Timestamp) -- ^ Extracts current timestamp+ -> Profile s -- ^ A profiled state+ -> i -- ^ Some input+ -> Maybe (s, Timestamp, Timestamp) -- ^ (state, currentTime, elapsedTime)+extractProfile timer p i = Just (profileState p, profileTime p, timer i - profileTime p)++profile :: (Ord s, Eq s)+ => Machine s i -- ^ A machine to profile+ -> (i -> Timestamp) -- ^ Converts input to timestamps+ -> [i] -- ^ The list of input+ -> Process (Profile s, i) (s, Timestamp, Timestamp)+profile machine timer =+ analyse (profileM timer machine)+ (extractProfile timer)++profileIndexed :: (Ord k, Ord s, Eq s)+ => Machine s i+ -> (i -> Maybe k)+ -> (i -> Timestamp)+ -> [i]+ -> Process (Map k (Profile s), i) (k, (s, Timestamp, Timestamp))+profileIndexed machine index timer =+ analyse (indexM index (profileM timer machine))+ (extractIndexed (extractProfile timer) index)++extractIndexed :: Ord k => (s -> i -> Maybe o) -> (i -> Maybe k) -> (Map k s -> i -> Maybe (k, o))+extractIndexed extract index m i = do+ k <- index i+ s <- M.lookup k m+ o <- extract s i+ return (k, o)++-- | An indexed machine takes a function that multiplexes the input to a key+-- and then takes a machine description to an indexed machine.+indexM :: Ord k+ => (i -> Maybe k) -- ^ An indexing function+ -> Machine s i -- ^ A machine to index with+ -> Machine (Map k s) i -- ^ The indexed machine+indexM index machine = Machine+ { initial = M.empty+ , final = indexMFinal+ , alpha = indexMAlpha+ , delta = indexMDelta+ }+ where+ -- An indexer never reaches a final state: it is always possible that+ -- an event comes along that is accepted by a machine that is not+ -- yet in in the index.+ --+ -- An alternative view is that the indexer is in a final state if all its+ -- elements are, but this would not allow the creation of new indexes:+ -- indexMFinal m = not (M.null m) && (all (final machine) . M.elems $ m)+ indexMFinal = const False++ -- The alphabet of the indexer is that of its elements.+ indexMAlpha = alpha machine++ -- If the index is not yet in the mapping, we start a new machine in its+ -- initial state. The indexer fails if indexed state fails.+ indexMDelta m i = do+ k <- index i+ let state = fromMaybe (initial machine) (M.lookup k m)+ state' <- delta machine state i+ return $ M.insert k state' m++profileRouted :: (Ord k, Ord s, Eq s, Eq r)+ => Machine s i+ -> Machine r i+ -> (r -> i -> Maybe k)+ -> (i -> Timestamp)+ -> [i]+ -> Process ((Map k (Profile s), r), i) (k, (s, Timestamp, Timestamp))+profileRouted machine router index timer =+ analyse (routeM router index (profileM timer machine))+ (extractRouted (extractProfile timer) index)++extractRouted :: Ord k => (s -> i -> Maybe o) -> (r -> i -> Maybe k) -> ((Map k s, r) -> i -> Maybe (k, o))+extractRouted extract index (m, r) i = do+ k <- index r i+ s <- M.lookup k m+ o <- extract s i+ return (k, o)+++-- | A machine can be indexed not only by the inputs, but also by the state+-- of an intermediary routing machine. This is a generalisation of indexM.+routeM :: (Ord k)+ => Machine r i+ -> (r -> i -> Maybe k)+ -> Machine s i+ -> Machine (Map k s, r) i+routeM router index machine = Machine+ { initial = (M.empty, initial router)+ , final = routeMFinal+ , alpha = routeMAlpha+ , delta = routeMDelta+ }+ where+ -- As with indexers, there is no final state.+ routeMFinal = const False++ -- The alphabet is that of the router combined with the machine+ routeMAlpha i = alpha router i || alpha machine i++ routeMDelta (m, r) i = do+ r' <- if alpha router i+ then delta router r i+ else return r+ m' <- if alpha machine i+ then case index r' i of+ Just k -> do+ s' <- delta machine (fromMaybe (initial machine) (M.lookup k m)) i+ return $ M.insert k s' m+ Nothing -> return m+ else return m+ return (m', r')+
+ GHC/RTS/Events/Analysis/Capability.hs view
@@ -0,0 +1,100 @@+module GHC.RTS.Events.Analysis.Capability+ ( capabilityThreadPoolMachine+ , capabilityThreadRunMachine+ , capabilityThreadIndexer+ )+ where++import GHC.RTS.Events+import GHC.RTS.Events.Analysis++import Data.Map (Map)+import qualified Data.Map as M++-- | This state machine tracks threads residing on capabilities.+-- Each thread can only reside on one capability, but can be migrated between+-- them.+capabilityThreadPoolMachine :: Machine (Map ThreadId Int) CapEvent+capabilityThreadPoolMachine = Machine+ { initial = M.empty+ , final = const False+ , alpha = capabilityThreadPoolMachineAlpha+ , delta = capabilityThreadPoolMachineDelta+ }+ where+ capabilityThreadPoolMachineAlpha capEvent = case spec . ce_event $ capEvent of+ (CreateThread _) -> True+ (StopThread _ _) -> True+ (MigrateThread _ _) -> True+ _ -> False++ capabilityThreadPoolMachineDelta mapping capEvent = do+ capId <- ce_cap capEvent+ case spec . ce_event $ capEvent of+ (CreateThread threadId) -> insertThread threadId capId mapping+ (StopThread threadId ThreadFinished) -> deleteThread threadId mapping+ (StopThread _ _) -> Just mapping+ (MigrateThread threadId capId') -> deleteThread threadId mapping >>=+ insertThread threadId capId'+ _ -> Nothing+ where+ insertThread :: ThreadId -> Int -> Map ThreadId Int -> Maybe (Map ThreadId Int)+ insertThread threadId capId m+ | threadId `elem` M.keys m = Nothing -- The thread already exists+ | otherwise = Just $ M.insert threadId capId m++ deleteThread :: ThreadId -> Map ThreadId Int -> Maybe (Map ThreadId Int)+ deleteThread threadId m+ | notElem threadId . M.keys $ m = Nothing -- The thread doesn't exist+ | otherwise = Just $ M.delete threadId m++-- | This state machine tracks threads running on capabilities, only one thread+-- may run on a capability at a time.+capabilityThreadRunMachine :: Machine (Map Int ThreadId) CapEvent+capabilityThreadRunMachine = Machine+ { initial = M.empty+ , final = const False+ , alpha = threadRunAlpha+ , delta = threadRunDelta+ }+ where+ threadRunAlpha capEvent = case spec . ce_event $ capEvent of+ -- TODO: can threads be migrated while they are running?+ -- TODO: take into account paused threads+ (RunThread _) -> True+ (StopThread _ _ ) -> True+ _ -> False++ -- The indexer fails if a thread is inserted where one already exists,+ -- or if a thread is deleted that doesn't exist.+ threadRunDelta mapping e = do+ capId <- ce_cap e+ case spec . ce_event $ e of+ (RunThread threadId) -> runThread capId threadId mapping+ (StopThread threadId _ ) -> stopThread threadId mapping+ _ -> Just mapping+ where+ runThread :: Int -> ThreadId -> Map Int ThreadId -> Maybe (Map Int ThreadId)+ runThread capId threadId m+ | M.member capId m = Nothing -- A thread is already on this cap+ | threadId `elem` M.elems m = Nothing -- This thread is already on a cap+ | otherwise = Just $ M.insert capId threadId m+ stopThread :: ThreadId -> Map Int ThreadId -> Maybe (Map Int ThreadId)+ stopThread threadId m+ | notElem threadId . M.elems $ m = Nothing -- The thread doesn't exist+ | otherwise = Just $ M.filter (/= threadId) m++capabilityThreadIndexer :: Map Int ThreadId -> CapEvent -> Maybe ThreadId+capabilityThreadIndexer m capEvent = case spec . ce_event $ capEvent of+ (CreateSparkThread threadId) -> Just threadId+ (CreateThread threadId) -> Just threadId+ (RunThread threadId) -> Just threadId+ (StopThread threadId _) -> Just threadId+ (ThreadRunnable threadId) -> Just threadId+ (MigrateThread threadId _) -> Just threadId+ (WakeupThread threadId capId) -> if Just capId == ce_cap capEvent+ then Just threadId+ else Nothing+ _ -> mThreadId+ where+ mThreadId = ce_cap capEvent >>= (\capId -> M.lookup capId m)
+ GHC/RTS/Events/Analysis/SparkThread.hs view
@@ -0,0 +1,114 @@+module GHC.RTS.Events.Analysis.SparkThread+ ( SparkThreadState (..)+ , sparkThreadMachine+ , capabilitySparkThreadMachine+ , capabilitySparkThreadIndexer+ )+ where++import GHC.RTS.Events+import GHC.RTS.Events.Analysis++import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S++import Debug.Trace++data SparkThreadState+ = SparkThreadInitial+ | SparkThreadCreated+ | SparkThreadRunning Int+ | SparkThreadPaused Int+ | SparkThreadFinal+ deriving (Eq, Ord, Show)++sparkThreadMachine :: Machine SparkThreadState EventInfo+sparkThreadMachine = Machine+ { initial = SparkThreadInitial+ , final = sparkThreadFinal+ , alpha = sparkThreadAlpha+ , delta = sparkThreadDelta+ }+ where+ sparkThreadFinal SparkThreadFinal = True+ sparkThreadFinal _ = False++ -- sparkThreadAlpha (CreateSparkThread _) = True+ sparkThreadAlpha (RunThread _) = True+ sparkThreadAlpha (StopThread _ _) = True+ sparkThreadAlpha SparkRun = True+ sparkThreadAlpha (SparkSteal _) = True+ sparkThreadAlpha _ = False++ -- SparkThreadInitial+ -- sparkThreadDelta SparkThreadInitial (CreateSparkThread _) = Just SparkThreadInitial+ sparkThreadDelta SparkThreadInitial (RunThread _) = Just SparkThreadCreated+ -- SparkThreadCreated+ sparkThreadDelta SparkThreadCreated SparkRun = Just (SparkThreadRunning 0)+ sparkThreadDelta SparkThreadCreated (SparkSteal _) = Just (SparkThreadRunning 0)+ sparkThreadDelta SparkThreadCreated (StopThread _ ThreadFinished) = Just SparkThreadFinal+ -- SparkThreadRunning+ sparkThreadDelta (SparkThreadRunning n) (StopThread _ ThreadFinished) = Just SparkThreadFinal+ sparkThreadDelta (SparkThreadRunning n) (StopThread _ _) = Just (SparkThreadPaused n)+ sparkThreadDelta (SparkThreadRunning n) SparkRun = Just (SparkThreadRunning (n+1))+ sparkThreadDelta (SparkThreadRunning n) (SparkSteal _) = Just (SparkThreadRunning (n+1))+ -- SparkThreadPaused+ sparkThreadDelta (SparkThreadPaused n) (RunThread _) = Just (SparkThreadRunning n)+ -- Other+ sparkThreadDelta _ _ = Nothing++capabilitySparkThreadMachine :: Machine (Map Int ThreadId, Set ThreadId) CapEvent+capabilitySparkThreadMachine = Machine+ { initial = (M.empty, S.empty)+ , final = const False+ , alpha = capabilitySparkThreadAlpha+ , delta = capabilitySparkThreadDelta+ }+ where+ capabilitySparkThreadAlpha capEvent = case spec . ce_event $ capEvent of+ (CreateSparkThread _) -> True+ (RunThread _) -> True+ (StopThread _ _) -> True+ _ -> False+ capabilitySparkThreadDelta (m, s) e = do+ capId <- ce_cap e+ case spec . ce_event $ e of+ (CreateSparkThread threadId) -> createThread threadId+ -- (StopThread threadId ThreadFinished) -> stopThread threadId+ (StopThread threadId _) -> pauseThread threadId+ (RunThread threadId) -> runThread capId threadId+ _ -> Just (m, s)+ where+ createThread :: ThreadId -> Maybe (Map Int ThreadId, Set ThreadId)+ createThread threadId+ | S.member threadId s = Nothing -- A spark thread with this Id already created+ | otherwise = Just (m, S.insert threadId s)++ runThread :: Int -> ThreadId -> Maybe (Map Int ThreadId, Set ThreadId)+ runThread capId threadId+ | M.member capId m = Nothing -- A thread is already on this cap+ | threadId `elem` M.elems m = Nothing -- This thread is already on a cap+ | S.notMember threadId s = Just (m, s) -- Not a spark thread+ | otherwise = Just (M.insert capId threadId m, S.insert threadId s)++ stopThread :: ThreadId -> Maybe (Map Int ThreadId, Set ThreadId)+ stopThread threadId = Just (M.filter (/= threadId) m, S.delete threadId s)++ pauseThread :: ThreadId -> Maybe (Map Int ThreadId, Set ThreadId)+ pauseThread threadId = Just (M.filter (/= threadId) m, s)++capabilitySparkThreadIndexer :: (Map Int ThreadId, Set ThreadId) -> CapEvent -> Maybe ThreadId+capabilitySparkThreadIndexer (m, s) capEvent = case spec . ce_event $ capEvent of+ (CreateThread threadId) -> inSparkThreadPool threadId+ (RunThread threadId) -> inSparkThreadPool threadId+ (StopThread threadId _) -> inSparkThreadPool threadId+ -- (WakeupThread threadId _) -> inSparkThreadPool threadId+ _ -> ce_cap capEvent >>= (\capId -> M.lookup capId m)+ where+ inSparkThreadPool :: ThreadId -> Maybe ThreadId+ inSparkThreadPool threadId+ | S.member threadId s = Just threadId+ | otherwise = Nothing+
+ GHC/RTS/Events/Analysis/Thread.hs view
@@ -0,0 +1,53 @@+module GHC.RTS.Events.Analysis.Thread+ ( ThreadState (..)+ , threadMachine+ )+ where++import GHC.RTS.Events+import GHC.RTS.Events.Analysis++--------------------------------------------------------------------------------+-- | This datatype defines the state machine for a single thread.+data ThreadState+ = ThreadInitial+ | ThreadQueued+ | ThreadRunning+ | ThreadStopped+ | ThreadFinal+ deriving (Show, Eq, Ord)++-- | This state machine tracks the events processed by a thread.+threadMachine :: Machine ThreadState EventInfo+threadMachine = Machine+ { initial = ThreadInitial+ , final = threadFinal+ , alpha = threadAlpha+ , delta = threadDelta+ }+ where+ threadFinal ThreadFinal = True+ threadFinal _ = False++ threadAlpha (CreateThread _) = True+ threadAlpha (RunThread _) = True+ threadAlpha (StopThread _ _) = True+ threadAlpha (WakeupThread _ _) = True+ threadAlpha _ = False++ -- ThreadInitial+ threadDelta ThreadInitial (CreateThread _) = Just ThreadQueued+ -- ThreadQueued+ threadDelta ThreadQueued (RunThread _) = Just ThreadRunning+ threadDelta ThreadQueued (WakeupThread _ _) = Just ThreadQueued+ -- ThreadRunning+ threadDelta ThreadRunning (StopThread _ StackOverflow) = Just ThreadQueued+ threadDelta ThreadRunning (StopThread _ HeapOverflow) = Just ThreadQueued+ threadDelta ThreadRunning (StopThread _ ForeignCall) = Just ThreadQueued+ threadDelta ThreadRunning (StopThread _ ThreadFinished) = Just ThreadFinal+ threadDelta ThreadRunning (StopThread _ _) = Just ThreadStopped+ -- ThreadStopped+ threadDelta ThreadStopped (RunThread _) = Just ThreadRunning+ threadDelta ThreadStopped (WakeupThread _ _) = Just ThreadQueued+ -- Unknown+ threadDelta _ _ = Nothing
+ GHC/RTS/Events/Merge.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++module GHC.RTS.Events.Merge (mergeEventLogs) where++import GHC.RTS.Events+import Data.Monoid+import Data.List (foldl')+import Data.Word (Word32, Word16)++{-+GHC numbers caps and capsets in sequential order, starting at 0. Threads are+similarly numbered, but start at 1. In order to merge logs 'x' and 'y', we+find the maximum values of each variable type in 'x', then increment each+variable in 'y' that amount. This guarantees that variables in each log don't+clash, and that the meaning of each reference to a thread/cap/capset is+preserved.+-}++mergeEventLogs :: EventLog -> EventLog -> EventLog+mergeEventLogs (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) | h1 == h2+ = EventLog h1 . Data . mergeOn time xs $ shift (maxVars xs) ys+mergeEventLogs _ _ = error "can't merge eventlogs with non-matching headers"++mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]+mergeOn f [] ys = ys+mergeOn f xs [] = xs+mergeOn f (x:xs) (y:ys) | f x <= f y = x : mergeOn f xs (y:ys)+ | otherwise = y : mergeOn f (x:xs) ys++data MaxVars = MaxVars { mcapset :: !Word32+ , mcap :: !Int+ , mthread :: !ThreadId }++instance Monoid MaxVars where+ -- threads start at 1+ mempty = MaxVars 0 0 1+ mappend (MaxVars a b c) (MaxVars x y z) = MaxVars (max a x) (max b y) (max c z)+ -- avoid space leaks:+ mconcat = foldl' mappend mempty++-- Capabilities are represented as Word16. An event block marked with the+-- capability of 0xffff belongs to no capability+isCap :: Int -> Bool+isCap x = fromIntegral x /= ((-1) :: Word16)++maxVars :: [Event] -> MaxVars+maxVars = mconcat . map (maxSpec . spec)+ where+ -- only checking binding sites right now, sufficient?+ maxSpec (Startup n) = mempty { mcap = n - 1 }+ maxSpec (CreateThread t) = mempty { mthread = t }+ maxSpec (CreateSparkThread t) = mempty { mthread = t }+ maxSpec (CapsetCreate cs _) = mempty {mcapset = cs }+ maxSpec (EventBlock _ _ es) = maxVars es+ maxSpec _ = mempty++sh :: Num a => a -> a -> a+sh x y = x + y + 1++shift :: MaxVars -> [Event] -> [Event]+shift mv@(MaxVars mcs mc mt) = map (\(Event t s) -> Event t $ shift' s)+ where+ -- -1 marks a block that isn't attached to a particular capability+ shift' (EventBlock et c bs) = EventBlock et (msh c) $ shift mv bs+ where msh x = if isCap x then sh mc x else x+ shift' (CreateThread t) = CreateThread $ sh mt t+ shift' (RunThread t) = RunThread $ sh mt t+ shift' (StopThread t s) = StopThread (sh mt t) s+ shift' (ThreadRunnable t) = ThreadRunnable $ sh mt t+ shift' (MigrateThread t c) = MigrateThread (sh mt t) (sh mc c)+ shift' (CreateSparkThread t) = CreateSparkThread (sh mt t)+ shift' (WakeupThread t c) = WakeupThread (sh mt t) (sh mc c)+ shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst+ shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs)+ shift' (CapsetRemoveCap cs c) = CapsetRemoveCap (sh mcs cs) (sh mc c)+ shift' (RtsIdentifier cs rts) = RtsIdentifier (sh mcs cs) rts+ shift' (ProgramArgs cs as) = ProgramArgs (sh mcs cs) as+ shift' (ProgramEnv cs es) = ProgramEnv (sh mcs cs) es+ shift' (OsProcessPid cs pid) = OsProcessPid (sh mcs cs) pid+ shift' (OsProcessParentPid cs ppid) = OsProcessParentPid (sh mcs cs) ppid+ shift' x = x
+ GhcEvents.hs view
@@ -0,0 +1,217 @@+module Main where++import GHC.RTS.Events+import GHC.RTS.Events.Merge+import GHC.RTS.Events.Analysis+import GHC.RTS.Events.Analysis.SparkThread+import GHC.RTS.Events.Analysis.Thread+import GHC.RTS.Events.Analysis.Capability++import System.Environment+import Text.Printf+import Data.List+import Data.Either (rights)+import Data.Function+import Data.IntMap (IntMap)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import System.IO+import System.Exit++main = getArgs >>= command++command ["--help"] = do+ putStr usage++command ["show", file] = do+ log <- readLogOrDie file+ putStrLn $ ppEventLog log++command ["show", "threads", file] = do+ eventLog <- readLogOrDie file+ let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog+ let capEvents = sortEvents . events . dat $ eventLog+ let mappings = rights . validates capabilityThreadRunMachine $ capEvents+ let indexes = map (uncurry capabilityThreadIndexer) $ zip mappings capEvents+ let threadMap = M.fromListWith (++) . reverse $ zip indexes (map return capEvents)+ putStrLn "Event Types:"+ putStrLn . unlines . map ppEventType . eventTypes . header $ eventLog+ putStrLn "Thread Indexed Events:"+ putStrLn . showMap+ ((++ "\n") . show)+ (unlines . map ((" " ++) . ppEvent eventTypeMap)) $+ threadMap++command ["show", "caps", file] = do+ eventLog <- readLogOrDie file+ let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog+ let capEvents = sortEvents . events . dat $ eventLog+ let indexes = map ce_cap capEvents+ let capMap = M.fromListWith (++) . reverse $ zip indexes (map return capEvents)+ putStrLn "Event Types:"+ putStrLn . unlines . map ppEventType . eventTypes . header $ eventLog+ putStrLn "Cap Indexed Events:"+ putStrLn . showMap+ ((++ "\n") . show)+ (unlines . map ((" " ++) . ppEvent eventTypeMap)) $+ capMap++command ["merge", out, file1, file2] = do+ log1 <- readLogOrDie file1+ log2 <- readLogOrDie file2+ let m = mergeEventLogs log1 log2+ writeEventLogToFile out m++command ["validate", "threads", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = validate (routeM capabilityThreadRunMachine+ capabilityThreadIndexer+ (refineM (spec . ce_event) threadMachine))+ capEvents+ putStrLn $ showValidate (\(m, n) ->+ "\nThread States:\n" ++ showIndexed show show m +++ "\nCap States:\n" ++ showIndexed show show n)+ show result++command ["validate", "threadpool", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = validate capabilityThreadPoolMachine capEvents+ putStrLn $ showValidate show show result++command ["validate", "threadrun", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = validate capabilityThreadRunMachine capEvents+ putStrLn $ showValidate show show result++command ["validate", "sparks", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = validate+ (routeM capabilitySparkThreadMachine capabilitySparkThreadIndexer+ (refineM (spec . ce_event) sparkThreadMachine))+ capEvents+ putStrLn $ showValidate show show result++command ["simulate", "threads", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = simulate (routeM capabilityThreadRunMachine+ capabilityThreadIndexer+ (refineM (spec . ce_event) threadMachine))+ capEvents+ putStrLn . showProcess $ result++command ["simulate", "threadpool", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = simulate capabilityThreadPoolMachine capEvents+ putStrLn . showProcess $ result++command ["simulate", "threadrun", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = simulate capabilityThreadRunMachine capEvents+ putStrLn . showProcess $ result++command ["simulate", "sparks", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = simulate+ (routeM capabilitySparkThreadMachine+ capabilitySparkThreadIndexer+ (refineM (spec . ce_event) sparkThreadMachine))+ capEvents+ putStrLn . showProcess $ result++command ["profile", "threads", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = profileRouted+ (refineM (spec. ce_event) threadMachine)+ capabilityThreadRunMachine+ capabilityThreadIndexer+ (time . ce_event)+ capEvents+ putStrLn . showProcess $ result++command ["profile", "sparks", file] = do+ eventLog <- readLogOrDie file+ let capEvents = sortEvents . events . dat $ eventLog+ let result = profileRouted+ (refineM (spec . ce_event) sparkThreadMachine)+ capabilitySparkThreadMachine+ capabilitySparkThreadIndexer+ (time . ce_event)+ capEvents+ putStrLn . showProcess $ result++command _ = putStr usage >> die "Unrecognized command"++usage = unlines $ map pad strings+ where+ align = 4 + (maximum . map (length . fst) $ strings)+ pad (x, y) = zipWith const (x ++ repeat ' ') (replicate align ()) ++ y+ strings = [ ("ghc-events --help:", "Display this help.")++ , ("ghc-events show <file>:", "Pretty print an event log.")+ , ("ghc-events show threads <file>:", "Pretty print an event log, ordered by threads.")+ , ("ghc-events show caps <file>:", "Pretty print an event log, ordered by capabilities.")++ , ("ghc-events merge <out> <in1> <in2>:", "Merge two event logs.")++ , ("ghc-events sparks-csv <file>:", "Print spark information in CSV.")++ , ("ghc-events validate threads <file>:", "Validate thread states.")+ , ("ghc-events validate threadpool <file>:", "Validate thread pool state.")+ , ("ghc-events validate threadrun <file>:", "Validate thread running state.")+ , ("ghc-events validate sparks <file>:", "Validate spark thread states.")++ , ("ghc-events simulate threads <file>:", "Simulate thread states.")+ , ("ghc-events simulate threadpool <file>:", "Simulate thread pool state.")+ , ("ghc-events simulate threadrun <file>:", "Simulate thread running state.")+ , ("ghc-events simulate sparks <file>:", "Simulate spark thread states.")++ , ("ghc-events profile threads <file>:", "Profile thread states.")+ , ("ghc-events profile sparks <file>:", "Profile spark thread states.")+ ]++readLogOrDie file = do+ e <- readEventLogFromFile file+ case e of+ Left s -> die ("Failed to parse " ++ file ++ ": " ++ s)+ Right log -> return log++die s = do hPutStrLn stderr s; exitWith (ExitFailure 1)++showValidate :: (s -> String) -> (i -> String) -> Either (s, i) s -> String+showValidate showState showInput (Left (state, input)) =+ "Invalid eventlog:"+ ++ "\nState:\n" ++ ( showState state )+ ++ "\nInput:\n" ++ ( showInput input )+showValidate showState _ (Right state) =+ "Valid eventlog: " ++ ( showState state )++showProcess :: (Show e, Show a) => Process e a -> String+showProcess process =+ "Trace:\n"+ ++ (unlines . map show . toList) process+ ++ "\n"+ ++ (maybe "Valid." (("Invalid:\n" ++) . show) . toMaybe) process++showIndexed :: (k -> String) -> (v -> String) -> Map k v -> String+showIndexed showKey showValue m+ | M.null m = "Empty map\n"+ | otherwise = "Indexed output:\n" +++ concatMap (\(k, v) -> "Key: " ++ ( showKey k ) ++ ", Value: "+ ++ ( showValue v ) ++ "\n")+ (M.toList m)++showMap :: Ord k => (k -> String) -> (a -> String) -> M.Map k a -> String+showMap showKey showValue m =+ concat $ zipWith (++)+ (map showKey . M.keys $ m :: [String])+ (map (showValue . (M.!) m) . M.keys $ m :: [String])
− MergeGhcEvents.hs
@@ -1,88 +0,0 @@-{-# OPTIONS_GHC -funbox-strict-fields #-}--import GHC.RTS.Events-import System.Environment-import Data.Monoid-import Data.List (foldl')-import Data.Word (Word32, Word16)---- todo, proper error handling-main = do- [out, file1, file2] <- getArgs- Right f1 <- readEventLogFromFile file1- Right f2 <- readEventLogFromFile file2- let m = merge f1 f2- writeEventLogToFile out m--{--GHC numbers caps and capsets in sequential order, starting at 0. Threads are-similarly numbered, but start at 1. In order to merge logs 'x' and 'y', we-find the maximum values of each variable type in 'x', then increment each-variable in 'y' that amount. This guarantees that variables in each log don't-clash, and that the meaning of each reference to a thread/cap/capset is-preserved.--}--merge :: EventLog -> EventLog -> EventLog-merge (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) | h1 == h2- = EventLog h1 . Data . mergeOn time xs $ shift (maxVars xs) ys-merge _ _ = error "can't merge eventlogs with non-matching headers"--mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]-mergeOn f [] ys = ys-mergeOn f xs [] = xs-mergeOn f (x:xs) (y:ys) | f x <= f y = x : mergeOn f xs (y:ys)- | otherwise = y : mergeOn f (x:xs) ys--data MaxVars = MaxVars { mcapset :: !Word32- , mcap :: !Int- , mthread :: !ThreadId }--instance Monoid MaxVars where- -- threads start at 1- mempty = MaxVars 0 0 1- mappend (MaxVars a b c) (MaxVars x y z) = MaxVars (max a x) (max b y) (max c z)- -- avoid space leaks:- mconcat = foldl' mappend mempty---- Capabilities are represented as Word16. An event block marked with the--- capability of 0xffff belongs to no capability-isCap :: Int -> Bool-isCap x = fromIntegral x /= ((-1) :: Word16)--maxVars :: [Event] -> MaxVars-maxVars = mconcat . map (maxSpec . spec)- where- -- only checking binding sites right now, sufficient?- maxSpec (Startup n) = mempty { mcap = n - 1 }- maxSpec (CreateThread t) = mempty { mthread = t }- maxSpec (CreateSparkThread t) = mempty { mthread = t }- maxSpec (CapsetCreate cs _) = mempty {mcapset = cs }- maxSpec (EventBlock _ _ es) = maxVars es- maxSpec _ = mempty--sh :: Num a => a -> a -> a-sh x y = x + y + 1--shift :: MaxVars -> [Event] -> [Event]-shift mv@(MaxVars mcs mc mt) = map (\(Event t s) -> Event t $ shift' s)- where- -- -1 marks a block that isn't attached to a particular capability- shift' (EventBlock et c bs) = EventBlock et (msh c) $ shift mv bs- where msh x = if isCap x then sh mc x else x- shift' (CreateThread t) = CreateThread $ sh mt t- shift' (RunThread t) = RunThread $ sh mt t- shift' (StopThread t s) = StopThread (sh mt t) s- shift' (ThreadRunnable t) = ThreadRunnable $ sh mt t- shift' (MigrateThread t c) = MigrateThread (sh mt t) (sh mc c)- shift' (CreateSparkThread t) = CreateSparkThread (sh mt t)- shift' (WakeupThread t c) = WakeupThread (sh mt t) (sh mc c)- shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst- shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs)- shift' (CapsetRemoveCap cs c) = CapsetRemoveCap (sh mcs cs) (sh mc c)- shift' (RtsIdentifier cs rts) = RtsIdentifier (sh mcs cs) rts- shift' (ProgramArgs cs as) = ProgramArgs (sh mcs cs) as- shift' (ProgramEnv cs es) = ProgramEnv (sh mcs cs) es- shift' (OsProcessPid cs pid) = OsProcessPid (sh mcs cs) pid- shift' (OsProcessParentPid cs ppid) = OsProcessParentPid (sh mcs cs) ppid- shift' x = x
− ShowGhcEvents.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Main where--import GHC.RTS.Events as Log-import System.Environment-import Text.Printf-import Data.List-import Data.Function-import Data.IntMap (IntMap)-import qualified Data.IntMap as M-import Data.Maybe-import System.IO-import System.Exit--main = do- [file] <- getArgs-- log <- do e <- readEventLogFromFile file- case e of- Left s -> die ("Failed to parse " ++ file ++ ": " ++ s)- Right log -> return log- - putStrLn $ ppEventLog log--die s = do hPutStrLn stderr s; exitWith (ExitFailure 1)
ghc-events.cabal view
@@ -1,20 +1,21 @@ name: ghc-events-version: 0.3.0.1+version: 0.4.0.0 synopsis: Library and tool for parsing .eventlog files from GHC description: Parses .eventlog files emitted by GHC 6.12.1 and later.- Includes the show-ghc-events tool to dump an event- log file as text.+ Includes the ghc-events tool permitting, in particular,+ to dump an event log file as text. category: Development, GHC, Debug, Profiling, Trace license: BSD3 license-file: LICENSE-author: Donnie Jones <donnie@darthik.com>, +author: Donnie Jones <donnie@darthik.com>, Simon Marlow <marlowsd@gmail.com>, Paul Bone <pbone@csse.unimelb.edu.au>, Duncan Coutts <duncan@well-typed.com>+ Nicolas Wu <nick@well-typed.com> maintainer: Simon Marlow <marlowsd@gmail.com> bug-reports: http://trac.haskell.org/ThreadScope/ build-type: Simple-tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1+tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 cabal-version: >= 1.8 extra-source-files: GHC/RTS/EventLogFormat.h, AUTHORS,@@ -30,19 +31,21 @@ containers >= 0.2 && < 0.5, binary == 0.5.*, bytestring == 0.9.*,- array == 0.3.*- exposed-modules: GHC.RTS.Events+ array >= 0.2 && < 0.5+ exposed-modules: GHC.RTS.Events,+ GHC.RTS.Events.Merge+ GHC.RTS.Events.Analysis+ GHC.RTS.Events.Analysis.Capability+ GHC.RTS.Events.Analysis.SparkThread+ GHC.RTS.Events.Analysis.Thread other-modules: GHC.RTS.EventParserUtils, GHC.RTS.EventTypes- extensions: CPP--executable ghc-events-show- main-is: ShowGhcEvents.hs- build-depends: base, mtl, containers, binary, bytestring, array+ extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards -executable ghc-events-merge- main-is: MergeGhcEvents.hs+executable ghc-events+ main-is: GhcEvents.hs build-depends: base, mtl, containers, binary, bytestring, array+ extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards test-suite test-versions type: exitcode-stdio-1.0
test/TestVersions.hs view
@@ -2,14 +2,14 @@ This test parses sample event logs from each major GHC version and compares the pretty printed output with reference output. -When tests fail, use a diff tool to compare the output of show-ghc-events with+When tests fail, use a diff tool to compare the output of "ghc-events show" with the reference file. Resolve the differences in either the library code or the reference file, and 'darcs record' the changes. Steps to produce event log and reference output: $ ghc --make queens.hs -o queens-ghc-$VERSION -threaded -eventlog $ queens-ghc-$VERSION 8 +RTS -N4 -ls- $ show-ghc-events queens-ghc-$VERSION.eventlog > queens-ghc-$VERSION.eventlog.reference+ $ ghc-events show queens-ghc-$VERSION.eventlog > queens-ghc-$VERSION.eventlog.reference Where queens.hs is http://darcs.haskell.org/nofib/parallel/queens/Main.hs -}