diff --git a/AUTHORS b/AUTHORS deleted file mode 100644 --- a/AUTHORS +++ /dev/null @@ -1,2 +0,0 @@ -Donnie Jones -Simon Marlow diff --git a/GHC/RTS/EventLogFormat.h b/GHC/RTS/EventLogFormat.h --- a/GHC/RTS/EventLogFormat.h +++ b/GHC/RTS/EventLogFormat.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 2008-2009 + * (c) The GHC Team, 2008-2012 * * Event log format * @@ -158,8 +158,12 @@ par_n_threads, par_max_copied, par_tot_copied) */ #define EVENT_GC_GLOBAL_SYNC 54 /* () */ +#define EVENT_TASK_CREATE 55 /* (taskID, cap, tid) */ +#define EVENT_TASK_MIGRATE 56 /* (taskID, cap, new_cap) */ +#define EVENT_TASK_DELETE 57 /* (taskID) */ +#define EVENT_USER_MARKER 58 /* (marker_name) */ -/* Range 55 - 59 is available for new GHC and common events */ +/* Range 59 - 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/ @@ -167,12 +171,14 @@ /* Range 100 - 139 is reserved for Mercury, see below. */ +/* Range 140 - 159 is reserved for Perf events, see below. */ + /* * The highest event code +1 that ghc itself emits. Note that some event * 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 55 +#define NUM_GHC_EVENT_TAGS 59 /* DEPRECATED EVENTS: */ @@ -216,6 +222,18 @@ #define EVENT_MER_RELEASE_CONTEXT 110 /* (context id) */ #define EVENT_MER_ENGINE_SLEEPING 111 /* () */ #define EVENT_MER_CALLING_MAIN 113 /* () */ + + +/* + * These event types are parsed from hardware performance counters logs, + * such as the Linux Performance Counters data available through + * the perf subsystem. + */ + +#define EVENT_PERF_NAME 140 /* (perf_num, name) */ +#define EVENT_PERF_COUNTER 141 /* (perf_num, tid, period) */ +#define EVENT_PERF_TRACEPOINT 142 /* (perf_num, tid) */ + /* * Status values for EVENT_STOP_THREAD diff --git a/GHC/RTS/EventTypes.hs b/GHC/RTS/EventTypes.hs --- a/GHC/RTS/EventTypes.hs +++ b/GHC/RTS/EventTypes.hs @@ -2,7 +2,8 @@ module GHC.RTS.EventTypes where -import Data.Word (Word16, Word32, Word64) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Binary -- EventType. type EventTypeNum = Word16 @@ -19,7 +20,16 @@ type RawThreadStopStatus = Word16 type StringId = Word32 type Capset = Word32 +type PerfEventTypeNum = Word32 +type TaskId = Word64 +type PID = Word32 +newtype KernelThreadId = KernelThreadId { kernelThreadId :: Word64 } + deriving (Eq, Ord, Show) +instance Binary KernelThreadId where + put (KernelThreadId tid) = put tid + get = fmap KernelThreadId get + -- These types are used by Mercury events. type ParConjDynId = Word64 type ParConjStaticId = StringId @@ -48,10 +58,16 @@ + sz_time + sz_cap) sz_pid :: EventTypeSize sz_pid = 4 +sz_taskid :: EventTypeSize +sz_taskid = 8 +sz_kernel_tid :: EventTypeSize +sz_kernel_tid = 8 sz_th_stop_status :: EventTypeSize sz_th_stop_status = 2 sz_string_id :: EventTypeSize sz_string_id = 4 +sz_perf_num :: EventTypeSize +sz_perf_num = 4 -- Sizes for Mercury event fields. sz_par_conj_dyn_id :: EventTypeSize @@ -148,6 +164,17 @@ | SparkFizzle { } | SparkGC { } + -- tasks + | TaskCreate { taskId :: TaskId, + cap :: {-# UNPACK #-}!Int, + tid :: {-# UNPACK #-}!KernelThreadId + } + | TaskMigrate { taskId :: TaskId, + cap :: {-# UNPACK #-}!Int, + new_cap :: {-# UNPACK #-}!Int + } + | TaskDelete { taskId :: TaskId } + -- garbage collection | RequestSeqGC { } | RequestParGC { } @@ -218,10 +245,10 @@ , env :: [String] } | OsProcessPid { capset :: {-# UNPACK #-}!Capset - , pid :: {-# UNPACK #-}!Word32 + , pid :: {-# UNPACK #-}!PID } | OsProcessParentPid { capset :: {-# UNPACK #-}!Capset - , ppid :: {-# UNPACK #-}!Word32 + , ppid :: {-# UNPACK #-}!PID } | WallClockTime { capset :: {-# UNPACK #-}!Capset , sec :: {-# UNPACK #-}!Word64 @@ -231,6 +258,7 @@ -- messages | Message { msg :: String } | UserMessage { msg :: String } + | UserMarker { markername :: String } -- These events have been added for Mercury's benifit but are generally -- useful. @@ -272,6 +300,18 @@ } | MerCapSleeping | MerCallingMain + + -- perf events + | PerfName { perfNum :: {-# UNPACK #-}!PerfEventTypeNum + , name :: String + } + | PerfCounter { perfNum :: {-# UNPACK #-}!PerfEventTypeNum + , tid :: {-# UNPACK #-}!KernelThreadId + , period :: {-# UNPACK #-}!Word64 + } + | PerfTracepoint { perfNum :: {-# UNPACK #-}!PerfEventTypeNum + , tid :: {-# UNPACK #-}!KernelThreadId + } deriving Show diff --git a/GHC/RTS/Events.hs b/GHC/RTS/Events.hs --- a/GHC/RTS/Events.hs +++ b/GHC/RTS/Events.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP,BangPatterns,PatternGuards #-} {-# OPTIONS_GHC -funbox-strict-fields -fwarn-incomplete-patterns #-} {- - - Authors: Donnie Jones, Simon Marlow, Paul Bone, Duncan Coutts - - Events.hs - Parser functions for GHC RTS EventLog framework. -} @@ -18,6 +16,8 @@ CapsetType(..), Timestamp, ThreadId, + TaskId, + KernelThreadId(..), -- * Reading and writing event logs readEventLogFromFile, @@ -29,7 +29,11 @@ -- * Printing showEventInfo, showThreadStopStatus, - ppEventLog, ppEventType, ppEvent + ppEventLog, ppEventType, ppEvent, + + -- * Perf events + nEVENT_PERF_NAME, nEVENT_PERF_COUNTER, nEVENT_PERF_TRACEPOINT, + sz_perf_num, sz_kernel_tid ) where {- Libraries. -} @@ -263,7 +267,6 @@ return WallClockTime{capset=cs,sec=s,nsec=ns} )), - (VariableSizeParser EVENT_LOG_MSG (do -- (msg) num <- getE :: GetEvents Word16 string <- getString num @@ -274,6 +277,11 @@ string <- getString num return UserMessage{ msg = string } )), + (VariableSizeParser EVENT_USER_MARKER (do -- (markername) + num <- getE :: GetEvents Word16 + string <- getString num + return UserMarker{ markername = string } + )), (VariableSizeParser EVENT_PROGRAM_ARGS (do -- (capset, [arg]) num <- getE :: GetEvents Word16 cs <- getE @@ -405,6 +413,25 @@ (simpleEvent EVENT_SPARK_FIZZLE SparkFizzle), (simpleEvent EVENT_SPARK_GC SparkGC), + (FixedSizeParser EVENT_TASK_CREATE (sz_taskid + sz_cap + sz_kernel_tid) (do -- (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 } + )), + (FixedSizeParser EVENT_THREAD_WAKEUP (sz_tid + sz_cap) (do -- (thread, other_cap) t <- getE oc <- getE :: GetEvents CapNo @@ -544,6 +571,28 @@ ] +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 @@ -586,8 +635,8 @@ -} event_parsers = if is_ghc_6 then standardParsers ++ ghc6Parsers - else standardParsers ++ ghc7Parsers ++ - mercuryParsers + else standardParsers ++ ghc7Parsers + ++ mercuryParsers ++ perfParsers parsers = mkEventTypeParsers imap event_parsers dat <- runReaderT getData (EventParsers parsers) return (EventLog header dat) @@ -703,6 +752,14 @@ 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 -> @@ -747,6 +804,8 @@ 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 -> @@ -799,6 +858,14 @@ "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" @@ -926,10 +993,14 @@ 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 @@ -968,7 +1039,15 @@ 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) @@ -1097,13 +1176,26 @@ 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 gen + putE (fromIntegral gen :: Word16) putE copied putE slop putE frag - putE parNThreads + putE (fromIntegral parNThreads :: Word32) putE parMaxCopied putE parTotCopied @@ -1121,7 +1213,7 @@ putEventSpec HeapInfoGHC{..} = do putE heapCapset - putE gens + putE (fromIntegral gens :: Word16) putE maxHeapSize putE allocAreaSize putE mblockSize @@ -1159,19 +1251,19 @@ putCap cp putEventSpec (RtsIdentifier cs rts) = do - putE (fromIntegral (length rts) + 4 :: Word16) + putE (fromIntegral (length rts) + sz_capset :: Word16) putE cs putEStr rts putEventSpec (ProgramArgs cs as) = do let as' = unsep as - putE (fromIntegral (length as') + 4 :: Word16) + 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') + 4 :: Word16) + putE (fromIntegral (length es') + sz_capset :: Word16) putE cs mapM_ putE es' @@ -1196,6 +1288,10 @@ 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 @@ -1240,6 +1336,20 @@ 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 diff --git a/GHC/RTS/Events/Analysis.hs b/GHC/RTS/Events/Analysis.hs --- a/GHC/RTS/Events/Analysis.hs +++ b/GHC/RTS/Events/Analysis.hs @@ -64,7 +64,7 @@ | 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. +-- is started from its initial state and run against 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)) @@ -280,4 +280,3 @@ Nothing -> return m else return m return (m', r') - diff --git a/GHC/RTS/Events/Analysis/Capability.hs b/GHC/RTS/Events/Analysis/Capability.hs --- a/GHC/RTS/Events/Analysis/Capability.hs +++ b/GHC/RTS/Events/Analysis/Capability.hs @@ -2,6 +2,8 @@ ( capabilityThreadPoolMachine , capabilityThreadRunMachine , capabilityThreadIndexer + , capabilityTaskPoolMachine + , capabilityTaskOSMachine ) where @@ -40,13 +42,13 @@ 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 + | threadId `M.member` 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 + | threadId `M.notMember` 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. @@ -76,7 +78,7 @@ 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 + | capId `M.member` 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) @@ -98,3 +100,110 @@ _ -> mThreadId where mThreadId = ce_cap capEvent >>= (\capId -> M.lookup capId m) + +-- | This state machine tracks Haskell tasks, represented by TaskId, +-- residing on capabilities. +-- Each Haskell task can only reside on one capability, but can be migrated +-- between them. +capabilityTaskPoolMachine :: Machine (Map TaskId Int) CapEvent +capabilityTaskPoolMachine = Machine + { initial = M.empty + , final = const False + , alpha = capabilityTaskPoolMachineAlpha + , delta = capabilityTaskPoolMachineDelta + } + where + capabilityTaskPoolMachineAlpha capEvent = case spec . ce_event $ capEvent of + TaskCreate{} -> True + TaskDelete{} -> True + TaskMigrate{} -> True + _ -> False + + capabilityTaskPoolMachineDelta mapping capEvent = do + case spec . ce_event $ capEvent of + TaskCreate {taskId, cap} -> insertTask taskId cap mapping + TaskDelete {taskId} -> deleteTask taskId Nothing mapping + TaskMigrate {taskId, cap, new_cap} -> + deleteTask taskId (Just cap) mapping >>= + insertTask taskId new_cap + _ -> Nothing + where + insertTask :: TaskId -> Int -> Map TaskId Int + -> Maybe (Map TaskId Int) + insertTask taskId cap m + | taskId `M.member` m = Nothing -- The task already exists. + | otherwise = Just $ M.insert taskId cap m + + deleteTask :: TaskId -> Maybe Int -> Map TaskId Int + -> Maybe (Map TaskId Int) + deleteTask taskId expectedcap m + | Just oldcap <- M.lookup taskId m + , maybe True (==oldcap) expectedcap + = Just $ M.delete taskId m + | otherwise + = Nothing -- The task doesn't exist, or does but with an unexpected cap. + +-- | This state machine tracks Haskell tasks (represented by the KernelThreadId +-- of their OS thread) residing on capabilities and additionally +-- tracks the (immutable) assignment of OS thread ids (KernelThreadId) +-- to tasks ids (TaskId). +-- Each Haskell task can only reside on one capability, but can be migrated +-- between them. +-- +-- Invariant for the @(Map KernelThreadId Int, Map TaskId KernelThreadId)@ +-- type: the second map is an injection (verified by the machine +-- in 'insertTaskOS') and the following sets are equal: +-- keys of the fist map and values of the second +-- (follows from the construction of the maps by the machine). +-- +-- The machine verifies as much as 'capabilityTaskPoolMachine' and additionally +-- the data invariant, and offers a richer verification profile. +capabilityTaskOSMachine :: Machine (Map KernelThreadId Int, + Map TaskId KernelThreadId) + CapEvent +capabilityTaskOSMachine = Machine + { initial = (M.empty, M.empty) + , final = const False + , alpha = capabilityTaskOSMachineAlpha + , delta = capabilityTaskOSMachineDelta + } + where + capabilityTaskOSMachineAlpha capEvent = case spec . ce_event $ capEvent of + TaskCreate{} -> True + TaskDelete{} -> True + TaskMigrate{} -> True + _ -> False + + capabilityTaskOSMachineDelta mapping capEvent = do + case spec . ce_event $ capEvent of + TaskCreate {taskId, cap, tid} -> insertTaskOS taskId cap tid mapping + TaskDelete {taskId} -> deleteTaskOS taskId mapping + TaskMigrate {taskId, new_cap} -> migrateTaskOS taskId new_cap mapping + _ -> Nothing + where + insertTaskOS :: TaskId -> Int -> KernelThreadId + -> (Map KernelThreadId Int, Map TaskId KernelThreadId) + -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId) + insertTaskOS taskId cap tid (m, ma) + | taskId `M.member` ma = Nothing -- The task already exists. + | tid `M.member` m = Nothing -- The OS thread already exists. + | otherwise = Just (M.insert tid cap m, + M.insert taskId tid ma) + + deleteTaskOS :: TaskId -> (Map KernelThreadId Int, + Map TaskId KernelThreadId) + -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId) + deleteTaskOS taskId (m, ma) = + case M.lookup taskId ma of + Nothing -> Nothing -- The task doesn't exist. + Just tid -> Just (M.delete tid m, + M.delete taskId ma) + + migrateTaskOS :: TaskId -> Int -> (Map KernelThreadId Int, + Map TaskId KernelThreadId) + -> Maybe (Map KernelThreadId Int, Map TaskId KernelThreadId) + migrateTaskOS taskId new_cap (m, ma) = + case M.lookup taskId ma of + Nothing -> Nothing -- The task doesn't exist. + Just tid -> Just (M.insert tid new_cap m, + ma) -- The assignment is immutable. diff --git a/GHC/RTS/Events/Merge.hs b/GHC/RTS/Events/Merge.hs --- a/GHC/RTS/Events/Merge.hs +++ b/GHC/RTS/Events/Merge.hs @@ -5,21 +5,37 @@ import GHC.RTS.Events import Data.Monoid import Data.List (foldl') +import qualified Data.Map as M import Data.Word (Word32, Word16) +-- TODO: add a merge mode where the events are synchronized using +-- the wall clock time event at the start of both eventlogs (for newer GHCs). +-- Such merge is not associative so we either need to take many arguments +-- or cope with eventlogs with many wall clock time events (assume they +-- are products of previous merges). To decide. + {- 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 +similarly numbered, but start at 1. In order to merge logs 'x' and 'y', +we find the # of occupied numbers for each variable type in 'x', +then increment each variable in 'y' by that amount. +We assume that if a number is occupied, so are all lower numbers. +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" +mergeEventLogs (EventLog h1 (Data xs)) (EventLog h2 (Data ys)) = + let headerMap = M.fromList . map (\ et@EventType {num} -> (num, et)) + m1 = headerMap $ eventTypes h1 + m2 = headerMap $ eventTypes h2 + combine et1 et2 | et1 == et2 = et1 + combine _ _ = error "can't merge eventlogs with inconsistent headers" + m = M.unionWith combine m1 m2 + h = Header $ M.elems m + in h == h `seq` -- Detect inconsistency ASAP. + EventLog h . Data . mergeOn time xs $ shift (maxVars xs) ys mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a] mergeOn f [] ys = ys @@ -27,14 +43,15 @@ mergeOn f (x:xs) (y:ys) | f x <= f y = x : mergeOn f xs (y:ys) | otherwise = y : mergeOn f (x:xs) ys +-- TODO: rename, since these are not maximal values, but numbers of used values 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) + mempty = MaxVars 0 0 0 + mappend (MaxVars a b c) (MaxVars x y z) = + MaxVars (max a x) (b + y) (max c z) -- avoid space leaks: mconcat = foldl' mappend mempty @@ -43,19 +60,27 @@ isCap :: Int -> Bool isCap x = fromIntegral x /= ((-1) :: Word16) +-- For caps we find the maximum value by summing the @Startup@ declarations. +-- TODO: it's not trivial to add CapCreate since we don't know +-- if created caps are guaranteed to be numbered consecutively or not +-- (are they? is it asserted in GHC code somewhere?). We might instead +-- just scan all events mentioning a cap and take the maximum, +-- but it's a slower and much longer code, requiring constant maintenance. maxVars :: [Event] -> MaxVars maxVars = mconcat . map (maxSpec . spec) where -- only checking binding sites right now, sufficient? - maxSpec (Startup n) = mempty { mcap = n - 1 } + maxSpec (Startup n) = mempty { mcap = n } + -- Threads start at 1. maxSpec (CreateThread t) = mempty { mthread = t } maxSpec (CreateSparkThread t) = mempty { mthread = t } - maxSpec (CapsetCreate cs _) = mempty {mcapset = cs } + -- Capsets start at 0. + maxSpec (CapsetCreate cs _) = mempty {mcapset = cs + 1 } maxSpec (EventBlock _ _ es) = maxVars es maxSpec _ = mempty sh :: Num a => a -> a -> a -sh x y = x + y + 1 +sh x y = x + y shift :: MaxVars -> [Event] -> [Event] shift mv@(MaxVars mcs mc mt) = map (\(Event t s) -> Event t $ shift' s) @@ -68,14 +93,24 @@ 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' (ThreadLabel t l) = ThreadLabel (sh mt t) l + shift' (CreateSparkThread t) = CreateSparkThread (sh mt t) + shift' (SparkSteal c) = SparkSteal (sh mc c) + shift' (TaskCreate tk c tid) = TaskCreate tk (sh mc c) tid + shift' (TaskMigrate tk c1 c2) = TaskMigrate tk (sh mc c1) (sh mc c2) + shift' (CapCreate c) = CapCreate (sh mc c) -- TODO: correct? + shift' (CapDelete c) = CapDelete (sh mc c) -- TODO: correct? + shift' (CapDisable c) = CapDisable (sh mc c) + shift' (CapEnable c) = CapEnable (sh mc c) shift' (CapsetCreate cs cst) = CapsetCreate (sh mcs cs) cst shift' (CapsetDelete cs) = CapsetDelete (sh mcs cs) + shift' (CapsetAssignCap cs c) = CapsetAssignCap (sh mcs cs) (sh mc c) 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' (WallClockTime cs sec nsec) = WallClockTime (sh mcs cs) sec nsec shift' x = x diff --git a/GhcEvents.hs b/GhcEvents.hs --- a/GhcEvents.hs +++ b/GhcEvents.hs @@ -30,7 +30,7 @@ command ["show", "threads", file] = do eventLog <- readLogOrDie file - let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog + 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 @@ -45,7 +45,7 @@ command ["show", "caps", file] = do eventLog <- readLogOrDie file - let eventTypeMap = buildEventTypeMap . eventTypes . header $ eventLog + 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) @@ -87,6 +87,18 @@ let result = validate capabilityThreadRunMachine capEvents putStrLn $ showValidate show show result +command ["validate", "taskpool", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = validate capabilityTaskPoolMachine capEvents + putStrLn $ showValidate show show result + +command ["validate", "tasks", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = validate capabilityTaskOSMachine capEvents + putStrLn $ showValidate show show result + command ["validate", "sparks", file] = do eventLog <- readLogOrDie file let capEvents = sortEvents . events . dat $ eventLog @@ -117,6 +129,18 @@ let result = simulate capabilityThreadRunMachine capEvents putStrLn . showProcess $ result +command ["simulate", "taskpool", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = simulate capabilityTaskPoolMachine capEvents + putStrLn . showProcess $ result + +command ["simulate", "tasks", file] = do + eventLog <- readLogOrDie file + let capEvents = sortEvents . events . dat $ eventLog + let result = simulate capabilityTaskOSMachine capEvents + putStrLn . showProcess $ result + command ["simulate", "sparks", file] = do eventLog <- readLogOrDie file let capEvents = sortEvents . events . dat $ eventLog @@ -168,11 +192,13 @@ , ("ghc-events validate threads :", "Validate thread states.") , ("ghc-events validate threadpool :", "Validate thread pool state.") , ("ghc-events validate threadrun :", "Validate thread running state.") + , ("ghc-events validate tasks :", "Validate task states.") , ("ghc-events validate sparks :", "Validate spark thread states.") , ("ghc-events simulate threads :", "Simulate thread states.") , ("ghc-events simulate threadpool :", "Simulate thread pool state.") , ("ghc-events simulate threadrun :", "Simulate thread running state.") + , ("ghc-events simulate tasks :", "Simulate task states.") , ("ghc-events simulate sparks :", "Simulate spark thread states.") , ("ghc-events profile threads :", "Profile thread states.") diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,21 @@ The Glasgow Haskell Compiler License -Copyright 2002, The University Court of the University of Glasgow. -All rights reserved. +Copyright 2002-2012, The University Court of the University of Glasgow +and others. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without -specific prior written permission. +specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, diff --git a/ghc-events.cabal b/ghc-events.cabal --- a/ghc-events.cabal +++ b/ghc-events.cabal @@ -1,31 +1,24 @@ name: ghc-events -version: 0.4.0.1 +version: 0.4.2.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 @ghc-events@ tool which dumps an event log file - as text. - . - Changes in 0.4.0.1: - . - * compiles with GHC 7.6.1 - +description: Parses .eventlog files emitted by GHC 6.12.1 and later. + 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 , Simon Marlow , Paul Bone , - Duncan Coutts - Nicolas Wu + Duncan Coutts , + Nicolas Wu , + Mikolaj Konarski maintainer: Simon Marlow bug-reports: http://trac.haskell.org/ThreadScope/ build-type: Simple -tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 +tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1 cabal-version: >= 1.8 extra-source-files: GHC/RTS/EventLogFormat.h, - AUTHORS, test/*.eventlog source-repository head @@ -34,9 +27,9 @@ library build-depends: base == 4.*, - mtl >= 1.1 && < 2.2, + mtl >= 1.1 && < 3.0, containers >= 0.2 && < 0.6, - binary == 0.5.*, + binary >= 0.5 && < 0.7, bytestring >= 0.9.0, array >= 0.2 && < 0.5 exposed-modules: GHC.RTS.Events, @@ -47,6 +40,7 @@ GHC.RTS.Events.Analysis.Thread other-modules: GHC.RTS.EventParserUtils, GHC.RTS.EventTypes + include-dirs: GHC/RTS extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards executable ghc-events @@ -58,3 +52,4 @@ type: exitcode-stdio-1.0 main-is: test/TestVersions.hs build-depends: base, mtl, containers, binary, bytestring, array + extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards