threadscope 0.2.7 → 0.2.8
raw patch · 15 files changed
+247/−224 lines, 15 filesdep +gtk-mac-integrationdep ~arraydep ~basedep ~binarynew-uploader
Dependencies added: gtk-mac-integration
Dependency ranges changed: array, base, binary, cairo, filepath, ghc-events, glib, gtk, mtl, pango, text, time
Files
- Events/EventDuration.hs +15/−15
- Events/EventTree.hs +6/−6
- Events/HECs.hs +14/−8
- Events/ReadEvents.hs +31/−39
- Events/SparkTree.hs +3/−3
- Events/TestEvents.hs +70/−97
- GUI/App.hs +37/−0
- GUI/EventsView.hs +5/−4
- GUI/GtkExtras.hs +6/−3
- GUI/Main.hs +3/−2
- GUI/ProgressView.hs +0/−3
- GUI/StartupInfoView.hs +6/−6
- GUI/SummaryView.hs +19/−22
- GUI/Timeline/HEC.hs +9/−9
- threadscope.cabal +23/−7
Events/EventDuration.hs view
@@ -10,8 +10,8 @@ ) where -- Imports for GHC Events+import GHC.RTS.Events hiding (Event, GCIdle, GCWork) import qualified GHC.RTS.Events as GHC-import GHC.RTS.Events hiding (Event,GCWork,GCIdle) ------------------------------------------------------------------------------- -- This datastructure is a duration-based representation of the event@@ -86,23 +86,23 @@ eventsToDurations :: [GHC.Event] -> [EventDuration] eventsToDurations [] = [] eventsToDurations (event : events) =- case spec event of+ case evSpec event of RunThread{thread=t} -> runDuration t : rest StopThread{} -> rest- StartGC -> gcStart (time event) events+ StartGC -> gcStart (evTime event) events EndGC{} -> rest _otherEvent -> rest where rest = eventsToDurations events - runDuration t = ThreadRun t s (time event) endTime+ runDuration t = ThreadRun t s (evTime event) endTime where (endTime, s) = case findRunThreadTime events of Nothing -> error $ "findRunThreadTime for " ++ (show event) Just x -> x isDiscreteEvent :: GHC.Event -> Bool isDiscreteEvent e =- case spec e of+ case evSpec e of RunThread{} -> False StopThread{} -> False StartGC{} -> False@@ -116,7 +116,7 @@ gcStart :: Timestamp -> [GHC.Event] -> [EventDuration] gcStart _ [] = [] gcStart t0 (event : events) =- case spec event of+ case evSpec event of GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events@@ -124,12 +124,12 @@ RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events) _other -> gcStart t0 events where- t1 = time event+ t1 = evTime event gcWork :: Timestamp -> [GHC.Event] -> [EventDuration] gcWork _ [] = [] gcWork t0 (event : events) =- case spec event of+ case evSpec event of GHC.GCWork{} -> gcWork t0 events GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events@@ -137,12 +137,12 @@ RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events) _other -> gcStart t0 events where- t1 = time event+ t1 = evTime event gcIdle :: Timestamp -> [GHC.Event] -> [EventDuration] gcIdle _ [] = [] gcIdle t0 (event : events) =- case spec event of+ case evSpec event of GHC.GCIdle{} -> gcIdle t0 events GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events@@ -150,12 +150,12 @@ RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events) _other -> gcStart t0 events where- t1 = time event+ t1 = evTime event gcDone :: Timestamp -> [GHC.Event] -> [EventDuration] gcDone _ [] = [] gcDone t0 (event : events) =- case spec event of+ case evSpec event of GHC.GCDone{} -> gcDone t0 events GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events@@ -163,15 +163,15 @@ RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events) _other -> gcStart t0 events where- t1 = time event+ t1 = evTime event ------------------------------------------------------------------------------- findRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus) findRunThreadTime [] = Nothing findRunThreadTime (e : es)- = case spec e of- StopThread{status=s} -> Just (time e, s)+ = case evSpec e of+ StopThread{status=s} -> Just (evTime e, s) _ -> findRunThreadTime es -------------------------------------------------------------------------------
Events/EventTree.hs view
@@ -14,11 +14,11 @@ import Events.EventDuration -import qualified GHC.RTS.Events as GHC import GHC.RTS.Events hiding (Event)+import qualified GHC.RTS.Events as GHC -import Text.Printf import Control.Exception (assert)+import Text.Printf ------------------------------------------------------------------------------- @@ -195,7 +195,7 @@ tree where tree = splitEvents es endTime- (s,e) = if null es then (0,0) else (time (head es), endTime)+ (s,e) = if null es then (0,0) else (evTime (head es), endTime) splitEvents :: [GHC.Event] -- events -> Timestamp -- end time of last event in the list@@ -223,14 +223,14 @@ | otherwise = -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $ assert (length lhs + length rhs == length es) $- EventSplit (time (head rhs))+ EventSplit (evTime (head rhs)) ltree rtree where -- | Integer division, rounding up. divUp :: Timestamp -> Timestamp -> Timestamp divUp n k = (n + k - 1) `div` k- startTime = time (head es)+ startTime = evTime (head es) splitTime = startTime + (endTime - startTime) `divUp` 2 duration = endTime - startTime @@ -257,7 +257,7 @@ | otherwise = (reverse acc, tmax, e:es) where- t = time e+ t = evTime e -------------------------------------------------------------------------------
Events/HECs.hs view
@@ -2,7 +2,6 @@ module Events.HECs ( HECs(..), Event,- CapEvent, Timestamp, eventIndexToTimestamp,@@ -17,16 +16,21 @@ import GHC.RTS.Events import Data.Array-import qualified Data.IntMap as IM import qualified Data.List as L +#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as IM+#else+import qualified Data.IntMap as IM+#endif+ ----------------------------------------------------------------------------- -- all the data from a .eventlog file data HECs = HECs { hecCount :: Int, hecTrees :: [(DurationTree, EventTree, SparkTree)],- hecEventArray :: Array Int CapEvent,+ hecEventArray :: Array Int Event, hecLastEventTime :: Timestamp, maxSparkPool :: Double, minXHistogram :: Int,@@ -40,7 +44,7 @@ eventIndexToTimestamp :: HECs -> Int -> Timestamp eventIndexToTimestamp HECs{hecEventArray=arr} n =- time (ce_event (arr ! n))+ evTime (arr ! n) timestampToEventIndex :: HECs -> Timestamp -> Int timestampToEventIndex HECs{hecEventArray=arr} ts =@@ -49,17 +53,17 @@ (l,r) = bounds arr search !l !r- | (r - l) <= 1 = if ts > time (ce_event (arr!l)) then r else l+ | (r - l) <= 1 = if ts > evTime (arr!l) then r else l | ts < tmid = search l mid | otherwise = search mid r where mid = l + (r - l) `quot` 2- tmid = time (ce_event (arr!mid))+ tmid = evTime (arr!mid) extractUserMarkers :: HECs -> [(Timestamp, String)] extractUserMarkers hecs = [ (ts, mark)- | CapEvent _ (Event ts (UserMarker mark)) <- elems (hecEventArray hecs) ]+ | (Event ts (UserMarker mark) _) <- elems (hecEventArray hecs) ] -- | Sum durations in the same buckets to form a histogram. histogram :: [(Int, Timestamp)] -> [(Int, Timestamp)]@@ -79,7 +83,9 @@ fromListWith' f xs = L.foldl' ins IM.empty xs where-#if MIN_VERSION_containers(0,4,1)+#if MIN_VERSION_containers(0,5,0)+ ins t (k,x) = IM.insertWith f k x t+#elif MIN_VERSION_containers(0,4,1) ins t (k,x) = IM.insertWith' f k x t #else ins t (k,x) =
Events/ReadEvents.hs view
@@ -2,34 +2,34 @@ registerEventsFromFile, registerEventsFromTrace ) where +import Events.EventDuration import Events.EventTree+import Events.HECs (HECs (..), histogram) import Events.SparkTree-import Events.HECs (HECs(..), histogram) import Events.TestEvents-import Events.EventDuration-import qualified GUI.ProgressView as ProgressView import GUI.ProgressView (ProgressView)+import qualified GUI.ProgressView as ProgressView -import GHC.RTS.Events -- hiding (Event)+import GHC.RTS.Events import GHC.RTS.Events.Analysis-import GHC.RTS.Events.Analysis.SparkThread import GHC.RTS.Events.Analysis.Capability+import GHC.RTS.Events.Analysis.SparkThread +import qualified Control.DeepSeq as DeepSeq+import Control.Exception+import Control.Monad import Data.Array+import Data.Either+import Data.Function+import qualified Data.IntMap as IM import qualified Data.List as L import Data.Map (Map) import qualified Data.Map as M-import qualified Data.IntMap as IM-import Data.Set (Set) import Data.Maybe (catMaybes, fromMaybe)-import Text.Printf+import Data.Set (Set) import System.FilePath-import Control.Monad-import Control.Exception-import qualified Control.DeepSeq as DeepSeq-import Data.Function-import Data.Either+import Text.Printf ------------------------------------------------------------------------------- -- import qualified GHC.RTS.Events as GHCEvents@@ -51,14 +51,14 @@ ------------------------------------------------------------------------------- -rawEventsToHECs :: [CapEvent] -> Timestamp+rawEventsToHECs :: [Event] -> Timestamp -> [(Double, (DurationTree, EventTree, SparkTree))] rawEventsToHECs evs endTime- = map (\ cap -> toTree $ L.find ((Just cap ==) . ce_cap . head) heclists)- [0 .. maximum (0 : map (fromMaybe 0 . ce_cap) evs)]+ = map (\cap -> toTree $ L.find ((Just cap ==) . evCap . head) heclists)+ [0 .. maximum (0 : map (fromMaybe 0 . evCap) evs)] where heclists =- L.groupBy ((==) `on` ce_cap) $ L.sortBy (compare `on` ce_cap) evs+ L.groupBy ((==) `on` evCap) $ L.sortBy (compare `on` evCap) evs toTree Nothing = (0, (DurationTreeEmpty, EventTree 0 0 (EventTreeLeaf []),@@ -68,8 +68,7 @@ (mkDurationTree (eventsToDurations nondiscrete) endTime, mkEventTree discrete endTime, mkSparkTree sparkD endTime))- where es = map ce_event evs- (discrete, nondiscrete) = L.partition isDiscreteEvent es+ where (discrete, nondiscrete) = L.partition isDiscreteEvent evs (maxSparkPool, sparkD) = eventsToSparkDurations nondiscrete -------------------------------------------------------------------------------@@ -118,15 +117,10 @@ divUp n k = (n + k - 1) `div` k build name evs = do let- specBy1000 e@EventBlock{} =- e{end_time = end_time e `divUp` 1000,- block_events = map eBy1000 (block_events e)}- specBy1000 e = e- eBy1000 ev = ev{time = time ev `divUp` 1000,- spec = specBy1000 (spec ev)}+ eBy1000 ev = ev{evTime = evTime ev `divUp` 1000} eventsBy = map eBy1000 (events (dat evs))- eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t- eventBlockEnd e = time e+ eventBlockEnd e | EventBlock{ end_time=t } <- evSpec e = t+ eventBlockEnd e = evTime e -- 1, to avoid graph scale 0 and division by 0 later on lastTx = maximum (1 : map eventBlockEnd eventsBy)@@ -139,18 +133,18 @@ -- one more step in the 'perf to TS' workflow and is a bit slower -- (yet another event sorting and loading eventlog chunks -- into the CPU cache).- steps :: [CapEvent] -> [(Map KernelThreadId Int, CapEvent)]+ steps :: [Event] -> [(Map KernelThreadId Int, Event)] steps evs = zip (map fst $ rights $ validates capabilityTaskOSMachine evs) evs- addC :: (Map KernelThreadId Int, CapEvent) -> CapEvent- addC (state, ev@CapEvent{ce_event=Event{spec=PerfTracepoint{tid}}}) =+ addC :: (Map KernelThreadId Int, Event) -> Event+ addC (state, ev@Event{evSpec=PerfTracepoint{tid}}) = case M.lookup tid state of Nothing -> ev -- unknown task's OS thread- ce_cap -> ev {ce_cap}- addC (state, ev@CapEvent{ce_event=Event{spec=PerfCounter{tid}}}) =+ evCap -> ev {evCap}+ addC (state, ev@Event{evSpec=PerfCounter{tid}}) = case M.lookup tid state of Nothing -> ev -- unknown task's OS thread- ce_cap -> ev {ce_cap}+ evCap -> ev {evCap} addC (_, ev) = ev addCaps evs = map addC (steps evs) @@ -183,13 +177,13 @@ sparkProfile :: Process ((Map ThreadId (Profile SparkThreadState), (Map Int ThreadId, Set ThreadId)),- CapEvent)+ Event) (ThreadId, (SparkThreadState, Timestamp, Timestamp)) sparkProfile = profileRouted- (refineM (spec . ce_event) sparkThreadMachine)+ (refineM evSpec sparkThreadMachine) capabilitySparkThreadMachine capabilitySparkThreadIndexer- (time . ce_event)+ evTime sorted sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp)@@ -225,9 +219,7 @@ maxYHistogram = 10000 * ceiling (fromIntegral maxY / 10000) getPerfNames nmap ev =- case spec ev of- EventBlock{block_events} ->- L.foldl' getPerfNames nmap block_events+ case evSpec ev of PerfName{perfNum, name} -> IM.insert (fromIntegral perfNum) name nmap _ -> nmap
Events/SparkTree.hs view
@@ -9,8 +9,8 @@ import qualified Events.SparkStats as SparkStats -import qualified GHC.RTS.Events as GHCEvents import GHC.RTS.Events (Timestamp)+import qualified GHC.RTS.Events as GHCEvents import Control.Exception (assert) import Text.Printf@@ -32,9 +32,9 @@ eventsToSparkDurations es = let aux _startTime _startCounters [] = (0, []) aux startTime startCounters (event : events) =- case GHCEvents.spec event of+ case GHCEvents.evSpec event of GHCEvents.SparkCounters crt dud ovf cnv fiz gcd rem ->- let endTime = GHCEvents.time event+ let endTime = GHCEvents.evTime event endCounters = (crt, dud, ovf, cnv, fiz, gcd, rem) delta = SparkStats.create startCounters endCounters newMaxSparkPool = SparkStats.maxPool delta
Events/TestEvents.hs view
@@ -1,8 +1,8 @@ module Events.TestEvents (testTrace) where -import GHC.RTS.Events import Data.Word+import GHC.RTS.Events ------------------------------------------------------------------------------- @@ -14,12 +14,7 @@ eventLog :: [Event] -> EventLog eventLog events =- let specBy1000 e@EventBlock{} =- e{end_time = end_time e * 1000,- block_events = map eBy1000 (block_events e)}- specBy1000 e = e- eBy1000 ev = ev{time = time ev * 1000,- spec = specBy1000 (spec ev)}+ let eBy1000 ev = ev{evTime = evTime ev * 1000} eventsBy = map eBy1000 events in EventLog (Header testEventTypes) (Data eventsBy) @@ -137,7 +132,7 @@ test "empty0" = [- Event 0 (Startup 1)+ Event 0 (Startup 1) (Just 0) ] -------------------------------------------------------------------------------@@ -145,107 +140,88 @@ test "empty1" = [- Event 0 (Startup 1),- Event 0 $ EventBlock 4000000 0 []+ Event 0 (Startup 1) (Just 0) ] ------------------------------------------------------------------------------- test "test0" = [- Event 0 (Startup 1),- Event 0 $ EventBlock 4000000 0 [- Event 4000000 Shutdown- ]+ Event 0 (Startup 1) (Just 0),+ Event 4000000 Shutdown (Just 0) ] ------------------------------------------------------------------------------- test "small" = [- Event 0 (Startup 1),- Event 0 $ EventBlock 4000000 0 [- Event 1000000 (CreateThread 1),- Event 2000000 (RunThread 1),- Event 3000000 (StopThread 1 ThreadFinished),- Event 4000000 (Shutdown)- ]+ Event 0 (Startup 1) (Just 0),+ Event 1000000 (CreateThread 1) (Just 0),+ Event 2000000 (RunThread 1) (Just 0),+ Event 3000000 (StopThread 1 ThreadFinished) (Just 0),+ Event 4000000 (Shutdown) (Just 0) ] ------------------------------------------------------------------------------- test "tick" = [-- A thread from 2s to 3s- Event 0 (Startup 3),- Event 0 $ EventBlock 4000000000 0 [- Event 1000000000 (CreateThread 1),- Event 2000000000 (RunThread 1),- Event 3000000000 (StopThread 1 ThreadFinished),- Event 4000000000 (Shutdown)- ],+ Event 0 (Startup 3) (Just 0),+ Event 1000000000 (CreateThread 1) (Just 0),+ Event 2000000000 (RunThread 1) (Just 0),+ Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),+ Event 4000000000 (Shutdown) (Just 0), -- A thread from 0.2ms to 0.3ms- Event 0 $ EventBlock 4000000000 1 [- Event 1000000 (CreateThread 2),- Event 2000000 (RunThread 2),- Event 3000000 (StopThread 2 ThreadFinished),- Event 4000000 (Shutdown)- ],+ Event 1000000 (CreateThread 2) (Just 1),+ Event 2000000 (RunThread 2) (Just 1),+ Event 3000000 (StopThread 2 ThreadFinished) (Just 1),+ Event 4000000 (Shutdown) (Just 1), -- A thread from 0.2us to 0.3us- Event 0 $ EventBlock 4000000000 2 [- Event 1000 (CreateThread 3),- Event 2000 (RunThread 3),- Event 3000 (StopThread 3 ThreadFinished),- Event 4000 (Shutdown)- ]+ Event 1000 (CreateThread 3) (Just 2),+ Event 2000 (RunThread 3) (Just 2),+ Event 3000 (StopThread 3 ThreadFinished) (Just 2),+ Event 4000 (Shutdown) (Just 2) ] ------------------------------------------------------------------------------- test "tick2" = [-- A thread create but no run- Event 0 (Startup 1),- Event 0 $ EventBlock 4000000000 0 [- Event 1000000000 (CreateThread 1),- Event 4000000000 (Shutdown)- ]+ Event 0 (Startup 1) (Just 0),+ Event 1000000000 (CreateThread 1) (Just 0),+ Event 4000000000 (Shutdown) (Just 0) ] ------------------------------------------------------------------------------- test "tick3" = [-- A thread from 2s to 3s- Event 0 (Startup 1),- Event 0 $ EventBlock 4000000000 0 [- Event 1000000000 (CreateThread 1),- Event 2000000000 (RunThread 1),- Event 3000000000 (StopThread 1 ThreadFinished),- Event 4000000000 (Shutdown)- ]+ Event 0 (Startup 1) (Just 0),+ Event 1000000000 (CreateThread 1) (Just 0),+ Event 2000000000 (RunThread 1) (Just 0),+ Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),+ Event 4000000000 (Shutdown) (Just 0) ] ------------------------------------------------------------------------------- test "tick4" = [-- A test for scale values close to 1.0- Event 0 (Startup 1),- Event 0 $ EventBlock 4000000000 0 [- Event 100 (CreateThread 1),- Event 200 (RunThread 1),- Event 300 (StopThread 1 ThreadFinished),- Event 400 (Shutdown)- ]+ Event 0 (Startup 1) (Just 0),+ Event 100 (CreateThread 1) (Just 0),+ Event 200 (RunThread 1) (Just 0),+ Event 300 (StopThread 1 ThreadFinished) (Just 0),+ Event 400 (Shutdown) (Just 0) ] ------------------------------------------------------------------------------- test "tick5" = [-- A thread from 2s to 3s- Event 0 (Startup 1),- Event 0 $ EventBlock 4000000000 0 [- Event 1000000000 (CreateThread 1),- Event 2000000000 (RunThread 1),- Event 3000000000 (StopThread 1 ThreadFinished),- Event 4000000000 (Shutdown)- ]+ Event 0 (Startup 1) (Just 0),+ Event 1000000000 (CreateThread 1) (Just 0),+ Event 2000000000 (RunThread 1) (Just 0),+ Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),+ Event 4000000000 (Shutdown) (Just 0) ] -------------------------------------------------------------------------------@@ -256,30 +232,28 @@ ------------------------------------------------------------------------------- test "overlap"- = [-- A thread from 2s to 3s- Event 0 (Startup 1),- Event 0 $ EventBlock 3000 0 [- Event 1000 (CreateThread 1),- Event 1100 (RunThread 1),- Event 1200 (CreateThread 2),- Event 1300 (StopThread 1 ThreadFinished),+ = [-- A thread from 2s to 3s+ Event 0 (Startup 1) (Just 0),+ Event 1000 (CreateThread 1) (Just 0),+ Event 1100 (RunThread 1) (Just 0),+ Event 1200 (CreateThread 2) (Just 0),+ Event 1300 (StopThread 1 ThreadFinished) (Just 0), - Event 1400 (RunThread 2),- Event 1500 (CreateThread 3),- Event 1500 (CreateThread 4),- Event 1500 (StopThread 2 ThreadFinished),+ Event 1400 (RunThread 2) (Just 0),+ Event 1500 (CreateThread 3) (Just 0),+ Event 1500 (CreateThread 4) (Just 0),+ Event 1500 (StopThread 2 ThreadFinished) (Just 0), - Event 1600 (RunThread 3),- Event 1600 (CreateThread 5),- Event 1600 (StopThread 3 ThreadFinished),+ Event 1600 (RunThread 3) (Just 0),+ Event 1600 (CreateThread 5) (Just 0),+ Event 1600 (StopThread 3 ThreadFinished) (Just 0), - Event 1700 (RunThread 4),- Event 1700 (CreateThread 6),- Event 1800 (StopThread 4 ThreadFinished),+ Event 1700 (RunThread 4) (Just 0),+ Event 1700 (CreateThread 6) (Just 0),+ Event 1800 (StopThread 4 ThreadFinished) (Just 0), - Event 3000 (Shutdown)- ]- ]+ Event 3000 (Shutdown) (Just 0)+ ] ------------------------------------------------------------------------------- -- These tests are for chequered patterns to help check for rendering@@ -305,7 +279,7 @@ chequered :: ThreadId -> Timestamp -> Timestamp -> [Event] chequered numThreads basicDuration runLength- = Event 0 (Startup (fromIntegral numThreads)) :+ = Event 0 (Startup (fromIntegral numThreads)) (Just 0) : makeChequered 1 numThreads basicDuration runLength -------------------------------------------------------------------------------@@ -314,25 +288,24 @@ makeChequered currentThread numThreads _basicDuration _runLength | currentThread > numThreads = [] -- All threads rendered makeChequered currentThread numThreads basicDuration runLength- = Event 0 eventBlock :+ = eventBlock ++ makeChequered (currentThread+1) numThreads (2*basicDuration) runLength where- eventBlock :: EventInfo- eventBlock = EventBlock runLength (fromIntegral (currentThread-1))- (Event 0 (CreateThread currentThread)- : chequeredPattern currentThread 0 basicDuration runLength)+ eventBlock = Event 0 (CreateThread currentThread) (Just $ fromIntegral $ currentThread - 1)+ : chequeredPattern currentThread 0 basicDuration runLength ------------------------------------------------------------------------------- chequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event] chequeredPattern currentThread currentPos basicDuration runLength = if currentPos + 2*basicDuration > runLength then- [Event runLength (Shutdown)]+ [Event runLength Shutdown mcap] else- [Event currentPos (RunThread currentThread),- Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding),- Event (currentPos+basicDuration) StartGC,- Event (currentPos+2*basicDuration) EndGC+ [Event currentPos (RunThread currentThread) mcap,+ Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding) mcap,+ Event (currentPos+basicDuration) StartGC mcap,+ Event (currentPos+2*basicDuration) EndGC mcap ] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength+ where mcap = Just $ fromIntegral $ currentThread - 1 -------------------------------------------------------------------------------
+ GUI/App.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}++-------------------------------------------------------------------------------+-- | Module : GUI.App+--+-- Platform-specific application functionality+-------------------------------------------------------------------------------++module GUI.App (initApp) where++-- Mac OS X-specific GTK imports+#if defined(darwin_HOST_OS)+import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.OSX as OSX+#endif++-------------------------------------------------------------------------------++#if defined(darwin_HOST_OS)++-- | Initialize application+-- Perform Mac OS X-specific application initialization+initApp :: IO ()+initApp = do+ app <- OSX.applicationNew+ menuBar <- Gtk.menuBarNew+ OSX.applicationSetMenuBar app menuBar+ OSX.applicationReady app++#else++-- | Initialize application+-- Perform application initialization for non-Mac OS X platforms+initApp :: IO ()+initApp = return ()++#endif
GUI/EventsView.hs view
@@ -44,7 +44,7 @@ | EventsLoaded { cursorPos :: !Int, mrange :: !(Maybe (Int, Int)),- eventsArr :: Array Int CapEvent+ eventsArr :: Array Int Event } -------------------------------------------------------------------------------@@ -181,7 +181,7 @@ ------------------------------------------------------------------------------- -eventsViewSetEvents :: EventsView -> Maybe (Array Int CapEvent) -> IO ()+eventsViewSetEvents :: EventsView -> Maybe (Array Int Event) -> IO () eventsViewSetEvents eventWin@EventsView{drawArea, stateRef} mevents = do viewState <- readIORef stateRef let eventsState' = case mevents of@@ -337,9 +337,10 @@ ] where- showEventTime (CapEvent _cap (Event time _spec)) =+ showEventTime (Event time _spec _) = showFFloat (Just 6) (fromIntegral time / 1000000) "s"- showEventDescr (CapEvent cap (Event _time spec)) =+ showEventDescr :: Event -> String+ showEventDescr (Event _time spec cap) = (case cap of Nothing -> "" Just c -> "HEC " ++ show c ++ ": ")
GUI/GtkExtras.hs view
@@ -6,7 +6,6 @@ import Graphics.UI.GtkInternals import Graphics.UI.Gtk (Rectangle)-import System.Glib.GError import System.Glib.MainLoop import Graphics.Rendering.Pango.Types import Graphics.Rendering.Pango.BasicTypes@@ -14,9 +13,13 @@ import Foreign import Foreign.C-import Control.Monad import Control.Concurrent.MVar +#if !(mingw32_HOST_OS || mingw32_TARGET_OS)+import System.Glib.GError+import Control.Monad+#endif+ waitGUI :: IO () waitGUI = do resultVar <- newEmptyMVar@@ -91,7 +94,7 @@ 1 -- SW_SHOWNORMAL return True -foreign import stdcall unsafe "shlobj.h ShellExecuteA"+foreign import ccall unsafe "shlobj.h ShellExecuteA" c_ShellExecuteA :: Ptr () -- HWND hwnd -> CString -- LPCTSTR lpOperation -> CString -- LPCTSTR lpFile
GUI/Main.hs view
@@ -7,20 +7,19 @@ -- Imports from Haskell library import Text.Printf-import Control.Monad #ifndef mingw32_HOST_OS import System.Posix #endif import Control.Concurrent import qualified Control.Concurrent.Chan as Chan import Control.Exception-import Prelude hiding (catch) import Data.Array import Data.Maybe import Paths_threadscope -- Imports for ThreadScope+import qualified GUI.App as App import qualified GUI.MainWindow as MainWindow import GUI.Types import Events.HECs hiding (Event)@@ -444,6 +443,8 @@ runGUI :: Maybe (Either FilePath String) -> IO () runGUI initialTrace = do Gtk.initGUI++ App.initApp uiEnv <- constructUI
GUI/ProgressView.hs view
@@ -17,9 +17,6 @@ import Control.Exception import Data.Typeable -import Prelude hiding (catch)-- data ProgressView = ProgressView { progressWindow :: Gtk.Window, progressLabel :: Gtk.Label,
GUI/StartupInfoView.hs view
@@ -86,31 +86,31 @@ ------------------------------------------------------------------------------- -startupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int CapEvent) -> IO ()+startupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int Event) -> IO () startupInfoViewSetEvents view mevents = updateStartupInfo view (maybe StartupInfoEmpty processEvents mevents) --TODO: none of this handles the possibility of an eventlog containing multiple -- OS processes. Note that the capset arg is ignored in the events below. -processEvents :: Array Int CapEvent -> StartupInfoState+processEvents :: Array Int Event -> StartupInfoState processEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing) . take 1000 . elems where- accum info (CapEvent _ (Event _ (ProgramArgs _ (name:args)))) =+ accum info (Event _ (ProgramArgs _ (name:args)) _) = info { progName = Just name, progArgs = Just args } - accum info (CapEvent _ (Event _ (ProgramEnv _ env))) =+ accum info (Event _ (ProgramEnv _ env) _) = info { progEnv = Just (sort (parseEnv env)) } - accum info (CapEvent _ (Event _ (RtsIdentifier _ rtsid))) =+ accum info (Event _ (RtsIdentifier _ rtsid) _) = info { progRtsId = Just rtsid } - accum info (CapEvent _ (Event timestamp (WallClockTime _ sec nsec))) =+ accum info (Event timestamp (WallClockTime _ sec nsec) _) = -- WallClockTime records the wall clock time of *this* event -- which occurs some time after startup, so we can just subtract -- the timestamp since that is the relative time since startup.
GUI/SummaryView.hs view
@@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ -type Events = Array Int CapEvent+type Events = Array Int Event data SummaryView = SummaryView { @@ -142,7 +142,7 @@ ------------------------------------------------------------------------------ -summaryViewSetEvents :: SummaryView -> Maybe (Array Int CapEvent) -> IO ()+summaryViewSetEvents :: SummaryView -> Maybe (Array Int Event) -> IO () summaryViewSetEvents view@SummaryView{cacheEventsStats} Nothing = do writeIORef cacheEventsStats Nothing setSummaryStatsEmpty view@@ -367,7 +367,7 @@ -- * then look at that 'StatsAccum' record and construct the various final -- stats that we want to present. ---summaryStats :: Array Int CapEvent -> Maybe Interval -> SummaryStats+summaryStats :: Array Int Event -> Maybe Interval -> SummaryStats summaryStats events minterval = SummaryStats { summHeapStats = hs,@@ -386,7 +386,7 @@ -- | Linearly accumulate the stats from the events array, -- either the full thing or some sub-range.-accumStats :: Array Int CapEvent -> Maybe Interval -> StatsAccum+accumStats :: Array Int Event -> Maybe Interval -> StatsAccum accumStats events minterval = foldl' accumEvent start [ events ! i | i <- range eventsRange ] where@@ -401,13 +401,13 @@ -- indicies containing that interval. The Nothing interval means to select -- the whole array range. ---selectEventRange :: Array Int CapEvent -> Maybe Interval -> (Int, Int)+selectEventRange :: Array Int Event -> Maybe Interval -> (Int, Int) selectEventRange arr Nothing = bounds arr selectEventRange arr (Just (start, end)) = (lbound, ubound) where !lbound = either snd id $ findArrayRange cmp arr start !ubound = either fst id $ findArrayRange cmp arr end- cmp ts (CapEvent _ (Event ts' _)) = compare ts ts'+ cmp ts (Event ts' _ _) = compare ts ts' findArrayRange :: (key -> val -> Ordering) -> Array Int val -> key -> Either (Int,Int) Int@@ -427,7 +427,7 @@ ------------------------------------------------------------------------------ -- Final step where we convert from StatsAccum to various presentation forms -timeStats :: Array Int CapEvent -> Maybe Interval -> GcStats -> TimeStats+timeStats :: Array Int Event -> Maybe Interval -> GcStats -> TimeStats timeStats events minterval GcStats { gcTotalStats = GcStatsEntry _ _ _ timeGC _ _ } = TimeStats {..}@@ -440,10 +440,9 @@ (intervalStart, intervalEnd) = case minterval of Just (s,e) -> (s, e)- Nothing -> (0, timeOf (events ! ub))+ Nothing -> (0, evTime (events ! ub)) where (_lb, ub) = bounds events- timeOf (CapEvent _ (Event t _)) = t heapStats :: StatsAccum -> TimeStats -> HeapStats@@ -691,8 +690,8 @@ errorAs :: String -> a -> a errorAs msg a = assert (error msg) a -accumEvent :: StatsAccum -> CapEvent -> StatsAccum-accumEvent !statsAccum (CapEvent mcap ev) =+accumEvent :: StatsAccum -> Event -> StatsAccum+accumEvent !statsAccum ev = let -- For events that contain a counter with a running sum. -- Eventually we'll subtract the last found -- event from the first. Intervals beginning at time 0@@ -713,12 +712,10 @@ alterMax n (Just k) | n > k = Just n alterMax _ jk = jk -- Scan events, updating summary data.- scan cap !sd@StatsAccum{..} Event{time, spec} =- let capGC = IM.findWithDefault (defaultGC time) cap dGCTable- in case spec of- -- TODO: check EventBlock elsewhere; define {map,fold}EventBlock- EventBlock{cap = bcap, block_events} ->- L.foldl' (scan bcap) sd block_events+ scan !sd@StatsAccum{..} Event{evTime, evSpec, evCap} =+ let cap = fromMaybe (error "Error: missing cap; use 'ghc-events validate' to verify the eventlog") evCap+ capGC = IM.findWithDefault (defaultGC evTime) cap dGCTable+ in case evSpec of HeapAllocated{allocBytes} -> sd { dallocTable = IM.alter (alterCounter allocBytes) cap dallocTable }@@ -729,7 +726,7 @@ StartGC -> assert (gcMode capGC `elem` [ModeInit, ModeEnd, ModeIdle]) $ let newGC = capGC { gcMode = ModeStart- , gcStartTime = time+ , gcStartTime = evTime } -- TODO: Index with generations, not caps? in sd { dGCTable = IM.insert cap newGC dGCTable }@@ -879,7 +876,7 @@ EndGC -> assert (gcMode capGC `notElem` [ModeEnd, ModeIdle]) $ let endedGC = capGC { gcMode = ModeEnd }- duration = time - gcStartTime capGC+ duration = evTime - gcStartTime capGC timeGC gen gstat = let genGC = IM.findWithDefault emptyGenStat gen (gcGenStat gstat)@@ -907,7 +904,7 @@ ModeStart -> sd { dGCTable = IM.insert cap endedGC dGCTable } -- There is no GCStatsGHC for this GC. Gather partial data. ModeSync mainCap ->- let dgm = fromMaybe (defaultGC time) dGCMain+ let dgm = fromMaybe (defaultGC evTime) dGCMain mainGenTot = updateMainCap mainCap gcGenTot dgm in sd { dGCTable = IM.insert cap timeGenTot dGCTable , dGCMain = Just mainGenTot@@ -915,7 +912,7 @@ -- All is known, so we update the times. ModeGHC mainCap gen -> let newTime = timeGC gen timeGenTot- dgm = fromMaybe (defaultGC time) dGCMain+ dgm = fromMaybe (defaultGC evTime) dGCMain mainGenTot = updateMainCap mainCap gcGenTot dgm newMain = updateMainCap mainCap gen mainGenTot in sd { dGCTable = IM.insert cap newTime dGCTable@@ -931,4 +928,4 @@ in sd { dsparkTable = IM.alter (alterCounter current) cap dsparkTable } _ -> sd- in scan (fromMaybe (error "Error: missing cap; use 'ghc-events validate' to verify the eventlog") mcap) statsAccum ev+ in scan statsAccum ev
GUI/Timeline/HEC.hs view
@@ -5,20 +5,20 @@ import GUI.Timeline.Render.Constants -import Events.EventTree import Events.EventDuration-import GUI.Types+import Events.EventTree import GUI.Timeline.CairoDrawing+import GUI.Types import GUI.ViewerColours import Graphics.Rendering.Cairo +import GHC.RTS.Events hiding (Event, GCIdle, GCWork) import qualified GHC.RTS.Events as GHC-import GHC.RTS.Events hiding (Event, GCWork, GCIdle) +import Control.Monad import qualified Data.IntMap as IM import Data.Maybe-import Control.Monad renderHEC :: ViewParameters -> Timestamp -> Timestamp -> IM.IntMap String -> (DurationTree,EventTree)@@ -83,7 +83,7 @@ renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth perfNames (EventTreeLeaf es)- = let within = [ e | e <- es, let t = time e, t >= startPos && t < endPos ]+ = let within = [ e | e <- es, let t = evTime e, t >= startPos && t < endPos ] untilTrue _ [] = return False untilTrue f (x : xs) = do b <- f x@@ -94,7 +94,7 @@ perfNames (EventTreeOne ev) | t >= startPos && t < endPos = drawEvent params ewidth perfNames ev | otherwise = return False- where t = time ev+ where t = evTime ev renderEvents params@ViewParameters{..} !s !e !startPos !endPos ewidth perfNames (EventSplit splitTime lhs rhs)@@ -242,7 +242,7 @@ -> Render Bool drawEvent params@ViewParameters{..} ewidth perfNames event = let renderI = renderInstantEvent params perfNames event ewidth- in case spec event of+ in case evSpec event of CreateThread{} -> renderI createThreadColour RequestSeqGC{} -> renderI seqGCReqColour RequestParGC{} -> renderI parGCReqColour@@ -276,7 +276,7 @@ renderInstantEvent ViewParameters{..} perfNames event ewidth color = do setSourceRGBAhex color 1.0 setLineWidth (ewidth * scaleValue)- let t = time event+ let t = evTime event draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4) let numToLabel PerfCounter{perfNum, period} | period == 0 = IM.lookup (fromIntegral perfNum) perfNames@@ -287,7 +287,7 @@ fmap ("tracepoint: " ++) $ IM.lookup (fromIntegral perfNum) perfNames numToLabel _ = Nothing showLabel espec = fromMaybe (showEventInfo espec) (numToLabel espec)- labelAt labelsMode t $ showLabel (spec event)+ labelAt labelsMode t $ showLabel (evSpec event) return True -------------------------------------------------------------------------------
threadscope.cabal view
@@ -1,5 +1,5 @@ Name: threadscope-Version: 0.2.7+Version: 0.2.8 Category: Development, Profiling, Trace Synopsis: A graphical tool for profiling parallel Haskell programs. Description: ThreadScope is a graphical viewer for thread profile@@ -33,6 +33,11 @@ Build-Type: Simple Cabal-version: >= 1.6 Data-files: threadscope.ui, threadscope.png+Tested-with: GHC == 7.6.3,+ GHC == 7.8.3,+ GHC == 7.10.2,+ GHC == 8.0.2,+ GHC == 8.2.1 source-repository head type: git@@ -40,14 +45,23 @@ Executable threadscope Main-is: Main.hs- Build-Depends: base >= 4.0 && < 5,- gtk >= 0.12, cairo, glib, pango,- binary, array, mtl, filepath,- ghc-events >= 0.4.2,+ Build-Depends: base >= 4.6 && < 5,+ gtk >= 0.12 && < 0.15,+ cairo < 0.14,+ glib < 0.14,+ pango < 0.14,+ binary < 0.10,+ array < 0.6,+ mtl < 2.3,+ filepath < 1.5,+ ghc-events >= 0.5 && < 0.7, containers >= 0.2 && < 0.6, deepseq >= 1.1,- text,- time >= 1.1+ text < 1.3,+ time >= 1.1 && < 1.9+ if os(osx)+ build-depends: gtk-mac-integration+ Extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards Other-Modules: Events.HECs, Events.EventDuration,@@ -56,6 +70,7 @@ Events.SparkStats, Events.SparkTree, Events.TestEvents,+ GUI.App, GUI.Main, GUI.MainWindow, GUI.EventsView,@@ -82,6 +97,7 @@ GUI.Timeline.Types, GUI.Timeline.Render.Constants, GUI.GtkExtras+ Paths_threadscope ghc-options: -Wall -fwarn-tabs -rtsopts -fno-warn-type-defaults -fno-warn-name-shadowing