diff --git a/Events/EventDuration.hs b/Events/EventDuration.hs --- a/Events/EventDuration.hs +++ b/Events/EventDuration.hs @@ -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 ------------------------------------------------------------------------------- diff --git a/Events/EventTree.hs b/Events/EventTree.hs --- a/Events/EventTree.hs +++ b/Events/EventTree.hs @@ -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 ------------------------------------------------------------------------------- diff --git a/Events/HECs.hs b/Events/HECs.hs --- a/Events/HECs.hs +++ b/Events/HECs.hs @@ -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) = diff --git a/Events/ReadEvents.hs b/Events/ReadEvents.hs --- a/Events/ReadEvents.hs +++ b/Events/ReadEvents.hs @@ -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 diff --git a/Events/SparkTree.hs b/Events/SparkTree.hs --- a/Events/SparkTree.hs +++ b/Events/SparkTree.hs @@ -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 diff --git a/Events/TestEvents.hs b/Events/TestEvents.hs --- a/Events/TestEvents.hs +++ b/Events/TestEvents.hs @@ -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 ------------------------------------------------------------------------------- diff --git a/GUI/App.hs b/GUI/App.hs new file mode 100644 --- /dev/null +++ b/GUI/App.hs @@ -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 diff --git a/GUI/EventsView.hs b/GUI/EventsView.hs --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -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 ++ ": ") diff --git a/GUI/GtkExtras.hs b/GUI/GtkExtras.hs --- a/GUI/GtkExtras.hs +++ b/GUI/GtkExtras.hs @@ -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 diff --git a/GUI/Main.hs b/GUI/Main.hs --- a/GUI/Main.hs +++ b/GUI/Main.hs @@ -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 diff --git a/GUI/ProgressView.hs b/GUI/ProgressView.hs --- a/GUI/ProgressView.hs +++ b/GUI/ProgressView.hs @@ -17,9 +17,6 @@ import Control.Exception import Data.Typeable -import Prelude hiding (catch) - - data ProgressView = ProgressView { progressWindow :: Gtk.Window, progressLabel :: Gtk.Label, diff --git a/GUI/StartupInfoView.hs b/GUI/StartupInfoView.hs --- a/GUI/StartupInfoView.hs +++ b/GUI/StartupInfoView.hs @@ -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. diff --git a/GUI/SummaryView.hs b/GUI/SummaryView.hs --- a/GUI/SummaryView.hs +++ b/GUI/SummaryView.hs @@ -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 diff --git a/GUI/Timeline/HEC.hs b/GUI/Timeline/HEC.hs --- a/GUI/Timeline/HEC.hs +++ b/GUI/Timeline/HEC.hs @@ -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 ------------------------------------------------------------------------------- diff --git a/threadscope.cabal b/threadscope.cabal --- a/threadscope.cabal +++ b/threadscope.cabal @@ -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