threadscope 0.2.0 → 0.2.1
raw patch · 34 files changed
+2779/−1201 lines, 34 filesdep +deepseqdep +timedep ~ghc-events
Dependencies added: deepseq, time
Dependency ranges changed: ghc-events
Files
- Events/EventDuration.hs +1/−1
- Events/EventTree.hs +36/−20
- Events/HECs.hs +37/−2
- Events/ReadEvents.hs +136/−65
- Events/SparkStats.hs +9/−10
- Events/SparkTree.hs +43/−47
- Events/TestEvents.hs +9/−3
- GUI/BookmarkView.hs +1/−1
- GUI/Dialogs.hs +4/−7
- GUI/EventsView.hs +27/−18
- GUI/GtkExtras.hs +16/−0
- GUI/Histogram.hs +129/−0
- GUI/KeyView.hs +98/−30
- GUI/Main.hs +100/−44
- GUI/MainWindow.hs +48/−47
- GUI/ProgressView.hs +7/−6
- GUI/SaveAs.hs +50/−27
- GUI/StartupInfoView.hs +145/−0
- GUI/SummaryView.hs +80/−0
- GUI/Timeline.hs +293/−98
- GUI/Timeline/Activity.hs +12/−9
- GUI/Timeline/HEC.hs +81/−76
- GUI/Timeline/Motion.hs +66/−60
- GUI/Timeline/Render.hs +288/−187
- GUI/Timeline/Render/Constants.hs +25/−14
- GUI/Timeline/Sparks.hs +168/−187
- GUI/Timeline/Ticks.hs +244/−113
- GUI/Timeline/Types.hs +18/−6
- GUI/TraceView.hs +23/−10
- GUI/Types.hs +15/−5
- GUI/ViewerColours.hs +12/−9
- Main.hs +3/−4
- threadscope.cabal +17/−14
- threadscope.ui +538/−81
Events/EventDuration.hs view
@@ -84,7 +84,7 @@ ------------------------------------------------------------------------------- eventsToDurations :: [GHC.Event] -> [EventDuration]-eventsToDurations [] = []+eventsToDurations [] = [] eventsToDurations (event : events) = case spec event of RunThread{thread=t} -> runDuration t : rest
Events/EventTree.hs view
@@ -18,6 +18,7 @@ import GHC.RTS.Events hiding (Event) import Text.Printf+import Control.Exception (assert) ------------------------------------------------------------------------------- @@ -63,23 +64,28 @@ tree = splitDurations es endTime splitDurations :: [EventDuration] -- events- -> Timestamp -- end time of last event in the list- -> DurationTree-splitDurations [] _endTime =+ -> Timestamp -- end time of last event in the list+ -> DurationTree+splitDurations [] _endTime = -- if len /= 0 then error "splitDurations0" else- DurationTreeEmpty -- The case for an empty list of events+ DurationTreeEmpty -- The case for an empty list of events. splitDurations [e] _entTime = DurationTreeLeaf e -splitDurations es endTime- | null lhs || null rhs- = -- error (printf "failed to split: len = %d, startTime = %d, endTime = %d\n" (length es) startTime endTime ++ '\n': show es)- DurationTreeEmpty+splitDurations es endTime+ | null rhs+ = splitDurations es lhs_end + | null lhs+ = error $+ printf "splitDurations: null lhs: len = %d, startTime = %d, endTime = %d\n"+ (length es) startTime endTime+ ++ '\n': show es+ | otherwise = -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $- -- if len /= length es || length lhs + length rhs /= len then error (printf "splitDurations3; %d %d %d %d %d" len (length es) (length lhs) lhs_len (length rhs)) else+ assert (length lhs + length rhs == length es) $ DurationSplit startTime lhs_end endTime@@ -101,18 +107,18 @@ splitDurationList :: [EventDuration]- -> [EventDuration]- -> Timestamp- -> Timestamp- -> ([EventDuration], Timestamp, [EventDuration])+ -> [EventDuration]+ -> Timestamp+ -> Timestamp+ -> ([EventDuration], Timestamp, [EventDuration]) splitDurationList [] acc !_tsplit !tmax = (reverse acc, tmax, []) splitDurationList [e] acc !_tsplit !tmax- = (reverse acc, tmax, [e])- -- just one event left: put it on the right. This ensures that we+ -- Just one event left: put it on the right. This ensures that we -- have at least one event on each side of the split.+ = (reverse acc, tmax, [e]) splitDurationList (e:es) acc !tsplit !tmax- | tstart < tsplit -- pick all events that start before the split+ | tstart <= tsplit -- pick all events that start at or before the split = splitDurationList es (e:acc) tsplit (max tmax tend) | otherwise = (reverse acc, tmax, e:es)@@ -209,17 +215,23 @@ = splitEvents es lhs_end | null lhs- = error (printf "null lhs: len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" (length es) startTime endTime ++ '\n': show es)+ = error $+ printf "splitEvents: null lhs: len = %d, startTime = %d, endTime = %d\n"+ (length es) startTime endTime+ ++ '\n': show es | otherwise = -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $- -- if len /= length es || length lhs + length rhs /= len then error (printf "splitEvents3; %d %d %d %d %d" len (length es) (length lhs) lhs_len (length rhs)) else+ assert (length lhs + length rhs == length es) $ EventSplit (time (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)- splitTime = startTime + (endTime - startTime) `div` 2+ splitTime = startTime + (endTime - startTime) `divUp` 2 duration = endTime - startTime (lhs, lhs_end, rhs) = splitEventList es [] splitTime 0@@ -235,8 +247,12 @@ -> ([GHC.Event], Timestamp, [GHC.Event]) splitEventList [] acc !_tsplit !tmax = (reverse acc, tmax, [])+splitEventList [e] acc !_tsplit !tmax+ -- Just one event left: put it on the right. This ensures that we+ -- have at least one event on each side of the split.+ = (reverse acc, tmax, [e]) splitEventList (e:es) acc !tsplit !tmax- | t < tsplit -- pick all events that start before the split+ | t <= tsplit -- pick all events that start at or before the split = splitEventList es (e:acc) tsplit (max tmax t) | otherwise = (reverse acc, tmax, e:es)
Events/HECs.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Events.HECs ( HECs(..), Event,@@ -7,6 +8,8 @@ eventIndexToTimestamp, timestampToEventIndex, extractUserMessages,+ histogram,+ histogramCounts, ) where import Events.EventTree@@ -14,6 +17,8 @@ import GHC.RTS.Events import Data.Array+import qualified Data.IntMap as IM+import qualified Data.List as L ----------------------------------------------------------------------------- @@ -23,8 +28,11 @@ hecTrees :: [(DurationTree, EventTree, SparkTree)], hecEventArray :: Array Int CapEvent, hecLastEventTime :: Timestamp,- maxSparkValue :: Double,- maxSparkPool :: Double+ maxSparkPool :: Double,+ minXHistogram :: Int,+ maxXHistogram :: Int,+ maxYHistogram :: Timestamp,+ durHistogram :: [(Timestamp, Int, Timestamp)] } -----------------------------------------------------------------------------@@ -51,3 +59,30 @@ extractUserMessages hecs = [ (ts, msg) | CapEvent _ (Event ts (UserMessage msg)) <- elems (hecEventArray hecs) ]++-- | Sum durations in the same buckets to form a histogram.+histogram :: [(Int, Timestamp)] -> [(Int, Timestamp)]+histogram durs = IM.toList $ fromListWith' (+) durs++-- | Sum durations and spark counts in the same buckets to form a histogram.+histogramCounts :: [(Int, (Timestamp, Int))] -> [(Int, (Timestamp, Int))]+histogramCounts durs =+ let agg (dur1, count1) (dur2, count2) =+ -- bangs needed to avoid stack overflow+ let !dur = dur1 + dur2+ !count = count1 + count2+ in (dur, count)+ in IM.toList $ fromListWith' agg durs++fromListWith' :: (a -> a -> a) -> [(Int, a)] -> IM.IntMap a+fromListWith' f xs =+ L.foldl' ins IM.empty xs+ where+#if MIN_VERSION_containers(0,4,1)+ ins t (k,x) = IM.insertWith' f k x t+#else+ ins t (k,x) =+ let r = IM.insertWith f k x t+ v = r IM.! k+ in v `seq` r+#endif
Events/ReadEvents.hs view
@@ -4,7 +4,7 @@ import Events.EventTree import Events.SparkTree-import Events.HECs (HECs(..))+import Events.HECs (HECs(..), histogram) import Events.TestEvents import Events.EventDuration import qualified GUI.ProgressView as ProgressView@@ -13,12 +13,20 @@ import qualified GHC.RTS.Events as GHCEvents import GHC.RTS.Events hiding (Event) +import GHC.RTS.Events.Analysis+import GHC.RTS.Events.Analysis.SparkThread+ import Data.Array-import Data.List+import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import Data.Maybe (catMaybes) import Text.Printf import System.FilePath import Control.Monad import Control.Exception+import qualified Control.DeepSeq as DeepSeq ------------------------------------------------------------------------------- -- The GHC.RTS.Events library returns the profile information@@ -39,38 +47,32 @@ ------------------------------------------------------------------------------- rawEventsToHECs :: [(Maybe Int, [GHCEvents.Event])] -> Timestamp- -> [((Double, Double), (DurationTree, EventTree, SparkTree))]+ -> [(Double, (DurationTree, EventTree, SparkTree))] rawEventsToHECs eventList endTime- = map (toTree . flip lookup heclists) [0 .. maximum0 (map fst heclists)]+ = map (toTree . flip lookup heclists)+ [0 .. maximum (minBound : map fst heclists)] where- heclists = [ (h,events) | (Just h,events) <- eventList ]+ heclists = [ (h, events) | (Just h, events) <- eventList ] - toTree Nothing = ( (0, 0),- ( DurationTreeEmpty,- EventTree 0 0 (EventTreeLeaf []),- emptySparkTree ) )+ toTree Nothing = (0, (DurationTreeEmpty,+ EventTree 0 0 (EventTreeLeaf []),+ emptySparkTree)) toTree (Just evs) =- ( (maxSparkValue, maxSparkPool),- ( mkDurationTree (eventsToDurations nondiscrete) endTime,- mkEventTree discrete endTime,- mkSparkTree sparkD endTime ) )- where (discrete, nondiscrete) = partition isDiscreteEvent evs- ((maxSparkValue, maxSparkPool), sparkD) =- eventsToSparkDurations nondiscrete------------------------------------------------------------------------------------- XXX: what's this for?-maximum0 :: (Num a, Ord a) => [a] -> a-maximum0 [] = -1-maximum0 x = maximum x+ (maxSparkPool,+ (mkDurationTree (eventsToDurations nondiscrete) endTime,+ mkEventTree discrete endTime,+ mkSparkTree sparkD endTime))+ where (discrete, nondiscrete) = L.partition isDiscreteEvent evs+ (maxSparkPool, sparkD) = eventsToSparkDurations nondiscrete ------------------------------------------------------------------------------- -registerEventsFromFile :: String -> ProgressView -> IO (HECs, String, Int, Double)+registerEventsFromFile :: String -> ProgressView+ -> IO (HECs, String, Int, Double) registerEventsFromFile filename = registerEvents (Left filename) -registerEventsFromTrace :: String -> ProgressView -> IO (HECs, String, Int, Double)+registerEventsFromTrace :: String -> ProgressView+ -> IO (HECs, String, Int, Double) registerEventsFromTrace traceName = registerEvents (Right traceName) registerEvents :: Either FilePath String@@ -88,10 +90,10 @@ buildEventLog progress from -------------------------------------------------------------------------------- -- Runs in a background thread ---buildEventLog :: ProgressView -> Either FilePath String -> IO (HECs, String, Int, Double)+buildEventLog :: ProgressView -> Either FilePath String+ -> IO (HECs, String, Int, Double) buildEventLog progress from = case from of Right test -> build test (testTrace test)@@ -103,50 +105,119 @@ Left err -> fail err --FIXME: report error properly Right evs -> build filename evs - where- build name evs = do- let- eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t- eventBlockEnd e = time e+ where+ -- | Integer division, rounding up.+ divUp :: Timestamp -> Timestamp -> Timestamp+ 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)}+ eventsBy = map eBy1000 (events (dat evs))+ eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t+ eventBlockEnd e = time e - lastTx = maximum (0 : map eventBlockEnd (events (dat evs)))+ -- 1, to avoid graph scale 0 and division by 0 later on+ lastTx = maximum (1 : map eventBlockEnd eventsBy) - groups = groupEvents (events (dat evs))- maxTrees = rawEventsToHECs groups lastTx- maxSparkValue = maximum (0 : map (fst . fst) maxTrees)- maxSparkPool = maximum (0 : map (snd . fst) maxTrees)- trees = map snd maxTrees+ groups = groupEvents eventsBy+ maxTrees = rawEventsToHECs groups lastTx+ maxSparkPool = maximum (0 : map fst maxTrees)+ trees = map snd maxTrees - -- sort the events by time and put them in an array- sorted = sortGroups groups- n_events = length sorted- event_arr = listArray (0, n_events-1) sorted- hec_count = length trees+ -- sort the events by time and put them in an array+ sorted = sortGroups groups+ n_events = length sorted+ event_arr = listArray (0, n_events-1) sorted+ hec_count = length trees - hecs = HECs {- hecCount = hec_count,- hecTrees = trees,- hecEventArray = event_arr,- hecLastEventTime = lastTx,- maxSparkValue = maxSparkValue,- maxSparkPool = maxSparkPool- }+ -- Pre-calculate the data for the sparks histogram.+ intDoub :: Integral a => a -> Double+ intDoub = fromIntegral+ -- Discretizes the data using log.+ -- Log base 2 seems to result in 7--15 bars, which is OK visually.+ -- Better would be 10--15 bars, but we want the base to be a small+ -- integer, for readable scales, and we can't go below 2.+ ilog :: Timestamp -> Int+ ilog 0 = 0+ ilog x = floor $ logBase 2 (intDoub x) - treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO ()- treeProgress hec (tree1, tree2, tree3) = do- ProgressView.setText progress $- printf "Building HEC %d/%d" (hec+1) hec_count- ProgressView.setProgress progress hec_count hec- evaluate tree1- evaluate (eventTreeMaxDepth tree2)- evaluate (sparkTreeMaxDepth tree3)- return ()+ sparkProfile :: Process+ ((Map ThreadId (Profile SparkThreadState),+ (Map Int ThreadId, Set ThreadId)),+ CapEvent)+ (ThreadId, (SparkThreadState, Timestamp, Timestamp))+ sparkProfile = profileRouted+ (refineM (spec . ce_event) sparkThreadMachine)+ capabilitySparkThreadMachine+ capabilitySparkThreadIndexer+ (time . ce_event)+ sorted - zipWithM_ treeProgress [0..] trees+ sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp)+ -> [(ThreadId, (SparkThreadState, Timestamp, Timestamp))]+ -> [Maybe (Timestamp, Int, Timestamp)]+ sparkSummary _ [] = []+ sparkSummary m ((threadId, (state, timeStarted', timeElapsed')):xs) =+ case state of+ SparkThreadRunning sparkId' -> case M.lookup threadId m of+ Just (sparkId, timeStarted, timeElapsed) ->+ if sparkId == sparkId'+ then let value = (sparkId, timeStarted, timeElapsed + timeElapsed')+ in sparkSummary (M.insert threadId value m) xs+ else let times = (timeStarted, ilog timeElapsed, timeElapsed)+ in Just times : newSummary sparkId' xs+ Nothing -> newSummary sparkId' xs+ _ -> sparkSummary m xs+ where+ newSummary sparkId = let value = (sparkId, timeStarted', timeElapsed')+ in sparkSummary (M.insert threadId value m) - --TODO: fully evaluate HECs before returning because othewise the last- -- bit of work gets done after the progress window has been closed.+ allHisto :: [(Timestamp, Int, Timestamp)]+ allHisto = catMaybes . sparkSummary M.empty . toList $ sparkProfile - return (hecs, name, n_events, fromIntegral lastTx * 1.0e-9)+ -- Sparks of zero lenght are already well visualized in other graphs:+ durHistogram = filter (\ (_, logdur, _) -> logdur > 0) allHisto+ -- Precompute some extremums of the maximal interval, needed for scales.+ durs = [(logdur, dur) | (_start, logdur, dur) <- durHistogram]+ (logDurs, sumDurs) = L.unzip (histogram durs)+ minXHistogram = minimum (maxBound : logDurs)+ maxXHistogram = maximum (minBound : logDurs)+ maxY = maximum (minBound : sumDurs)+ -- round up to multiples of 10ms+ maxYHistogram = 10000 * ceiling (fromIntegral maxY / 10000) --------------------------------------------------------------------------------+ hecs = HECs {+ hecCount = hec_count,+ hecTrees = trees,+ hecEventArray = event_arr,+ hecLastEventTime = lastTx,+ maxSparkPool = maxSparkPool,+ minXHistogram = minXHistogram,+ maxXHistogram = maxXHistogram,+ maxYHistogram = maxYHistogram,+ durHistogram = durHistogram+ }++ treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO ()+ treeProgress hec (tree1, tree2, tree3) = do+ ProgressView.setText progress $+ printf "Building HEC %d/%d" (hec+1) hec_count+ ProgressView.setProgress progress hec_count hec+ evaluate tree1+ evaluate (eventTreeMaxDepth tree2)+ evaluate (sparkTreeMaxDepth tree3)+ when (length trees == 1 || hec == 1) -- eval only with 2nd HEC+ (return $! DeepSeq.rnf durHistogram)++ zipWithM_ treeProgress [0..] trees+ ProgressView.setProgress progress hec_count hec_count++ --TODO: fully evaluate HECs before returning because othewise the last+ -- bit of work gets done after the progress window has been closed.++ return (hecs, name, n_events, fromIntegral lastTx / 1000000)
Events/SparkStats.hs view
@@ -1,8 +1,6 @@-module Events.SparkStats (- SparkStats(rateCreated, rateDud, rateOverflowed,- rateConverted, rateFizzled, rateGCd,- meanPool, maxPool, minPool),- initial, create, rescale, aggregate, agEx,+module Events.SparkStats+ ( SparkStats(..)+ , initial, create, rescale, aggregate, agEx ) where import Data.Word (Word64)@@ -37,9 +35,9 @@ -- but to have the same tree for rates and pool sizes, we then have -- to shift the durations by half interval size to the right -- (which would be neglectable if the interval was small and even).-create :: (Word64, Word64, Word64, Word64, Word64, Word64, Word64) ->- (Word64, Word64, Word64, Word64, Word64, Word64, Word64) ->- SparkStats+create :: (Word64, Word64, Word64, Word64, Word64, Word64, Word64)+ -> (Word64, Word64, Word64, Word64, Word64, Word64, Word64)+ -> SparkStats create (crt1, dud1, ovf1, cnv1, fiz1, gcd1, remaining1) (crt2, dud2, ovf2, cnv2, fiz2, gcd2, _remaining2) = let (crt, dud, ovf, cnv, fiz, gcd) =@@ -54,8 +52,8 @@ -- | Reduce a list of spark stats; spark pool stats are overwritten. foldStats :: (Double -> Double -> Double)- -> Double -> Double -> Double- -> [SparkStats] -> SparkStats+ -> Double -> Double -> Double+ -> [SparkStats] -> SparkStats foldStats f meanP maxP minP l = SparkStats (foldr f 0 (map rateCreated l))@@ -76,6 +74,7 @@ -- in reverse chronological order, of consecutive subintervals -- that sum up to the original interval. aggregate :: [SparkStats] -> SparkStats+aggregate [] = error "aggregate" aggregate [s] = s -- optimization aggregate l = let meanP = sum (map meanPool l) / fromIntegral (length l) -- TODO: inaccurate
Events/SparkTree.hs view
@@ -9,9 +9,10 @@ import qualified Events.SparkStats as SparkStats -import qualified GHC.RTS.Events as GHC+import qualified GHC.RTS.Events as GHCEvents import GHC.RTS.Events (Timestamp) +import Control.Exception (assert) import Text.Printf -- import Debug.Trace @@ -21,47 +22,32 @@ -- spark stats that record the spark transition rate -- and the absolute number of sparks in the spark pool within the duration. data SparkDuration =- SparkDuration { startT :: Timestamp,- deltaC :: SparkStats.SparkStats }+ SparkDuration { startT :: {-#UNPACK#-}!Timestamp,+ deltaC :: {-#UNPACK#-}!SparkStats.SparkStats } deriving Show -- | Calculates durations and maximal rendered values from the event log. -- Warning: cannot be applied to a suffix of the log (assumes start at time 0).-eventsToSparkDurations :: [GHC.Event] -> ((Double, Double), [SparkDuration])+eventsToSparkDurations :: [GHCEvents.Event] -> (Double, [SparkDuration]) eventsToSparkDurations es =- let aux _startTime _startCounters [] = ((0, 0), [])+ let aux _startTime _startCounters [] = (0, []) aux startTime startCounters (event : events) =- case GHC.spec event of- GHC.SparkCounters crt dud ovf cnv fiz gcd rem ->- let endTime = GHC.time event+ case GHCEvents.spec event of+ GHCEvents.SparkCounters crt dud ovf cnv fiz gcd rem ->+ let endTime = GHCEvents.time event endCounters = (crt, dud, ovf, cnv, fiz, gcd, rem) delta = SparkStats.create startCounters endCounters- duration = endTime - startTime- newMaxSparkValue = maxSparkRenderedValue delta duration newMaxSparkPool = SparkStats.maxPool delta sd = SparkDuration { startT = startTime, deltaC = delta }- ((oldMaxSparkValue, oldMaxSparkPool), l) =+ (oldMaxSparkPool, l) = aux endTime endCounters events- in ((max oldMaxSparkValue newMaxSparkValue,- max oldMaxSparkPool newMaxSparkPool),+ in ( max oldMaxSparkPool newMaxSparkPool, sd : l) _otherEvent -> aux startTime startCounters events in aux 0 (0,0,0,0,0,0,0) es --- | This is the maximal raw value, to be displayed at total zoom in.--- It's smoothed out (so lower values) at lower zoom levels.-maxSparkRenderedValue :: SparkStats.SparkStats -> Timestamp -> Double-maxSparkRenderedValue c duration =- max (SparkStats.rateDud c +- SparkStats.rateCreated c +- SparkStats.rateOverflowed c)- (SparkStats.rateFizzled c +- SparkStats.rateConverted c +- SparkStats.rateGCd c)- / fromIntegral duration - -- | We map the spark transition durations (intervals) onto a binary -- search tree, so that we can easily find the durations -- that correspond to a particular view of the timeline.@@ -84,9 +70,11 @@ -- ^ the LHS split; all data lies completely between start and split SparkNode -- ^ the RHS split; all data lies completely between split and end- SparkStats.SparkStats -- ^ aggregate of the spark stats within the span+ {-#UNPACK#-}!SparkStats.SparkStats+ -- ^ aggregate of the spark stats within the span | SparkTreeLeaf- SparkStats.SparkStats -- ^ the spark stats for the base duration+ {-#UNPACK#-}!SparkStats.SparkStats+ -- ^ the spark stats for the base duration | SparkTreeEmpty -- ^ represents a span that no data referts to, e.g., after the last GC deriving Show@@ -107,8 +95,8 @@ -- there is no data about sparks for the last time interval -- (the subtree for the interval will have SparkTreeEmpty node). mkSparkTree :: [SparkDuration] -- ^ spark durations calculated from events- -> Timestamp -- ^ end time of last event in the list- -> SparkTree+ -> Timestamp -- ^ end time of last event in the list+ -> SparkTree mkSparkTree es endTime = SparkTree s e $ -- trace (show tree) $@@ -133,23 +121,23 @@ | null rhs = splitSparks es lhs_end | null lhs- = error ((printf "null lhs: len = %d, startTime = %d, endTime = %d\n"- (length es) startTime endTime)- ++ '\n': show es)+ = error $+ printf "splitSparks: null lhs: len = %d, startTime = %d, endTime = %d\n"+ (length es) startTime endTime+ ++ '\n' : show es | otherwise = -- trace (printf "len = %d, startTime = %d, endTime = %d\n" (length es) startTime endTime) $- if length lhs + length rhs /= length es- then error (printf "splitSparks3; %d %d %d"- (length es) (length lhs) (length rhs))- else- SparkSplit (startT $ head rhs)- ltree- rtree- (SparkStats.aggregate (subDelta rtree ++ subDelta ltree))-+ assert (length lhs + length rhs == length es) $+ SparkSplit (startT $ head rhs)+ ltree+ rtree+ (SparkStats.aggregate (subDelta rtree ++ subDelta ltree)) where+ -- | Integer division, rounding up.+ divUp :: Timestamp -> Timestamp -> Timestamp+ divUp n k = (n + k - 1) `div` k startTime = startT $ head es- splitTime = startTime + (endTime - startTime) `div` 2+ splitTime = startTime + (endTime - startTime) `divUp` 2 (lhs, lhs_end, rhs) = splitSparkList es [] splitTime 0 @@ -168,9 +156,13 @@ -> ([SparkDuration], Timestamp, [SparkDuration]) splitSparkList [] acc !_tsplit !tmax = (reverse acc, tmax, [])+splitSparkList [e] acc !_tsplit !tmax+ -- Just one event left: put it on the right. This ensures that we+ -- have at least one event on each side of the split.+ = (reverse acc, tmax, [e]) splitSparkList (e:es) acc !tsplit !tmax- | startT e < tsplit -- pick all durations that start before the split- = splitSparkList es (e:acc) tsplit (max tmax (startT e))+ | startT e <= tsplit -- pick all durations that start at or before the split+ = splitSparkList es (e:acc) tsplit (max tmax (startT e)) | otherwise = (reverse acc, tmax, e:es) @@ -180,7 +172,7 @@ -- at the level of the spark tree covering intervals of the size -- similar to the timeslice size. sparkProfile :: Timestamp -> Timestamp -> Timestamp -> SparkTree- -> [SparkStats.SparkStats]+ -> [SparkStats.SparkStats] sparkProfile slice start0 end0 t = {- trace (show flat) $ -} chopped @@ -246,12 +238,16 @@ (s, e) | SparkTree s e _ <- t = (s, e) -- The common part of the slice and the duration.- common = min (start1 + slice) e - max start1 s+ mi = min (start1 + slice) e+ ma = max start1 s+ common = if mi < ma then 0 else mi - ma -- Instead of drilling down the tree (unless it's a leaf), -- we approximate by taking a proportion of the aggregate value, -- depending on how much of the spark duration corresponding -- to the tree node is covered by our timeslice.- proportion = fromIntegral common / fromIntegral (e - s)+ proportion = if e > s+ then fromIntegral common / fromIntegral (e - s)+ else assert (e == s && common == 0) $ 0 -- Spark transitions in the tree are in units spark/duration. -- Here the numbers are rescaled so that the units are spark/ms.
Events/TestEvents.hs view
@@ -13,8 +13,15 @@ ------------------------------------------------------------------------------- eventLog :: [Event] -> EventLog-eventLog events- = EventLog (Header testEventTypes) (Data events)+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)}+ eventsBy = map eBy1000 events+ in EventLog (Header testEventTypes) (Data eventsBy) ------------------------------------------------------------------------------- @@ -329,4 +336,3 @@ ] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength --------------------------------------------------------------------------------
GUI/BookmarkView.hs view
@@ -84,7 +84,7 @@ treeViewSetModel bookmarkTreeView bookmarkStore cellLayoutSetAttributes columnTs cellTs bookmarkStore $ \(ts,_) ->- [ cellText := showFFloat (Just 6) (fromIntegral ts / 1000000000) "s" ]+ [ cellText := showFFloat (Just 6) (fromIntegral ts / 1000000) "s" ] cellLayoutSetAttributes columnLabel cellLabel bookmarkStore $ \(_,label) -> [ cellText := label ]
GUI/Dialogs.hs view
@@ -1,8 +1,3 @@------------------------------------------------------------------------------------ $Id: About.hs#1 2009/03/20 13:27:50 REDMOND\\satnams $---- $Source: //depot/satnams/haskell/ThreadScope/About.hs $--------------------------------------------------------------------------------- module GUI.Dialogs where import Paths_threadscope (getDataFileName, version)@@ -29,9 +24,11 @@ "Simon Marlow <simonm@microsoft.com>", "Satnam Singh <s.singh@ieee.org>", "Duncan Coutts <duncan@well-typed.com>",- "Mikolaj Konarski <mikolaj@well-typed.com>"],+ "Mikolaj Konarski <mikolaj@well-typed.com>",+ "Nicolas Wu <nick@well-typed.com>",+ "Eric Kow <eric@well-typed.com>"], aboutDialogLogo := Just logo,- aboutDialogWebsite := "http://research.microsoft.com/threadscope",+ aboutDialogWebsite := "http://www.haskell.org/haskellwiki/ThreadScope", windowTransientFor := toWindow parent ] onResponse dialog $ \_ -> widgetDestroy dialog
GUI/EventsView.hs view
@@ -13,7 +13,7 @@ import GHC.RTS.Events import Graphics.UI.Gtk-import GUI.GtkExtras as GtkExt+import qualified GUI.GtkExtras as GtkExt import Control.Monad.Reader import Data.Array@@ -29,7 +29,7 @@ } data EventsViewActions = EventsViewActions {- timelineViewCursorChanged :: Int -> IO ()+ eventsViewCursorChanged :: Int -> IO () } data ViewState = ViewState {@@ -41,6 +41,7 @@ = EventsEmpty | EventsLoaded { cursorPos :: !Int,+ mrange :: !(Maybe (Int, Int)), eventsArr :: Array Int CapEvent } @@ -105,7 +106,7 @@ case eventsState of EventsEmpty -> return () EventsLoaded{cursorPos, eventsArr} ->- timelineViewCursorChanged cursorPos'+ eventsViewCursorChanged cursorPos' where cursorPos' = clampBounds range (by pagejump end cursorPos) range@(_,end) = bounds eventsArr@@ -149,7 +150,7 @@ widgetGrabFocus drawArea case hitpointToLine viewState yOffset y of Nothing -> return ()- Just n -> timelineViewCursorChanged n+ Just n -> eventsViewCursorChanged n on drawArea scrollEvent $ do dir <- eventScrollDirection@@ -181,6 +182,7 @@ Nothing -> EventsEmpty Just events -> EventsLoaded { cursorPos = 0,+ mrange = Nothing, eventsArr = events } viewState' = viewState { eventsState = eventsState' }@@ -197,15 +199,15 @@ EventsEmpty -> return Nothing EventsLoaded{cursorPos} -> return (Just cursorPos) -eventsViewSetCursor :: EventsView -> Int -> IO ()-eventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n = do+eventsViewSetCursor :: EventsView -> Int -> Maybe (Int, Int) -> IO ()+eventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n mrange = do viewState@ViewState{eventsState} <- readIORef stateRef case eventsState of EventsEmpty -> return () EventsLoaded{eventsArr} -> do let n' = clampBounds (bounds eventsArr) n writeIORef stateRef viewState {- eventsState = eventsState { cursorPos = n' }+ eventsState = eventsState { cursorPos = n', mrange } } eventsViewScrollToLine eventsView n' widgetQueueDraw drawArea@@ -274,30 +276,32 @@ (width,clipHeight) <- widgetGetSize drawArea let clipRect = Rectangle 0 0 width clipHeight - let --TODO: calculate based on average char width and n digits- timeWidth = 120+ let -- With average char width, timeWidth is enough for 24 hours of logs+ -- (way more than TS can handle, currently). Aligns nicely with+ -- current timeline_yscale_area width, too.+ -- TODO: take timeWidth from the yScaleDrawingArea width+ -- TODO: perhaps make the timeWidth area grey, too?+ -- TODO: perhaps limit scroll to the selected interval (perhaps not strictly, but only so that the interval area does not completely vanish from the visible area)?+ timeWidth = 105 columnGap = 20 descrWidth = width - timeWidth - columnGap sequence_- [ do when selected $+ [ do when (inside || selected) $ GtkExt.stylePaintFlatBox style win- state ShadowNone+ state1 ShadowNone clipRect drawArea "" 0 (round y) width (round lineHeight) - let state' | selected = state- | otherwise = StateNormal- -- The event time layoutSetText layout (showEventTime event) layoutSetAlignment layout AlignRight layoutSetWidth layout (Just (fromIntegral timeWidth)) GtkExt.stylePaintLayout style win- state' True+ state2 True clipRect drawArea "" 0 (round y)@@ -309,7 +313,7 @@ layoutSetWidth layout (Just (fromIntegral descrWidth)) GtkExt.stylePaintLayout style win- state' True+ state2 True clipRect drawArea "" (timeWidth + columnGap) (round y)@@ -318,16 +322,21 @@ | n <- [begin..end] , let y = fromIntegral n * lineHeight - yOffset event = eventsArr ! n+ inside = maybe False (\ (s, e) -> s <= n && n <= e) mrange selected = cursorPos == n+ (state1, state2)+ | inside = (StatePrelight, StatePrelight)+ | selected = (state, state)+ | otherwise = (state, StateNormal) ] where showEventTime (CapEvent _cap (Event time _spec)) =- showFFloat (Just 6) (fromIntegral time / 1000000000) "s"+ showFFloat (Just 6) (fromIntegral time / 1000000) "s" showEventDescr (CapEvent cap (Event _time spec)) = (case cap of Nothing -> ""- Just c -> "cap " ++ show c ++ ": ")+ Just c -> "HEC " ++ show c ++ ": ") ++ case spec of UnknownEvent{ref} -> "unknown event; " ++ show ref Message msg -> msg
GUI/GtkExtras.hs view
@@ -6,6 +6,7 @@ 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@@ -13,6 +14,7 @@ import Foreign import Foreign.C+import Control.Monad import Control.Concurrent.MVar waitGUI :: IO ()@@ -74,6 +76,14 @@ (fromIntegral x) (fromIntegral y) layout ++launchProgramForURI :: String -> IO Bool+launchProgramForURI uri =+ propagateGError $ \errPtrPtr ->+ withCString uri $ \uriStrPtr -> do+ timestamp <- gtk_get_current_event_time+ liftM toBool $ gtk_show_uri nullPtr uriStrPtr timestamp errPtrPtr+ ------------------------------------------------------------------------------- foreign import ccall safe "gtk_paint_flat_box"@@ -81,3 +91,9 @@ foreign import ccall safe "gtk_paint_layout" gtk_paint_layout :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> Ptr PangoLayoutRaw -> IO ()++foreign import ccall safe "gtk_show_uri"+ gtk_show_uri :: Ptr Screen -> Ptr CChar -> CUInt -> Ptr (Ptr ()) -> IO CInt++foreign import ccall unsafe "gtk_get_current_event_time"+ gtk_get_current_event_time :: IO CUInt
+ GUI/Histogram.hs view
@@ -0,0 +1,129 @@+module GUI.Histogram (+ HistogramView,+ histogramViewNew,+ histogramViewSetHECs,+ histogramViewSetInterval,+ ) where++import Events.HECs+import GUI.Timeline.Render (renderTraces, renderYScaleArea)+import GUI.Timeline.Render.Constants+import GUI.Types++import Graphics.UI.Gtk+import qualified Graphics.Rendering.Cairo as C+import qualified GUI.GtkExtras as GtkExt++import Data.IORef++data HistogramView =+ HistogramView+ { hecsIORef :: IORef (Maybe HECs)+ , mintervalIORef :: IORef (Maybe Interval)+ , histogramDrawingArea :: DrawingArea+ , histogramYScaleArea :: DrawingArea+ }++histogramViewSetHECs :: HistogramView -> Maybe HECs -> IO ()+histogramViewSetHECs HistogramView{..} mhecs = do+ writeIORef hecsIORef mhecs+ widgetQueueDraw histogramDrawingArea+ widgetQueueDraw histogramYScaleArea++histogramViewSetInterval :: HistogramView -> Maybe Interval -> IO ()+histogramViewSetInterval HistogramView{..} minterval = do+ writeIORef mintervalIORef minterval+ widgetQueueDraw histogramDrawingArea+ widgetQueueDraw histogramYScaleArea++histogramViewNew :: Builder -> IO HistogramView+histogramViewNew builder = do+ let getWidget cast = builderGetObject builder cast+ histogramDrawingArea <- getWidget castToDrawingArea "histogram_drawingarea"+ histogramYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area2"+ timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area"++ -- HACK: layoutSetAttributes does not work for \mu, so let's work around+ fd <- fontDescriptionNew+ fontDescriptionSetSize fd 8+ fontDescriptionSetFamily fd "sans serif"+ widgetModifyFont histogramYScaleArea (Just fd)++ (_, xh) <- widgetGetSize timelineXScaleArea+ let xScaleAreaHeight = fromIntegral xh+ traces = [TraceHistogram]+ paramsHist (w, h) minterval = ViewParameters+ { width = w+ , height = h+ , viewTraces = traces+ , hadjValue = 0+ , scaleValue = 1+ , maxSpkValue = undefined+ , detail = undefined+ , bwMode = undefined+ , labelsMode = False+ , histogramHeight = h - histXScaleHeight+ , minterval = minterval+ , xScaleAreaHeight = xScaleAreaHeight+ }++ hecsIORef <- newIORef Nothing+ mintervalIORef <- newIORef Nothing++ pangoCtx <- widgetGetPangoContext histogramDrawingArea+ style <- get histogramDrawingArea widgetStyle+ layout <- layoutEmpty pangoCtx+ layoutSetMarkup layout $ "No detailed spark events in this eventlog.\n"+ ++ "Re-run with <tt>+RTS -lf</tt> to generate them."++ -- Program the callback for the capability drawingArea+ on histogramDrawingArea exposeEvent $+ C.liftIO $ do+ maybeEventArray <- readIORef hecsIORef+ win <- widgetGetDrawWindow histogramDrawingArea+ (w, windowHeight) <- widgetGetSize histogramDrawingArea+ case maybeEventArray of+ Nothing -> return False+ Just hecs+ | null (durHistogram hecs) -> do+ GtkExt.stylePaintLayout+ style win+ StateNormal True+ (Rectangle 0 0 w windowHeight)+ histogramDrawingArea ""+ 4 20+ layout+ return True+ | otherwise -> do+ minterval <- readIORef mintervalIORef+ if windowHeight < 80+ then return False+ else do+ let size = (w, windowHeight - firstTraceY)+ params = paramsHist size minterval+ rect = Rectangle 0 0 w (snd size)+ renderWithDrawable win $+ renderTraces params hecs rect+ return True++ -- Redrawing histogramYScaleArea+ histogramYScaleArea `onExpose` \_ -> do+ maybeEventArray <- readIORef hecsIORef+ case maybeEventArray of+ Nothing -> return False+ Just hecs+ | null (durHistogram hecs) -> return False+ | otherwise -> do+ win <- widgetGetDrawWindow histogramYScaleArea+ minterval <- readIORef mintervalIORef+ (_, windowHeight) <- widgetGetSize histogramYScaleArea+ if windowHeight < 80+ then return False+ else do+ let size = (undefined, windowHeight - firstTraceY)+ params = paramsHist size minterval+ renderWithDrawable win $+ renderYScaleArea params hecs histogramYScaleArea+ return True++ return HistogramView{..}
GUI/KeyView.hs view
@@ -7,7 +7,7 @@ import GUI.Timeline.Render.Constants import Graphics.UI.Gtk-import Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo as C ---------------------------------------------------------------------------@@ -38,11 +38,15 @@ selection <- treeViewGetSelection keyTreeView treeSelectionSetMode selection SelectionNone + let tooltipColumn = makeColumnIdString 0+ customStoreSetColumn keyStore tooltipColumn (\(_,tooltip,_) -> tooltip) treeViewSetModel keyTreeView keyStore - cellLayoutSetAttributes keyColumn imageCell keyStore $ \(_,img) ->+ set keyTreeView [ treeViewTooltipColumn := tooltipColumn ]++ cellLayoutSetAttributes keyColumn imageCell keyStore $ \(_,_,img) -> [ cellPixbuf := img ]- cellLayoutSetAttributes keyColumn labelCell keyStore $ \(label,_) ->+ cellLayoutSetAttributes keyColumn labelCell keyStore $ \(label,_,_) -> [ cellText := label ] ---------------------------------------------------------------------------@@ -51,47 +55,111 @@ ------------------------------------------------------------------------------- -data KeyStyle = Box | Vertical+data KeyStyle = KDuration | KEvent | KEventAndGraph -keyData :: [(String, KeyStyle, Color)]-keyData = [ ("running", Box, runningColour)- , ("GC", Box, gcColour)- , ("create thread", Vertical, createThreadColour)- , ("run spark", Vertical, createdConvertedColour)- , ("thread runnable", Vertical, threadRunnableColour)- , ("seq GC req", Vertical, seqGCReqColour)- , ("par GC req", Vertical, parGCReqColour)- , ("migrate thread", Vertical, migrateThreadColour)- , ("thread wakeup", Vertical, threadWakeupColour)- , ("shutdown", Vertical, shutdownColour)- ]+keyData :: [(String, KeyStyle, Color, String)]+keyData =+ [ ("running", KDuration, runningColour,+ "Indicates a period of time spent running Haskell code (not GC, not blocked/idle)")+ , ("GC", KDuration, gcColour,+ "Indicates a period of time spent by the RTS performing garbage collection (GC)")+ , ("create thread", KEvent, createThreadColour,+ "Indicates a new Haskell thread has been created")+ , ("seq GC req", KEvent, seqGCReqColour,+ "Indicates a HEC has requested to start a sequential GC")+ , ("par GC req", KEvent, parGCReqColour,+ "Indicates a HEC has requested to start a parallel GC")+ , ("migrate thread", KEvent, migrateThreadColour,+ "Indicates a Haskell thread has been moved from one HEC to another")+ , ("thread wakeup", KEvent, threadWakeupColour,+ "Indicates that a thread that was previously blocked (e.g. I/O, MVar etc) is now ready to run")+ , ("shutdown", KEvent, shutdownColour,+ "Indicates a HEC is terminating")+ , ("user message", KEvent, userMessageColour,+ "Indicates a message generated from Haskell code (via traceEvent)")+ , ("create spark", KEventAndGraph, createdConvertedColour,+ "As an event it indicates a use of `par` resulted in a spark being " +++ "created (and added to the spark pool). In the spark creation " +++ "graph the coloured area represents the number of sparks created.")+ , ("dud spark", KEventAndGraph, fizzledDudsColour,+ "As an event it indicates a use of `par` resulted in the spark being " +++ "discarded because it was a 'dud' (already evaluated). In the spark " +++ "creation graph the coloured area represents the number of dud sparks.")+ , ("overflowed spark",KEventAndGraph, overflowedColour,+ "As an event it indicates a use of `par` resulted in the spark being " +++ "discarded because the spark pool was full. In the spark creation " +++ "graph the coloured area represents the number of overflowed sparks.")+ , ("run spark", KEventAndGraph, createdConvertedColour,+ "As an event it indicates a spark has started to be run/evaluated. " +++ "In the spark conversion graph the coloured area represents the number " +++ "of sparks run.")+ , ("fizzled spark", KEventAndGraph, fizzledDudsColour,+ "As an event it indicates a spark has 'fizzled', meaning it has been " +++ "discovered that the spark's thunk was evaluated by some other thread. " +++ "In the spark conversion graph the coloured area represents the number " +++ "of sparks that have fizzled.")+ , ("GCed spark", KEventAndGraph, gcColour,+ "As an event it indicates a spark has been GC'd, meaning it has been " +++ "discovered that the spark's thunk was no longer needed anywhere. " +++ "In the spark conversion graph the coloured area represents the number " +++ "of sparks that were GC'd.")+ ] -createKeyEntries :: DrawableClass dw => dw- -> [(String, KeyStyle, Color)] -> IO [(String, Pixbuf)]+createKeyEntries :: DrawableClass dw+ => dw+ -> [(String, KeyStyle, Color,String)]+ -> IO [(String, String, Pixbuf)] createKeyEntries similar entries = sequence [ do pixbuf <- renderToPixbuf similar (50, hecBarHeight) $ do- setSourceRGB 1 1 1- paint+ C.setSourceRGB 1 1 1+ C.paint renderKeyIcon style colour- return (label, pixbuf)+ return (label, tooltip, pixbuf) - | (label, style, colour) <- entries ]+ | (label, style, colour, tooltip) <- entries ] -renderKeyIcon :: KeyStyle -> Color -> Render ()-renderKeyIcon Box keyColour = do+renderKeyIcon :: KeyStyle -> Color -> C.Render ()+renderKeyIcon KDuration keyColour = do setSourceRGBAhex keyColour 1.0- rectangle 0 0 50 (fromIntegral (hecBarHeight `div` 2))+ let x = fromIntegral ox+ C.rectangle (x - 2) 5 38 (fromIntegral (hecBarHeight `div` 2)) C.fill-renderKeyIcon Vertical keyColour = do+renderKeyIcon KEvent keyColour = renderKEvent keyColour+renderKeyIcon KEventAndGraph keyColour = do+ renderKEvent keyColour+ -- An icon roughly repreenting a jagedy graph.+ let x = fromIntegral ox+ y = fromIntegral hecBarHeight+ C.moveTo (2*x) (y - 2)+ C.relLineTo 3 (-6)+ C.relLineTo 3 0+ C.relLineTo 3 3+ C.relLineTo 5 1+ C.relLineTo 1 (-(y - 4))+ C.relLineTo 2 (y - 4)+ C.relLineTo 1 (-(y - 4))+ C.relLineTo 2 (y - 4)+ C.lineTo (2*x+20) (y - 2)+ C.fill+ setSourceRGBAhex black 1.0+ C.setLineWidth 1.0+ C.moveTo (2*x-4) (y - 2.5)+ C.lineTo (2*x+24) (y - 2.5)+ C.stroke++renderKEvent :: Color -> C.Render ()+renderKEvent keyColour = do setSourceRGBAhex keyColour 1.0- setLineWidth 3.0- moveTo 10 0- relLineTo 0 25+ C.setLineWidth 3.0+ let x = fromIntegral ox+ C.moveTo x 0+ C.relLineTo 0 25 C.stroke -renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> Render () -> IO Pixbuf+renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> C.Render ()+ -> IO Pixbuf renderToPixbuf similar (w, h) draw = do pixmap <- pixmapNew (Just similar) w h Nothing renderWithDrawable pixmap draw
GUI/Main.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE CPP #-}--- ThreadScope: a graphical viewer for Haskell event log information.--- Maintainer: satnams@microsoft.com, s.singh@ieee.org- module GUI.Main (runGUI) where -- Imports for GTK-import Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk as Gtk import System.Glib.GError (failOnGError) -- Imports from Haskell library@@ -24,12 +21,15 @@ import Paths_threadscope -- Imports for ThreadScope-import GUI.MainWindow as MainWindow+import qualified GUI.MainWindow as MainWindow import GUI.Types import Events.HECs hiding (Event) import GUI.Dialogs import Events.ReadEvents import GUI.EventsView+import GUI.SummaryView+import GUI.StartupInfoView+import GUI.Histogram import GUI.Timeline import GUI.TraceView import GUI.BookmarkView@@ -37,13 +37,17 @@ import GUI.SaveAs import qualified GUI.ConcurrencyControl as ConcurrencyControl import qualified GUI.ProgressView as ProgressView+import qualified GUI.GtkExtras as GtkExtras ------------------------------------------------------------------------------- data UIEnv = UIEnv { - mainWin :: MainWindow,+ mainWin :: MainWindow.MainWindow, eventsView :: EventsView,+ startupView :: StartupInfoView,+ summaryView :: InfoView,+ histogramView :: HistogramView, timelineWin :: TimelineView, traceView :: TraceView, bookmarkView :: BookmarkView,@@ -58,7 +62,7 @@ | EventlogLoaded { mfilename :: Maybe FilePath, --test traces have no filepath hecs :: HECs,- cursorTs :: Timestamp,+ selection :: TimeSelection, cursorPos :: Int } @@ -71,6 +75,8 @@ data Event = EventOpenDialog | EventExportDialog+ | EventLaunchWebsite+ | EventLaunchTutorial | EventAboutDialog | EventQuit @@ -93,11 +99,11 @@ | EventTimelineZoomIn | EventTimelineZoomOut | EventTimelineZoomToFit- | EventTimelineShowLabels Bool+ | EventTimelineLabelsMode Bool | EventTimelineShowBW Bool | EventCursorChangedIndex Int- | EventCursorChangedTimestamp Timestamp+ | EventCursorChangedSelection TimeSelection | EventTracesChanged [Trace] @@ -111,19 +117,21 @@ constructUI :: IO UIEnv constructUI = failOnGError $ do - builder <- builderNew- builderAddFromFile builder =<< getDataFileName "threadscope.ui"+ builder <- Gtk.builderNew+ Gtk.builderAddFromFile builder =<< getDataFileName "threadscope.ui" eventQueue <- Chan.newChan let post = postEvent eventQueue - mainWin <- mainWindowNew builder MainWindowActions {+ mainWin <- MainWindow.mainWindowNew builder MainWindow.MainWindowActions { mainWinOpen = post EventOpenDialog, mainWinExport = post EventExportDialog, mainWinQuit = post EventQuit, mainWinViewSidebar = post . EventShowSidebar, mainWinViewEvents = post . EventShowEvents, mainWinViewReload = post EventFileReload,+ mainWinWebsite = post EventLaunchWebsite,+ mainWinTutorial = post EventLaunchTutorial, mainWinAbout = post EventAboutDialog, mainWinJumpStart = post EventTimelineJumpStart, mainWinJumpEnd = post EventTimelineJumpEnd,@@ -133,18 +141,23 @@ mainWinJumpZoomIn = post EventTimelineZoomIn, mainWinJumpZoomOut = post EventTimelineZoomOut, mainWinJumpZoomFit = post EventTimelineZoomToFit,- mainWinDisplayLabels = post . EventTimelineShowLabels,+ mainWinDisplayLabels = post . EventTimelineLabelsMode, mainWinViewBW = post . EventTimelineShowBW } timelineWin <- timelineViewNew builder TimelineViewActions {- timelineViewCursorChanged = post . EventCursorChangedTimestamp+ timelineViewSelectionChanged = post . EventCursorChangedSelection } eventsView <- eventsViewNew builder EventsViewActions {- timelineViewCursorChanged = post . EventCursorChangedIndex+ eventsViewCursorChanged = post . EventCursorChangedIndex } + startupView <- startupInfoViewNew builder+ summaryView <- summaryViewNew builder++ histogramView <- histogramViewNew builder+ traceView <- traceViewNew builder TraceViewActions { traceViewTracesChanged = post . EventTracesChanged }@@ -152,8 +165,9 @@ bookmarkView <- bookmarkViewNew builder BookmarkViewActions { bookmarkViewAddBookmark = post EventBookmarkAdd, bookmarkViewRemoveBookmark = post . EventBookmarkRemove,- bookmarkViewGotoBookmark = \ts -> post (EventCursorChangedTimestamp ts)- >> post EventTimelineJumpCursor,+ bookmarkViewGotoBookmark = \ts -> do+ post (EventCursorChangedSelection (PointSelection ts))+ post EventTimelineJumpCursor, bookmarkViewEditLabel = \n v -> post (EventBookmarkEdit n v) } @@ -219,26 +233,35 @@ MainWindow.setStatusMessage mainWin $ printf "%s (%d events, %.3fs)" name nevents timespan - eventsViewSetEvents eventsView (Just (hecEventArray hecs))+ let mevents = Just $ hecEventArray hecs+ eventsViewSetEvents eventsView mevents+ startupInfoViewSetEvents startupView mevents+ summaryViewSetEvents summaryView mevents+ histogramViewSetHECs histogramView (Just hecs) traceViewSetHECs traceView hecs traces' <- traceViewGetTraces traceView timelineWindowSetHECs timelineWin (Just hecs) timelineWindowSetTraces timelineWin traces' + -- TODO: disabled for now, until it's configurable (see the TODO file) -- We set user 'traceEvent' messages as initial bookmarks. -- This is somewhat of an experiment. If users use lots of trace events -- then it will not be appropriate and we'll want a separate 'traceMark'.- let usrMsgs = extractUserMessages hecs- sequence_ [ bookmarkViewAdd bookmarkView ts label- | (ts, label) <- usrMsgs ]- timelineWindowSetBookmarks timelineWin (map fst usrMsgs)+ --let usrMsgs = extractUserMessages hecs+ --sequence_ [ bookmarkViewAdd bookmarkView ts label+ -- | (ts, label) <- usrMsgs ]+ -- timelineWindowSetBookmarks timelineWin (map fst usrMsgs)+ bookmarkViewClear bookmarkView+ timelineWindowSetBookmarks timelineWin [] - continueWith EventlogLoaded {- mfilename = mfilename,- hecs = hecs,- cursorTs = 0,- cursorPos = 0- }+ if nevents == 0+ then continueWith NoEventlogLoaded+ else continueWith EventlogLoaded+ { mfilename = mfilename+ , hecs = hecs+ , selection = PointSelection 0+ , cursorPos = 0+ } dispatch EventExportDialog EventlogLoaded {mfilename} = do@@ -254,11 +277,22 @@ bwMode = False, labelsMode = False }+ let yScaleArea = timelineGetYScaleArea timelineWin case format of- FormatPDF -> saveAsPDF filename hecs viewParams'- FormatPNG -> saveAsPNG filename hecs viewParams'+ FormatPDF ->+ saveAsPDF filename hecs viewParams' yScaleArea+ FormatPNG ->+ saveAsPNG filename hecs viewParams' yScaleArea continue + dispatch EventLaunchWebsite _ = do+ GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope"+ continue++ dispatch EventLaunchTutorial _ = do+ GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope_Tour"+ continue+ dispatch EventAboutDialog _ = do aboutDialog mainWin continue@@ -283,7 +317,7 @@ continue dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do- timelineCentreOnCursor timelineWin --TODO: pass cursorTs here+ timelineCentreOnCursor timelineWin --TODO: pass selection here eventsViewScrollToLine eventsView cursorPos continue @@ -304,8 +338,8 @@ timelineZoomToFit timelineWin continue - dispatch (EventTimelineShowLabels showLabels) _ = do- timelineSetShowLabels timelineWin showLabels+ dispatch (EventTimelineLabelsMode labelsMode) _ = do+ timelineSetLabelsMode timelineWin labelsMode continue dispatch (EventTimelineShowBW showBW) _ = do@@ -313,29 +347,47 @@ continue dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do- let cursorTs' = eventIndexToTimestamp hecs cursorPos'- timelineSetCursor timelineWin cursorTs'- eventsViewSetCursor eventsView cursorPos'+ let cursorTs' = eventIndexToTimestamp hecs cursorPos'+ selection' = PointSelection cursorTs'+ timelineSetSelection timelineWin selection'+ eventsViewSetCursor eventsView cursorPos' Nothing continueWith eventlogState {- cursorTs = cursorTs',+ selection = selection', cursorPos = cursorPos' } - dispatch (EventCursorChangedTimestamp cursorTs') EventlogLoaded{hecs} = do+ dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs'))+ EventlogLoaded{hecs} = do let cursorPos' = timestampToEventIndex hecs cursorTs'- timelineSetCursor timelineWin cursorTs'- eventsViewSetCursor eventsView cursorPos'+ timelineSetSelection timelineWin selection'+ eventsViewSetCursor eventsView cursorPos' Nothing+ histogramViewSetInterval histogramView Nothing continueWith eventlogState {- cursorTs = cursorTs',+ selection = selection', cursorPos = cursorPos' } + dispatch (EventCursorChangedSelection selection'@(RangeSelection start end))+ EventlogLoaded{hecs} = do+ let cursorPos' = timestampToEventIndex hecs start+ mrange = Just (cursorPos', timestampToEventIndex hecs end)+ timelineSetSelection timelineWin selection'+ eventsViewSetCursor eventsView cursorPos' mrange+ histogramViewSetInterval histogramView (Just (start, end))+ continueWith eventlogState {+ selection = selection',+ cursorPos = cursorPos'+ }+ dispatch (EventTracesChanged traces) _ = do timelineWindowSetTraces timelineWin traces continue - dispatch EventBookmarkAdd EventlogLoaded{cursorTs} = do- bookmarkViewAdd bookmarkView cursorTs ""+ dispatch EventBookmarkAdd EventlogLoaded{selection} = do+ case selection of+ PointSelection a -> bookmarkViewAdd bookmarkView a ""+ RangeSelection a b -> do bookmarkViewAdd bookmarkView a ""+ bookmarkViewAdd bookmarkView b "" --TODO: should have a way to add/set a single bookmark for the timeline -- rather than this hack where we ask the bookmark view for the whole lot. ts <- bookmarkViewGet bookmarkView@@ -366,6 +418,11 @@ ConcurrencyControl.fullSpeed concCtl $ ProgressView.withProgress mainWin $ \progress -> do (hecs, name, nevents, timespan) <- registerEvents progress+ -- This is a desperate hack to avoid the "segfault on reload" bug+ -- http://trac.haskell.org/ThreadScope/ticket/1+ -- It should be enough to let other threads finish and so avoid+ -- re-entering gtk C code (see ticket for the dirty details)+ threadDelay 100000 -- 1/10th of a second post (EventSetState hecs mfilename name nevents timespan) return () @@ -408,4 +465,3 @@ -- Wait for child event loop to terminate -- This lets us wait for any exceptions. either throwIO return =<< takeMVar doneVar-
GUI/MainWindow.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP #-}--- ThreadScope: a graphical viewer for Haskell event log information.--- Maintainer: satnams@microsoft.com, s.singh@ieee.org- module GUI.MainWindow ( MainWindow, mainWindowNew,@@ -18,8 +14,7 @@ -- Imports for GTK import Graphics.UI.Gtk as Gtk-import Graphics.UI.Gtk.Gdk.Events as Old hiding (eventModifier)-import System.Glib.GObject as Glib+import qualified System.Glib.GObject as Glib -------------------------------------------------------------------------------@@ -54,10 +49,11 @@ mainWinViewEvents :: Bool -> IO (), mainWinViewBW :: Bool -> IO (), mainWinViewReload :: IO (),+ mainWinWebsite :: IO (),+ mainWinTutorial :: IO (), mainWinAbout :: IO (), -- Toolbar actions- --TODO: all toolbar actions should also be available from the menu mainWinJumpStart :: IO (), mainWinJumpEnd :: IO (), mainWinJumpCursor :: IO (),@@ -110,39 +106,47 @@ eventsBox <- getWidget castToWidget "eventsbox" bwToggle <- getWidget castToCheckMenuItem "black_and_white"+-- TODO: tie in the button and the menu toggle and then re-enable:+ labModeToggle <- getWidget castToCheckMenuItem "view_labels_mode" sidebarToggle <- getWidget castToCheckMenuItem "view_sidebar" eventsToggle <- getWidget castToCheckMenuItem "view_events" openMenuItem <- getWidget castToMenuItem "openMenuItem" exportMenuItem <- getWidget castToMenuItem "exportMenuItem" reloadMenuItem <- getWidget castToMenuItem "view_reload" quitMenuItem <- getWidget castToMenuItem "quitMenuItem"+ websiteMenuItem <- getWidget castToMenuItem "websiteMenuItem"+ tutorialMenuItem <- getWidget castToMenuItem "tutorialMenuItem" aboutMenuItem <- getWidget castToMenuItem "aboutMenuItem" - timelineViewport <- getWidget castToWidget "timeline_viewport"--- timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea"--- timelineLabelDrawingArea <- getWidget castToDrawingArea "timeline_labels_drawingarea"--- timelineHScrollbar <- getWidget castToHScrollbar "timeline_hscroll"--- timelineVScrollbar <- getWidget castToVScrollbar "timeline_vscroll"--- timelineAdj <- rangeGetAdjustment timelineHScrollbar--- timelineVAdj <- rangeGetAdjustment timelineVScrollbar+ firstMenuItem <- getWidget castToMenuItem "move_first"+ centreMenuItem <- getWidget castToMenuItem "move_centre"+ lastMenuItem <- getWidget castToMenuItem "move_last" - zoomInButton <- getWidget castToToolButton "cpus_zoomin"- zoomOutButton <- getWidget castToToolButton "cpus_zoomout"- zoomFitButton <- getWidget castToToolButton "cpus_zoomfit"+ zoomInMenuItem <- getWidget castToMenuItem "move_zoomin"+ zoomOutMenuItem <- getWidget castToMenuItem "move_zoomout"+ zoomFitMenuItem <- getWidget castToMenuItem "move_zoomfit" - showLabelsToggle <- getWidget castToToggleToolButton "cpus_showlabels"+ openButton <- getWidget castToToolButton "cpus_open"+ firstButton <- getWidget castToToolButton "cpus_first"- lastButton <- getWidget castToToolButton "cpus_last" centreButton <- getWidget castToToolButton "cpus_centre"+ lastButton <- getWidget castToToolButton "cpus_last" - --TODO: these two are currently unbound, but they should be!- -- eventsTextEntry <- getWidget castToEntry "events_entry"- -- eventsFindButton <- getWidget castToToolButton "events_find"+ zoomInButton <- getWidget castToToolButton "cpus_zoomin"+ zoomOutButton <- getWidget castToToolButton "cpus_zoomout"+ zoomFitButton <- getWidget castToToolButton "cpus_zoomfit" + --TODO: this is currently not used, but it'be nice if it were!+ eventsTextEntry <- getWidget castToEntry "events_entry"+ ------------------------------------------------------------------------+ -- Show everything+ widgetShowAll mainWindow - widgetSetAppPaintable mainWindow True --TODO: Really?+ widgetHide eventsTextEntry -- for now we hide it, see above. + ------------------------------------------------------------------------+ logoPath <- getDataFileName "threadscope.png" windowSetIconFromFile mainWindow logoPath @@ -154,7 +158,7 @@ ------------------------------------------------------------------------ -- Bind all the events- + -- Menus on openMenuItem menuItemActivate $ mainWinOpen actions on exportMenuItem menuItemActivate $ mainWinExport actions@@ -163,39 +167,36 @@ on mainWindow objectDestroy $ mainWinQuit actions on sidebarToggle checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle- >>= mainWinViewSidebar actions+ >>= mainWinViewSidebar actions on eventsToggle checkMenuItemToggled $ checkMenuItemGetActive eventsToggle- >>= mainWinViewEvents actions+ >>= mainWinViewEvents actions on bwToggle checkMenuItemToggled $ checkMenuItemGetActive bwToggle- >>= mainWinViewBW actions+ >>= mainWinViewBW actions+ on labModeToggle checkMenuItemToggled $ checkMenuItemGetActive labModeToggle+ >>= mainWinDisplayLabels actions on reloadMenuItem menuItemActivate $ mainWinViewReload actions - on aboutMenuItem menuItemActivate $ mainWinAbout actions+ on websiteMenuItem menuItemActivate $ mainWinWebsite actions+ on tutorialMenuItem menuItemActivate $ mainWinTutorial actions+ on aboutMenuItem menuItemActivate $ mainWinAbout actions - -- Toolbar + on firstMenuItem menuItemActivate $ mainWinJumpStart actions+ on centreMenuItem menuItemActivate $ mainWinJumpCursor actions+ on lastMenuItem menuItemActivate $ mainWinJumpEnd actions++ on zoomInMenuItem menuItemActivate $ mainWinJumpZoomIn actions+ on zoomOutMenuItem menuItemActivate $ mainWinJumpZoomOut actions+ on zoomFitMenuItem menuItemActivate $ mainWinJumpZoomFit actions++ -- Toolbar+ onToolButtonClicked openButton $ mainWinOpen actions+ onToolButtonClicked firstButton $ mainWinJumpStart actions- onToolButtonClicked lastButton $ mainWinJumpEnd actions onToolButtonClicked centreButton $ mainWinJumpCursor actions+ onToolButtonClicked lastButton $ mainWinJumpEnd actions onToolButtonClicked zoomInButton $ mainWinJumpZoomIn actions onToolButtonClicked zoomOutButton $ mainWinJumpZoomOut actions onToolButtonClicked zoomFitButton $ mainWinJumpZoomFit actions- - onToolButtonToggled showLabelsToggle $- toggleToolButtonGetActive showLabelsToggle >>= mainWinDisplayLabels actions-- -- Key bindings- --TODO: move these to the timeline module- onKeyPress timelineViewport $ \Key { Old.eventKeyName = key, eventKeyChar = mch } ->- case (key, mch) of- ("Right", _) -> mainWinScrollRight actions >> return True- ("Left", _) -> mainWinScrollLeft actions >> return True- (_ , Just '+') -> mainWinJumpZoomIn actions >> return True- (_ , Just '-') -> mainWinJumpZoomOut actions >> return True- _ -> return False-- ------------------------------------------------------------------------- -- Show all windows- widgetShowAll mainWindow return MainWindow {..}
GUI/ProgressView.hs view
@@ -9,9 +9,9 @@ startPulse, ) where -import Graphics.UI.Gtk as Gtk hiding (eventKeyName)-import Graphics.UI.Gtk.Gdk.Events+import Graphics.UI.Gtk as Gtk import GUI.GtkExtras+import Graphics.Rendering.Cairo import qualified Control.Concurrent as Concurrent import Control.Exception@@ -100,10 +100,11 @@ cancel <- buttonNewFromStock stockCancel onClicked cancel (widgetDestroy win >> cancelAction) onDelete win (\_ -> cancelAction >> return True)- onKeyPress win $ \key ->- if eventKeyName key == "Escape"- then cancelAction >> return True- else return False+ on win keyPressEvent $ do+ keyVal <- eventKeyVal+ case keyVal of+ 0xff1b -> liftIO $ cancelAction >> return True+ _ -> return False vbox <- vBoxNew False 20 hbox <- hBoxNew False 0
GUI/SaveAs.hs view
@@ -1,7 +1,9 @@ module GUI.SaveAs (saveAsPDF, saveAsPNG) where -- Imports for ThreadScope-import GUI.Timeline.Render (renderTraces)+import GUI.Timeline.Render (renderTraces, renderYScaleArea)+import GUI.Timeline.Render.Constants+import GUI.Timeline.Ticks (renderXScaleArea) import GUI.Types import Events.HECs @@ -9,31 +11,52 @@ import Graphics.UI.Gtk import Graphics.Rendering.Cairo ----------------------------------------------------------------------------------saveAsPDF :: FilePath -> HECs -> ViewParameters -> IO ()-saveAsPDF file hecs viewParams =-- withPDFSurface file w' h' $ \surface ->- renderWith surface $- renderTraces viewParams hecs (Rectangle 0 0 w h)-- where- w = width viewParams; w' = fromIntegral w- h = height viewParams; h' = fromIntegral h-----------------------------------------------------------------------------------saveAsPNG :: FilePath -> HECs -> ViewParameters -> IO ()-saveAsPNG file hecs viewParams =-- withImageSurface FormatARGB32 w' h' $ \surface -> do- renderWith surface $- renderTraces viewParams hecs (Rectangle 0 0 w h)- surfaceWriteToPNG surface file+saveAs :: HECs -> ViewParameters -> Double -> DrawingArea+ -> (Int, Int, Render ())+saveAs hecs params' @ViewParameters{xScaleAreaHeight, width,+ height = oldHeight, histogramHeight}+ yScaleAreaWidth yScaleArea =+ let histTotalHeight = histogramHeight + histXScaleHeight+ params@ViewParameters{height} =+ params'{ viewTraces = viewTraces params' ++ [TraceHistogram]+ , height = oldHeight + histTotalHeight + tracePad+ }+ w = ceiling yScaleAreaWidth + width+ h = xScaleAreaHeight + height+ drawTraces = renderTraces params hecs (Rectangle 0 0 width height)+ drawXScale = renderXScaleArea params hecs+ drawYScale = renderYScaleArea params hecs yScaleArea+ -- Functions renderTraces and renderXScaleArea draw to the left of 0+ -- which is not seen in the normal mode, but would be seen in export,+ -- so it has to be cleared before renderYScaleArea is written on top:+ clearLeftArea = do+ rectangle 0 0 yScaleAreaWidth (fromIntegral h)+ op <- getOperator+ setOperator OperatorClear+ fill+ setOperator op+ drawAll = do+ translate yScaleAreaWidth (fromIntegral xScaleAreaHeight)+ drawTraces+ translate 0 (- fromIntegral xScaleAreaHeight)+ drawXScale+ translate (-yScaleAreaWidth) 0+ clearLeftArea+ translate 0 (fromIntegral xScaleAreaHeight)+ drawYScale+ in (w, h, drawAll) - where- w = width viewParams; w' = fromIntegral w- h = height viewParams; h' = fromIntegral h+saveAsPDF :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()+saveAsPDF filename hecs params yScaleArea = do+ (xoffset, _) <- liftIO $ widgetGetSize yScaleArea+ let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea+ withPDFSurface filename (fromIntegral w') (fromIntegral h') $ \surface ->+ renderWith surface drawAll --------------------------------------------------------------------------------+saveAsPNG :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()+saveAsPNG filename hecs params yScaleArea = do+ (xoffset, _) <- liftIO $ widgetGetSize yScaleArea+ let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea+ withImageSurface FormatARGB32 w' h' $ \surface -> do+ renderWith surface drawAll+ surfaceWriteToPNG surface filename
+ GUI/StartupInfoView.hs view
@@ -0,0 +1,145 @@+module GUI.StartupInfoView (+ StartupInfoView,+ startupInfoViewNew,+ startupInfoViewSetEvents,+ ) where++import GHC.RTS.Events++import Graphics.UI.Gtk++import Data.Array+import Data.List+import Data.Maybe+import Data.Time+import Data.Time.Clock.POSIX++-------------------------------------------------------------------------------++data StartupInfoView = StartupInfoView+ { labelProgName :: Label+ , storeProgArgs :: ListStore String+ , storeProgEnv :: ListStore (String, String)+ , labelProgStartTime :: Label+ , labelProgRtsId :: Label+ }++data StartupInfoState+ = StartupInfoEmpty+ | StartupInfoLoaded+ { progName :: Maybe String+ , progArgs :: Maybe [String]+ , progEnv :: Maybe [(String, String)]+ , progStartTime :: Maybe UTCTime+ , progRtsId :: Maybe String+ }++-------------------------------------------------------------------------------++startupInfoViewNew :: Builder -> IO StartupInfoView+startupInfoViewNew builder = do++ let getWidget cast = builderGetObject builder cast++ labelProgName <- getWidget castToLabel "labelProgName"+ treeviewProgArgs <- getWidget castToTreeView "treeviewProgArguments"+ treeviewProgEnv <- getWidget castToTreeView "treeviewProgEnvironment"+ labelProgStartTime <- getWidget castToLabel "labelProgStartTime"+ labelProgRtsId <- getWidget castToLabel "labelProgRtsIdentifier"++ storeProgArgs <- listStoreNew []+ columnArgs <- treeViewColumnNew+ cellArgs <- cellRendererTextNew++ treeViewColumnPackStart columnArgs cellArgs True+ treeViewAppendColumn treeviewProgArgs columnArgs++ treeViewSetModel treeviewProgArgs storeProgArgs++ set cellArgs [ cellTextEditable := True ]+ cellLayoutSetAttributes columnArgs cellArgs storeProgArgs $ \arg ->+ [ cellText := arg ]++ storeProgEnv <- listStoreNew []+ columnVar <- treeViewColumnNew+ cellVar <- cellRendererTextNew+ columnValue <- treeViewColumnNew+ cellValue <- cellRendererTextNew++ treeViewColumnPackStart columnVar cellVar False+ treeViewColumnPackStart columnValue cellValue True+ treeViewAppendColumn treeviewProgEnv columnVar+ treeViewAppendColumn treeviewProgEnv columnValue++ treeViewSetModel treeviewProgEnv storeProgEnv++ cellLayoutSetAttributes columnVar cellVar storeProgEnv $ \(var,_) ->+ [ cellText := var ]++ set cellValue [ cellTextEditable := True ]+ cellLayoutSetAttributes columnValue cellValue storeProgEnv $ \(_,value) ->+ [ cellText := value ]++ let startupInfoView = StartupInfoView{..}++ return startupInfoView++-------------------------------------------------------------------------------++startupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int CapEvent) -> 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 = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing)+ . take 1000+ . elems+ where+ accum info (CapEvent _ (Event _ (ProgramArgs _ (name:args)))) =+ info {+ progName = Just name,+ progArgs = Just args+ }++ accum info (CapEvent _ (Event _ (ProgramEnv _ env))) =+ info { progEnv = Just (sort (parseEnv env)) }++ accum info (CapEvent _ (Event _ (RtsIdentifier _ rtsid))) =+ info { progRtsId = Just rtsid }++ accum info (CapEvent _ (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.+ let wallTimePosix :: NominalDiffTime+ wallTimePosix = fromIntegral sec+ + (fromIntegral nsec / nanoseconds)+ - (fromIntegral timestamp / nanoseconds)+ nanoseconds = 1000000000+ wallTimeUTC = posixSecondsToUTCTime wallTimePosix+ in info { progStartTime = Just wallTimeUTC }++ accum info _ = info++ -- convert ["foo=bar", ...] to [("foo", "bar"), ...]+ parseEnv env = [ (var, value) | (var, '=':value) <- map (span (/='=')) env ]++updateStartupInfo :: StartupInfoView -> StartupInfoState -> IO ()+updateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do+ set labelProgName [ labelText := fromMaybe "(unknown)" progName ]+ set labelProgStartTime [ labelText := maybe "(unknown)" show progStartTime ]+ set labelProgRtsId [ labelText := fromMaybe "(unknown)" progRtsId ]+ listStoreClear storeProgArgs+ mapM_ (listStoreAppend storeProgArgs) (fromMaybe [] progArgs)+ listStoreClear storeProgEnv+ mapM_ (listStoreAppend storeProgEnv) (fromMaybe [] progEnv)++updateStartupInfo StartupInfoView{..} StartupInfoEmpty = do+ set labelProgName [ labelText := "" ]+ set labelProgStartTime [ labelText := "" ]+ set labelProgRtsId [ labelText := "" ]+ listStoreClear storeProgArgs+ listStoreClear storeProgEnv
+ GUI/SummaryView.hs view
@@ -0,0 +1,80 @@+module GUI.SummaryView (+ InfoView,+ summaryViewNew,+ summaryViewSetEvents,+ ) where++import GHC.RTS.Events++import GUI.Timeline.Render.Constants++import Graphics.UI.Gtk+import Graphics.Rendering.Cairo++import Data.Array+import Data.IORef++-------------------------------------------------------------------------------++data InfoView = InfoView+ { gtkLayout :: !Layout+ , stateRef :: !(IORef InfoState)+ }++data InfoState+ = InfoEmpty+ | InfoLoaded+ { infoState :: String+ }++-------------------------------------------------------------------------------++infoViewNew :: String -> Builder -> IO InfoView+infoViewNew widgetName builder = do++ stateRef <- newIORef undefined+ let getWidget cast = builderGetObject builder cast+ gtkLayout <- getWidget castToLayout widgetName+ writeIORef stateRef InfoEmpty+ let infoView = InfoView{..}++ -- Drawing+ on gtkLayout exposeEvent $ liftIO $ do+ drawInfo infoView =<< readIORef stateRef+ return True++ return infoView++summaryViewNew :: Builder -> IO InfoView+summaryViewNew = infoViewNew "eventsLayoutSummary"++-------------------------------------------------------------------------------++infoViewSetEvents :: (Array Int CapEvent -> InfoState)+ -> InfoView -> Maybe (Array Int CapEvent) -> IO ()+infoViewSetEvents f InfoView{gtkLayout, stateRef} mevents = do+ let infoState = case mevents of+ Nothing -> InfoEmpty+ Just events -> f events+ writeIORef stateRef infoState+ widgetQueueDraw gtkLayout++summaryViewProcessEvents :: Array Int CapEvent -> InfoState+summaryViewProcessEvents _events = InfoLoaded "TODO"++summaryViewSetEvents :: InfoView -> Maybe (Array Int CapEvent) -> IO ()+summaryViewSetEvents = infoViewSetEvents summaryViewProcessEvents++-------------------------------------------------------------------------------++drawInfo :: InfoView -> InfoState -> IO ()+drawInfo _ InfoEmpty = return ()+drawInfo InfoView{gtkLayout} InfoLoaded{..} = do+ win <- layoutGetDrawWindow gtkLayout+ pangoCtx <- widgetGetPangoContext gtkLayout+ layout <- layoutText pangoCtx infoState+ (_, Rectangle _ _ width height) <- layoutGetPixelExtents layout+ layoutSetSize gtkLayout (width + 30) (height + 30)+ renderWithDrawable win $ do+ moveTo (fromIntegral ox / 2) (fromIntegral ox / 3)+ showLayout layout
GUI/Timeline.hs view
@@ -1,15 +1,18 @@+{-# LANGUAGE CPP #-} module GUI.Timeline ( TimelineView, timelineViewNew, TimelineViewActions(..), timelineSetBWMode,- timelineSetShowLabels,+ timelineSetLabelsMode, timelineGetViewParameters,+ timelineGetYScaleArea, timelineWindowSetHECs, timelineWindowSetTraces, timelineWindowSetBookmarks,- timelineSetCursor,+ timelineSetSelection,+ TimeSelection(..), timelineZoomIn, timelineZoomOut,@@ -21,17 +24,17 @@ timelineCentreOnCursor, ) where -import GUI.Timeline.Types (TimelineState(..))+import GUI.Types+import GUI.Timeline.Types+ import GUI.Timeline.Motion import GUI.Timeline.Render+import GUI.Timeline.Render.Constants -import GUI.Types import Events.HECs import Graphics.UI.Gtk-import Graphics.UI.Gtk.Gdk.Events as Old hiding (eventModifier)-import Graphics.UI.Gtk.Gdk.EventM as New-import Graphics.Rendering.Cairo as C+import Graphics.Rendering.Cairo import Data.IORef import Control.Monad@@ -47,32 +50,36 @@ tracesIORef :: IORef [Trace], bookmarkIORef :: IORef [Timestamp], - cursorIORef :: IORef Timestamp,- showLabelsIORef :: IORef Bool,- bwmodeIORef :: IORef Bool+ selectionRef :: IORef TimeSelection,+ labelsModeIORef :: IORef Bool,+ bwmodeIORef :: IORef Bool,++ cursorIBeam :: Cursor,+ cursorMove :: Cursor } data TimelineViewActions = TimelineViewActions {- timelineViewCursorChanged :: Timestamp -> IO ()+ timelineViewSelectionChanged :: TimeSelection -> IO () } -- | Draw some parts of the timeline in black and white rather than colour.--- timelineSetBWMode :: TimelineView -> Bool -> IO () timelineSetBWMode timelineWin bwmode = do writeIORef (bwmodeIORef timelineWin) bwmode widgetQueueDraw (timelineDrawingArea (timelineState timelineWin)) -timelineSetShowLabels :: TimelineView -> Bool -> IO ()-timelineSetShowLabels timelineWin showLabels = do- writeIORef (showLabelsIORef timelineWin) showLabels+timelineSetLabelsMode :: TimelineView -> Bool -> IO ()+timelineSetLabelsMode timelineWin labelsMode = do+ writeIORef (labelsModeIORef timelineWin) labelsMode widgetQueueDraw (timelineDrawingArea (timelineState timelineWin)) timelineGetViewParameters :: TimelineView -> IO ViewParameters-timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, showLabelsIORef, timelineState=TimelineState{..}} = do+timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef,+ timelineState=TimelineState{..}} = do - (dAreaWidth,_) <- widgetGetSize timelineDrawingArea- scaleValue <- readIORef scaleIORef+ (w, _) <- widgetGetSize timelineDrawingArea+ scaleValue <- readIORef scaleIORef+ maxSpkValue <- readIORef maxSpkIORef -- snap the view to whole pixels, to avoid blurring hadj_value0 <- adjustmentGetValue timelineAdj@@ -80,27 +87,35 @@ traces <- readIORef tracesIORef bwmode <- readIORef bwmodeIORef- showLabels <- readIORef showLabelsIORef+ labelsMode <- readIORef labelsModeIORef - let timelineHeight = calculateTotalTimelineHeight showLabels traces+ (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea+ let histTotalHeight = stdHistogramHeight + histXScaleHeight+ timelineHeight =+ calculateTotalTimelineHeight labelsMode histTotalHeight traces - return ViewParameters {- width = dAreaWidth,- height = timelineHeight,- viewTraces = traces,- hadjValue = hadj_value,- scaleValue = scaleValue,- detail = 3, --for now- bwMode = bwmode,- labelsMode = showLabels- }+ return ViewParameters+ { width = w+ , height = timelineHeight+ , viewTraces = traces+ , hadjValue = hadj_value+ , scaleValue = scaleValue+ , maxSpkValue = maxSpkValue+ , detail = 3 --for now+ , bwMode = bwmode+ , labelsMode = labelsMode+ , histogramHeight = stdHistogramHeight+ , minterval = Nothing+ , xScaleAreaHeight = xScaleAreaHeight+ } +timelineGetYScaleArea :: TimelineView -> DrawingArea+timelineGetYScaleArea timelineWin =+ timelineYScaleArea $ timelineState timelineWin timelineWindowSetHECs :: TimelineView -> Maybe HECs -> IO () timelineWindowSetHECs timelineWin@TimelineView{..} mhecs = do writeIORef hecsIORef mhecs- writeIORef (scaleIORef timelineState) defaultScaleValue- -- FIXME: this defaultScaleValue = -1 stuff is a terrible hack zoomToFit timelineState mhecs timelineParamsChanged timelineWin @@ -117,75 +132,148 @@ ----------------------------------------------------------------------------- timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView-timelineViewNew builder TimelineViewActions{..} = do+timelineViewNew builder actions@TimelineViewActions{..} = do let getWidget cast = builderGetObject builder cast- timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea"- timelineLabelDrawingArea <- getWidget castToDrawingArea "timeline_labels_drawingarea"- timelineHScrollbar <- getWidget castToHScrollbar "timeline_hscroll"- timelineVScrollbar <- getWidget castToVScrollbar "timeline_vscroll"- timelineAdj <- rangeGetAdjustment timelineHScrollbar- timelineVAdj <- rangeGetAdjustment timelineVScrollbar+ timelineViewport <- getWidget castToWidget "timeline_viewport"+ timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea"+ timelineYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area"+ timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area"+ timelineHScrollbar <- getWidget castToHScrollbar "timeline_hscroll"+ timelineVScrollbar <- getWidget castToVScrollbar "timeline_vscroll"+ timelineAdj <- rangeGetAdjustment timelineHScrollbar+ timelineVAdj <- rangeGetAdjustment timelineVScrollbar + -- HACK: layoutSetAttributes does not work for \mu, so let's work around+ fd <- fontDescriptionNew+ fontDescriptionSetSize fd 8+ fontDescriptionSetFamily fd "sans serif"+ widgetModifyFont timelineYScaleArea (Just fd)++ cursorIBeam <- cursorNew Xterm+ cursorMove <- cursorNew Fleur+ hecsIORef <- newIORef Nothing tracesIORef <- newIORef [] bookmarkIORef <- newIORef []- scaleIORef <- newIORef defaultScaleValue- cursorIORef <- newIORef 0+ scaleIORef <- newIORef 0+ maxSpkIORef <- newIORef 0+ selectionRef <- newIORef (PointSelection 0) bwmodeIORef <- newIORef False- showLabelsIORef <- newIORef False+ labelsModeIORef <- newIORef False timelinePrevView <- newIORef Nothing let timelineState = TimelineState{..} timelineWin = TimelineView{..} ------------------------------------------------------------------------- -- Porgram the callback for the capability drawingArea- timelineLabelDrawingArea `onExpose` \_ -> do- traces <- readIORef tracesIORef- showLabels <- readIORef showLabelsIORef- updateLabelDrawingArea timelineState showLabels traces- return True+ -- Redrawing labelDrawingArea+ timelineYScaleArea `onExpose` \_ -> do+ maybeEventArray <- readIORef hecsIORef + -- Check to see if an event trace has been loaded+ case maybeEventArray of+ Nothing -> return False+ Just hecs -> do+ traces <- readIORef tracesIORef+ labelsMode <- readIORef labelsModeIORef+ let maxP = maxSparkPool hecs+ maxH = fromIntegral (maxYHistogram hecs)+ updateYScaleArea timelineState maxP maxH Nothing labelsMode traces+ return True+ ------------------------------------------------------------------------+ -- Redrawing XScaleArea+ timelineXScaleArea `onExpose` \_ -> do+ maybeEventArray <- readIORef hecsIORef++ -- Check to see if an event trace has been loaded+ case maybeEventArray of+ Nothing -> return False+ Just hecs -> do+ let lastTx = hecLastEventTime hecs+ updateXScaleArea timelineState lastTx+ return True++ ------------------------------------------------------------------------ -- Allow mouse wheel to be used for zoom in/out- on timelineDrawingArea scrollEvent $ tryEvent $ do+ on timelineViewport scrollEvent $ tryEvent $ do dir <- eventScrollDirection mods <- eventModifier- liftIO $ do- cursor <- readIORef cursorIORef- case (dir,mods) of- (ScrollUp, [Control]) -> zoomIn timelineState cursor- (ScrollDown, [Control]) -> zoomOut timelineState cursor+ (x, _y) <- eventCoordinates+ x_ts <- liftIO $ viewPointToTime timelineWin x+ liftIO $ case (dir,mods) of+ (ScrollUp, [Control]) -> zoomIn timelineState x_ts+ (ScrollDown, [Control]) -> zoomOut timelineState x_ts (ScrollUp, []) -> vscrollUp timelineState (ScrollDown, []) -> vscrollDown timelineState _ -> return () ------------------------------------------------------------------------- -- Mouse button+ -- Mouse button and selection - onButtonPress timelineDrawingArea $ \button -> do- case button of- Button{ Old.eventButton = LeftButton, Old.eventClick = SingleClick,- -- eventModifier = [], -- contains [Alt2] for me- eventX = x } -> do- hadjValue <- adjustmentGetValue timelineAdj- scaleValue <- readIORef scaleIORef- let cursor = round (hadjValue + x * scaleValue)- widgetGrabFocus timelineDrawingArea- timelineViewCursorChanged cursor+ widgetSetCursor timelineDrawingArea (Just cursorIBeam) - return True- _other -> do- return False+ mouseStateVar <- newIORef None + let withMouseState action = liftIO $ do+ st <- readIORef mouseStateVar+ st' <- action st+ writeIORef mouseStateVar st'++ on timelineDrawingArea buttonPressEvent $ do+ (x,_y) <- eventCoordinates+ button <- eventButton+ liftIO $ widgetGrabFocus timelineViewport+ withMouseState (\st -> mousePress timelineWin actions st button x)+ return False++ on timelineDrawingArea buttonReleaseEvent $ do+ (x,_y) <- eventCoordinates+ button <- eventButton+ withMouseState (\st -> mouseRelease timelineWin actions st button x)+ return False++ widgetAddEvents timelineDrawingArea [Button1MotionMask, Button2MotionMask]+ on timelineDrawingArea motionNotifyEvent $ do+ (x, _y) <- eventCoordinates+ withMouseState (\st -> mouseMove timelineWin st x)+ return False++ on timelineDrawingArea grabBrokenEvent $ do+ withMouseState (mouseMoveCancel timelineWin actions)+ return False++ -- Escape key to cancel selection or drag+ on timelineViewport keyPressEvent $ do+ let liftNoMouse a =+ let whenNoMouse None = a >> return None+ whenNoMouse st = return st+ in withMouseState whenNoMouse >> return True+ keyName <- eventKeyName+ keyVal <- eventKeyVal+ case (keyName, keyToChar keyVal, keyVal) of+ ("Right", _, _) -> liftNoMouse $ scrollRight timelineState+ ("Left", _, _) -> liftNoMouse $ scrollLeft timelineState+ (_ , Just '+', _) -> liftNoMouse $ timelineZoomIn timelineWin+ (_ , Just '-', _) -> liftNoMouse $ timelineZoomOut timelineWin+ (_, _, 0xff1b) -> withMouseState (mouseMoveCancel timelineWin actions)+ >> return True+ _ -> return False++ ------------------------------------------------------------------------+ -- Scroll bars+ onValueChanged timelineAdj $ queueRedrawTimelines timelineState onValueChanged timelineVAdj $ queueRedrawTimelines timelineState onAdjChanged timelineAdj $ queueRedrawTimelines timelineState onAdjChanged timelineVAdj $ queueRedrawTimelines timelineState + ------------------------------------------------------------------------+ -- Redrawing+ on timelineDrawingArea exposeEvent $ do- exposeRegion <- New.eventRegion+ exposeRegion <- eventRegion liftIO $ do maybeEventArray <- readIORef hecsIORef @@ -197,12 +285,12 @@ -- render either the whole height of the timeline, or the window, whichever -- is larger (this just ensure we fill the background if the timeline is -- smaller than the window).- (_,dAreaHeight) <- widgetGetSize timelineDrawingArea- let params' = params { height = max (height params) dAreaHeight }- cursor <- readIORef cursorIORef+ (_, h) <- widgetGetSize timelineDrawingArea+ let params' = params { height = max (height params) h }+ selection <- readIORef selectionRef bookmarks <- readIORef bookmarkIORef - renderView timelineState params' hecs cursor bookmarks exposeRegion+ renderView timelineState params' hecs selection bookmarks exposeRegion return True @@ -213,13 +301,39 @@ return timelineWin -------------------------------------------------------------------------------++viewPointToTime :: TimelineView -> Double -> IO Timestamp+viewPointToTime TimelineView{timelineState=TimelineState{..}} x = do+ hadjValue <- adjustmentGetValue timelineAdj+ scaleValue <- readIORef scaleIORef+ let ts = round (max 0 (hadjValue + x * scaleValue))+ return $! ts++viewPointToTimeNoClamp :: TimelineView -> Double -> IO Double+viewPointToTimeNoClamp TimelineView{timelineState=TimelineState{..}} x = do+ hadjValue <- adjustmentGetValue timelineAdj+ scaleValue <- readIORef scaleIORef+ let ts = hadjValue + x * scaleValue+ return $! ts++viewRangeToTimeRange :: TimelineView+ -> (Double, Double) -> IO (Timestamp, Timestamp)+viewRangeToTimeRange view (x, x') = do+ let xMin = min x x'+ xMax = max x x'+ xv <- viewPointToTime view xMin+ xv' <- viewPointToTime view xMax+ return (xv, xv')++------------------------------------------------------------------------------- -- Update the internal state and the timemline view after changing which -- traces are displayed, or the order of traces. queueRedrawTimelines :: TimelineState -> IO () queueRedrawTimelines TimelineState{..} = do widgetQueueDraw timelineDrawingArea- widgetQueueDraw timelineLabelDrawingArea+ widgetQueueDraw timelineYScaleArea+ widgetQueueDraw timelineXScaleArea --FIXME: we are still unclear about which state changes involve which updates timelineParamsChanged :: TimelineView -> IO ()@@ -233,12 +347,14 @@ updateTimelineHPageSize timelineState updateTimelineVScroll :: TimelineView -> IO ()-updateTimelineVScroll TimelineView{tracesIORef, showLabelsIORef, timelineState=TimelineState{..}} = do+updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=TimelineState{..}} = do traces <- readIORef tracesIORef- showLabels <- readIORef showLabelsIORef- let h = calculateTotalTimelineHeight showLabels traces+ labelsMode <- readIORef labelsModeIORef+ let histTotalHeight = stdHistogramHeight + histXScaleHeight+ h = calculateTotalTimelineHeight labelsMode histTotalHeight traces (_,winh) <- widgetGetSize timelineDrawingArea- let winh' = fromIntegral winh; h' = fromIntegral h+ let winh' = fromIntegral winh;+ h' = fromIntegral h adjustmentSetLower timelineVAdj 0 adjustmentSetUpper timelineVAdj h' @@ -261,24 +377,108 @@ adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue) ---------------------------------------------------------------------------------- Set the cursor to a new position+-- Cursor / selection and mouse interaction -timelineSetCursor :: TimelineView -> Timestamp -> IO ()-timelineSetCursor TimelineView{..} ts = do- writeIORef cursorIORef ts+timelineSetSelection :: TimelineView -> TimeSelection -> IO ()+timelineSetSelection TimelineView{..} selection = do+ writeIORef selectionRef selection queueRedrawTimelines timelineState +-- little state machine+data MouseState = None+ | PressLeft !Double -- left mouse button is currently pressed+ -- but not over threshold for dragging+ | DragLeft !Double -- dragging with left mouse button+ | DragMiddle !Double !Double -- dragging with middle mouse button++mousePress :: TimelineView -> TimelineViewActions+ -> MouseState -> MouseButton -> Double -> IO MouseState+mousePress view@TimelineView{..} TimelineViewActions{..} state button x =+ case (state, button) of+ (None, LeftButton) -> do xv <- viewPointToTime view x+ -- update the view without notifying the client+ timelineSetSelection view (PointSelection xv)+ return (PressLeft x)+ (None, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorMove)+ v <- adjustmentGetValue timelineAdj+ return (DragMiddle x v)+ _ -> return state+ where+ TimelineState{timelineAdj, timelineDrawingArea} = timelineState+++mouseMove :: TimelineView -> MouseState+ -> Double -> IO MouseState+mouseMove view@TimelineView{..} state x =+ case state of+ None -> return None+ PressLeft x0+ | dragThreshold -> mouseMove view (DragLeft x0) x+ | otherwise -> return (PressLeft x0)+ where+ dragThreshold = abs (x - x0) > 5+ DragLeft x0 -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)+ -- update the view without notifying the client+ timelineSetSelection view (RangeSelection xv xv')+ return (DragLeft x0)+ DragMiddle x0 v -> do xv <- viewPointToTimeNoClamp view x+ xv' <- viewPointToTimeNoClamp view x0+ scrollTo timelineState (v + (xv' - xv))+ return (DragMiddle x0 v)+++mouseMoveCancel :: TimelineView -> TimelineViewActions+ -> MouseState -> IO MouseState+mouseMoveCancel view@TimelineView{..} TimelineViewActions{..} state =+ case state of+ PressLeft x0 -> do xv <- viewPointToTime view x0+ timelineViewSelectionChanged (PointSelection xv)+ return None+ DragLeft x0 -> do xv <- viewPointToTime view x0+ timelineViewSelectionChanged (PointSelection xv)+ return None+ DragMiddle _ _ -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)+ return None+ None -> return None+ where+ TimelineState{timelineDrawingArea} = timelineState++mouseRelease :: TimelineView -> TimelineViewActions+ -> MouseState -> MouseButton -> Double -> IO MouseState+mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x =+ case (state, button) of+ (PressLeft x0, LeftButton) -> do xv <- viewPointToTime view x0+ timelineViewSelectionChanged (PointSelection xv)+ return None+ (DragLeft x0, LeftButton) -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)+ timelineViewSelectionChanged (RangeSelection xv xv')+ return None+ (DragMiddle{}, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)+ return None+ _ -> return state+ where+ TimelineState{timelineDrawingArea} = timelineState+++widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO ()+widgetSetCursor widget cursor = do+#if MIN_VERSION_gtk(0,12,1)+ dw <- widgetGetDrawWindow widget+ drawWindowSetCursor dw cursor+#endif+ return ()+ ------------------------------------------------------------------------------- timelineZoomIn :: TimelineView -> IO () timelineZoomIn TimelineView{..} = do- cursor <- readIORef cursorIORef- zoomIn timelineState cursor+ selection <- readIORef selectionRef+ zoomIn timelineState (selectionPoint selection) timelineZoomOut :: TimelineView -> IO () timelineZoomOut TimelineView{..} = do- cursor <- readIORef cursorIORef- zoomOut timelineState cursor+ selection <- readIORef selectionRef+ zoomOut timelineState (selectionPoint selection) timelineZoomToFit :: TimelineView -> IO () timelineZoomToFit TimelineView{..} = do@@ -302,16 +502,11 @@ -- This one is especially evil since it relies on a shared cursor IORef timelineCentreOnCursor :: TimelineView -> IO () timelineCentreOnCursor TimelineView{..} = do- cursor <- readIORef cursorIORef- centreOnCursor timelineState cursor------------------------------------------------------------------------------------- This scale value is used to map a micro-second value to a pixel unit.--- To convert a timestamp value to a pixel value, multiply it by scale.--- To convert a pixel value to a micro-second value, divide it by scale.--- A negative value means the scale value to be computed to fit the--- trace to the display.+ selection <- readIORef selectionRef+ centreOnCursor timelineState (selectionPoint selection) -defaultScaleValue :: Double-defaultScaleValue = -1.0+selectionPoint :: TimeSelection -> Timestamp+selectionPoint (PointSelection x) = x+selectionPoint (RangeSelection x x') = midpoint x x'+ where+ midpoint a b = a + (b - a) `div` 2
GUI/Timeline/Activity.hs view
@@ -26,7 +26,7 @@ renderActivity ViewParameters{..} hecs start0 end0 = do let- slice = round (fromIntegral activity_detail * scaleValue)+ slice = ceiling (fromIntegral activity_detail * scaleValue) -- round the start time down, and the end time up, to a slice boundary start = (start0 `div` slice) * slice@@ -35,10 +35,11 @@ hec_profs = map (actProfile slice start end) (map (\ (t, _, _) -> t) (hecTrees hecs)) total_prof = map sum (transpose hec_profs)- --+ -- liftIO $ printf "%s\n" (show (map length hec_profs)) -- liftIO $ printf "%s\n" (show (map (take 20) hec_profs)) drawActivity hecs start end slice total_prof+ (if not bwMode then runningColour else black) activity_detail :: Int activity_detail = 4 -- in pixels@@ -93,7 +94,9 @@ | DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev) | DurationSplit s _ e _ _ _run _ <- t = (s, e) - duration = min (start+slice) e - max start s+ mi = min (start + slice) e+ ma = max start s+ duration = if mi < ma then 0 else mi - ma time_in_this_slice t = case t of DurationTreeLeaf ThreadRun{} -> duration@@ -103,8 +106,9 @@ DurationTreeEmpty -> error "time_in_this_slice" drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp]+ -> Color -> Render ()-drawActivity hecs start end slice ts = do+drawActivity hecs start end slice ts color = do case ts of [] -> return () t:ts -> do@@ -127,15 +131,12 @@ moveTo (dstart-dslice/2) (off t) zipWithM_ lineTo (tail [dstart-dslice/2, dstart+dslice/2 ..]) (map off ts) setSourceRGBAhex black 1.0- save- identityMatrix setLineWidth 1 strokePreserve- restore lineTo dend dheight lineTo dstart dheight- setSourceRGB 0 1 0+ setSourceRGBAhex color 1.0 fill -- funky gradients don't seem to work:@@ -163,11 +164,13 @@ fromIntegral (t * fromIntegral activityGraphHeight) / fromIntegral (fromIntegral (hecCount hecs) * slice) +-- | Draw a dashed line along the current path. dashedLine1 :: Render () dashedLine1 = do save identityMatrix- setDash [10,10] 0.0+ let dash = fromIntegral ox+ setDash [dash, dash] 0.0 setLineWidth 1 stroke restore
GUI/Timeline/HEC.hs view
@@ -1,5 +1,6 @@ module GUI.Timeline.HEC (- renderHEC+ renderHEC,+ renderInstantHEC, ) where import GUI.Timeline.Render.Constants@@ -11,8 +12,6 @@ import GUI.ViewerColours import Graphics.Rendering.Cairo-import qualified Graphics.Rendering.Cairo as C-import Graphics.UI.Gtk import qualified GHC.RTS.Events as GHC import GHC.RTS.Events hiding (Event, GCWork, GCIdle)@@ -29,8 +28,15 @@ EventTree ltime etime tree -> renderEvents params ltime etime start end tree +renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp+ -> EventTree+ -> Render ()+renderInstantHEC params@ViewParameters{..} start end+ (EventTree ltime etime tree) =+ renderEvents params ltime etime start end tree+ detailThreshold :: Double-detailThreshold = 3000+detailThreshold = 3 ------------------------------------------------------------------------------- -- hecView draws the trace for a single HEC@@ -82,7 +88,9 @@ (EventSplit splitTime lhs rhs) | startPos < splitTime && endPos >= splitTime && (fromIntegral (e - s) / scaleValue) <= fromIntegral detail- = drawTooManyEvents params s e+ -- was: = drawTooManyEvents params s e+ -- is: draw only the right hand side (let's say it overwrites LHS)+ = renderEvents params splitTime e startPos endPos rhs | otherwise = do when (startPos < splitTime) $@@ -94,39 +102,39 @@ -- An event is in view if it is not outside the view. inView :: Timestamp -> Timestamp -> EventDuration -> Bool-inView viewStart viewEnd event- = not (eStart > viewEnd || eEnd <= viewStart)- where- eStart = startTimeOf event- eEnd = endTimeOf event+inView viewStart viewEnd event =+ not (eStart > viewEnd || eEnd <= viewStart)+ where+ eStart = startTimeOf event+ eEnd = endTimeOf event ------------------------------------------------------------------------------- drawAverageDuration :: ViewParameters -> Timestamp -> Timestamp -> Timestamp -> Timestamp -> Render ()-drawAverageDuration ViewParameters{..} startTime endTime runAv gcAv- = do setSourceRGBAhex (if not bwMode then runningColour else black) 1.0- when (runAv > 0) $- draw_rectangle startTime hecBarOff -- x, y- (endTime - startTime) -- w- hecBarHeight- setSourceRGBAhex black 1.0- --move_to (oxs + startTime, 0)- --relMoveTo (4/scaleValue) 13- --unscaledText scaleValue (show nrEvents)- setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio- draw_rectangle startTime -- x- (hecBarOff+hecBarHeight) -- y- (endTime - startTime) -- w- (hecBarHeight `div` 2) -- h+drawAverageDuration ViewParameters{..} startTime endTime runAv gcAv = do+ setSourceRGBAhex (if not bwMode then runningColour else black) 1.0+ when (runAv > 0) $+ draw_rectangle startTime hecBarOff -- x, y+ (endTime - startTime) -- w+ hecBarHeight+ setSourceRGBAhex black 1.0+ --move_to (oxs + startTime, 0)+ --relMoveTo (4/scaleValue) 13+ --unscaledText scaleValue (show nrEvents)+ setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio+ draw_rectangle startTime -- x+ (hecBarOff+hecBarHeight) -- y+ (endTime - startTime) -- w+ (hecBarHeight `div` 2) -- h - where- duration = endTime - startTime+ where+ duration = endTime - startTime -- runRatio :: Double -- runRatio = (fromIntegral runAv) / (fromIntegral duration)- gcRatio :: Double- gcRatio = (fromIntegral gcAv) / (fromIntegral duration)+ gcRatio :: Double+ gcRatio = (fromIntegral gcAv) / (fromIntegral duration) ------------------------------------------------------------------------------- @@ -134,8 +142,7 @@ unscaledText text = do m <- getMatrix identityMatrix- textPath text- C.fill+ showText text setMatrix m -------------------------------------------------------------------------------@@ -151,33 +158,31 @@ ------------------------------------------------------------------------------- drawDuration :: ViewParameters -> EventDuration -> Render ()--drawDuration ViewParameters{..}- (ThreadRun t s startTime endTime)- = do setSourceRGBAhex (if not bwMode then runningColour else black) 1.0- setLineWidth (1/scaleValue)- draw_rectangle_opt False- startTime -- x- hecBarOff -- y- (endTime - startTime) -- w- hecBarHeight -- h- -- Optionally label the bar with the threadID if there is room- tExtent <- textWidth scaleValue tStr- let tw = textExtentsWidth tExtent- th = textExtentsHeight tExtent- when (tw + 6 < fromIntegral rectWidth)- $ do setSourceRGBAhex labelTextColour 1.0- move_to (fromIntegral startTime + truncate (4*scaleValue),- hecBarOff + (hecBarHeight + round th) `quot` 2)- unscaledText tStr+drawDuration ViewParameters{..} (ThreadRun t s startTime endTime) = do+ setSourceRGBAhex (if not bwMode then runningColour else black) 1.0+ setLineWidth (1/scaleValue)+ draw_rectangle_opt False+ startTime -- x+ hecBarOff -- y+ (endTime - startTime) -- w+ hecBarHeight -- h+ -- Optionally label the bar with the threadID if there is room+ tExtent <- textWidth scaleValue tStr+ let tw = textExtentsWidth tExtent+ th = textExtentsHeight tExtent+ when (tw + 6 < fromIntegral rectWidth) $ do+ setSourceRGBAhex labelTextColour 1.0+ move_to (fromIntegral startTime + truncate (4*scaleValue),+ hecBarOff + (hecBarHeight + round th) `quot` 2)+ unscaledText tStr - -- Optionally write the reason for the thread being stopped- -- depending on the zoom value- labelAt labelsMode endTime $- show t ++ " " ++ showThreadStopStatus s- where- rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels- tStr = show t+ -- Optionally write the reason for the thread being stopped+ -- depending on the zoom value+ labelAt labelsMode endTime $+ show t ++ " " ++ showThreadStopStatus s+ where+ rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels+ tStr = show t drawDuration ViewParameters{..} (GCStart startTime endTime) = gcBar (if bwMode then black else gcStartColour) startTime endTime@@ -192,13 +197,13 @@ = gcBar (if bwMode then black else gcEndColour) startTime endTime gcBar :: Color -> Timestamp -> Timestamp -> Render ()-gcBar col !startTime !endTime- = do setSourceRGBAhex col 1.0- draw_rectangle_opt False- startTime -- x- (hecBarOff+hecBarHeight) -- y- (endTime - startTime) -- w- (hecBarHeight `div` 2) -- h+gcBar col !startTime !endTime = do+ setSourceRGBAhex col 1.0+ draw_rectangle_opt False+ startTime -- x+ (hecBarOff+hecBarHeight) -- y+ (endTime - startTime) -- w+ (hecBarHeight `div` 2) -- h labelAt :: Bool -> Timestamp -> String -> Render () labelAt labelsMode t str@@ -209,19 +214,17 @@ save identityMatrix rotate (pi/4)- textPath str- C.fill+ showText str restore drawEvent :: ViewParameters -> GHC.Event -> Render () drawEvent params@ViewParameters{..} event = case spec event of CreateThread{} -> renderInstantEvent params event createThreadColour- ThreadRunnable{} -> renderInstantEvent params event threadRunnableColour RequestSeqGC{} -> renderInstantEvent params event seqGCReqColour RequestParGC{} -> renderInstantEvent params event parGCReqColour MigrateThread{} -> renderInstantEvent params event migrateThreadColour- WakeupThread{} -> renderInstantEvent params event threadRunnableColour+ WakeupThread{} -> renderInstantEvent params event threadWakeupColour Shutdown{} -> renderInstantEvent params event shutdownColour SparkCreate{} -> renderInstantEvent params event createdConvertedColour@@ -230,8 +233,10 @@ SparkRun{} -> renderInstantEvent params event createdConvertedColour SparkSteal{} -> renderInstantEvent params event createdConvertedColour SparkFizzle{} -> renderInstantEvent params event fizzledDudsColour- SparkGC{} -> renderInstantEvent params event fizzledDudsColour+ SparkGC{} -> renderInstantEvent params event gcColour + UserMessage{} -> renderInstantEvent params event userMessageColour+ RunThread{} -> return () StopThread{} -> return () StartGC{} -> return ()@@ -240,16 +245,16 @@ renderInstantEvent :: ViewParameters -> GHC.Event -> Color -> Render () renderInstantEvent ViewParameters{..} event color = do- setSourceRGBAhex color 1.0- setLineWidth (3 * scaleValue)- let t = time event- draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4)- labelAt labelsMode t $ showEventInfo (spec event)+ setSourceRGBAhex color 1.0+ setLineWidth (3 * scaleValue)+ let t = time event+ draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4)+ labelAt labelsMode t $ showEventInfo (spec event) -drawTooManyEvents :: ViewParameters -> Timestamp -> Timestamp+_drawTooManyEvents :: ViewParameters -> Timestamp -> Timestamp -> Render ()-drawTooManyEvents _params@ViewParameters{..} _start _end = do+_drawTooManyEvents _params@ViewParameters{..} _start _end = do return () -- setSourceRGBAhex grey 1.0 -- setLineWidth (3 * scaleValue)
GUI/Timeline/Motion.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE NamedFieldPuns #-} module GUI.Timeline.Motion ( zoomIn, zoomOut, zoomToFit,- scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, centreOnCursor,+ scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, scrollTo, centreOnCursor, vscrollDown, vscrollUp, ) where import GUI.Timeline.Types-import GUI.Timeline.Render.Constants+import GUI.Timeline.Sparks import Events.HECs import Graphics.UI.Gtk@@ -29,60 +28,65 @@ zoomOut :: TimelineState -> Timestamp -> IO () zoomOut = zoom (*2) -zoom :: (Double->Double) -> TimelineState -> Timestamp -> IO ()+zoom :: (Double -> Double) -> TimelineState -> Timestamp -> IO () zoom factor TimelineState{timelineAdj, scaleIORef} cursor = do- scaleValue <- readIORef scaleIORef- let clampedFactor = if factor scaleValue < 1 then- id- else- factor- let newScaleValue = clampedFactor scaleValue- writeIORef scaleIORef newScaleValue+ scaleValue <- readIORef scaleIORef+ -- TODO: we'd need HECs, as below, to fit maxScale to graphs at hand+ let maxScale = 10000000000 -- big enough for hours of eventlogs+ clampedFactor =+ if factor scaleValue < 0.2 || factor scaleValue > maxScale+ then id+ else factor+ newScaleValue = clampedFactor scaleValue+ writeIORef scaleIORef newScaleValue - hadj_value <- adjustmentGetValue timelineAdj- hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar+ hadj_value <- adjustmentGetValue timelineAdj+ hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar - let newPageSize = clampedFactor hadj_pagesize- adjustmentSetPageSize timelineAdj newPageSize+ let newPageSize = clampedFactor hadj_pagesize+ adjustmentSetPageSize timelineAdj newPageSize - let cursord = fromIntegral cursor- when (cursord >= hadj_value && cursord < hadj_value + hadj_pagesize) $- adjustmentSetValue timelineAdj $- cursord - clampedFactor (cursord - hadj_value)+ let cursord = fromIntegral cursor+ when (cursord >= hadj_value && cursord < hadj_value + hadj_pagesize) $+ adjustmentSetValue timelineAdj $+ cursord - clampedFactor (cursord - hadj_value) - let pageshift = 0.9 * newPageSize- let nudge = 0.1 * newPageSize+ let pageshift = 0.9 * newPageSize+ let nudge = 0.1 * newPageSize - adjustmentSetStepIncrement timelineAdj nudge- adjustmentSetPageIncrement timelineAdj pageshift+ adjustmentSetStepIncrement timelineAdj nudge+ adjustmentSetPageIncrement timelineAdj pageshift ------------------------------------------------------------------------------- zoomToFit :: TimelineState -> Maybe HECs -> IO ()-zoomToFit TimelineState{scaleIORef, timelineAdj, timelineDrawingArea} mb_hecs = do+zoomToFit TimelineState{scaleIORef, maxSpkIORef,timelineAdj,+ timelineDrawingArea} mb_hecs = do case mb_hecs of- Nothing -> writeIORef scaleIORef (-1.0) --FIXME: ug!+ Nothing -> return () Just hecs -> do- let lastTx = hecLastEventTime hecs- (w, _) <- widgetGetSize timelineDrawingArea- let newScaleValue = fromIntegral lastTx / fromIntegral (w - 2*ox)- -- leave a gap of ox pixels at each end- writeIORef scaleIORef newScaleValue+ let lastTx = hecLastEventTime hecs+ upper = fromIntegral lastTx+ lower = 0+ (w, _) <- widgetGetSize timelineDrawingArea+ let newScaleValue = upper / fromIntegral w+ (sliceAll, profAll) = treesProfile newScaleValue 0 lastTx hecs+ -- TODO: verify that no empty lists possible below+ maxmap l = maximum (0 : map (maxSparkRenderedValue sliceAll) l)+ maxAll = map maxmap profAll+ newMaxSpkValue = maximum (0 : maxAll) - -- Configure the horizontal scrollbar units to correspond to ns.- -- leave a gap of ox pixels on the left and right of the full trace- let gap = fromIntegral ox * newScaleValue- lower = -gap- upper = fromIntegral lastTx + gap- page = upper + gap+ writeIORef scaleIORef newScaleValue+ writeIORef maxSpkIORef newMaxSpkValue - adjustmentSetLower timelineAdj lower- adjustmentSetValue timelineAdj lower- adjustmentSetUpper timelineAdj upper- adjustmentSetPageSize timelineAdj page- -- TODO: this seems suspicious:- adjustmentSetStepIncrement timelineAdj 0- adjustmentSetPageIncrement timelineAdj 0+ -- Configure the horizontal scrollbar units to correspond to micro-secs.+ adjustmentSetLower timelineAdj lower+ adjustmentSetValue timelineAdj lower+ adjustmentSetUpper timelineAdj upper+ adjustmentSetPageSize timelineAdj upper+ -- TODO: this seems suspicious:+ adjustmentSetStepIncrement timelineAdj 0+ adjustmentSetPageIncrement timelineAdj 0 ------------------------------------------------------------------------------- @@ -93,6 +97,9 @@ scrollToBeginning = scroll (\_ _ l _ -> l) scrollToEnd = scroll (\_ _ _ u -> u) +scrollTo :: TimelineState -> Double -> IO ()+scrollTo s x = scroll (\_ _ _ _ -> x) s+ centreOnCursor :: TimelineState -> Timestamp -> IO () centreOnCursor state cursor =@@ -100,15 +107,14 @@ scroll :: (Double -> Double -> Double -> Double -> Double) -> TimelineState -> IO ()-scroll adjust TimelineState{timelineAdj}- = do hadj_value <- adjustmentGetValue timelineAdj- hadj_pagesize <- adjustmentGetPageSize timelineAdj- hadj_lower <- adjustmentGetLower timelineAdj- hadj_upper <- adjustmentGetUpper timelineAdj- let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper- newValue' = max hadj_lower (min (hadj_upper - hadj_pagesize) newValue)- adjustmentSetValue timelineAdj newValue'- adjustmentValueChanged timelineAdj+scroll adjust TimelineState{timelineAdj} = do+ hadj_value <- adjustmentGetValue timelineAdj+ hadj_pagesize <- adjustmentGetPageSize timelineAdj+ hadj_lower <- adjustmentGetLower timelineAdj+ hadj_upper <- adjustmentGetUpper timelineAdj+ let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper+ newValue' = max hadj_lower (min (hadj_upper - hadj_pagesize) newValue)+ adjustmentSetValue timelineAdj newValue' vscrollDown, vscrollUp :: TimelineState -> IO () vscrollDown = vscroll (\val page _l u -> (u - page) `min` (val + page/8))@@ -116,13 +122,13 @@ vscroll :: (Double -> Double -> Double -> Double -> Double) -> TimelineState -> IO ()-vscroll adjust TimelineState{timelineVAdj}- = do hadj_value <- adjustmentGetValue timelineVAdj- hadj_pagesize <- adjustmentGetPageSize timelineVAdj- hadj_lower <- adjustmentGetLower timelineVAdj- hadj_upper <- adjustmentGetUpper timelineVAdj- let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper- adjustmentSetValue timelineVAdj newValue- adjustmentValueChanged timelineVAdj+vscroll adjust TimelineState{timelineVAdj} = do+ hadj_value <- adjustmentGetValue timelineVAdj+ hadj_pagesize <- adjustmentGetPageSize timelineVAdj+ hadj_lower <- adjustmentGetLower timelineVAdj+ hadj_upper <- adjustmentGetUpper timelineVAdj+ let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper+ adjustmentSetValue timelineVAdj newValue+ adjustmentValueChanged timelineVAdj -- -----------------------------------------------------------------------------
GUI/Timeline/Render.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE NamedFieldPuns #-} module GUI.Timeline.Render ( renderView, renderTraces,- updateLabelDrawingArea,+ updateXScaleArea,+ renderYScaleArea,+ updateYScaleArea, calculateTotalTimelineHeight,- toWholePixels+ toWholePixels, ) where import GUI.Timeline.Types@@ -21,7 +22,6 @@ import Graphics.UI.Gtk import Graphics.Rendering.Cairo-import Graphics.UI.Gtk.Gdk.GC (GC, gcNew) --FIXME: eliminate old style drawing import Data.IORef import Control.Monad@@ -33,13 +33,13 @@ -- renderView :: TimelineState -> ViewParameters- -> HECs -> Timestamp -> [Timestamp]+ -> HECs -> TimeSelection -> [Timestamp] -> Region -> IO () renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView}- params hecs cursor_t bookmarks exposeRegion = do+ params hecs selection bookmarks exposeRegion = do -- Get state information from user-interface components- (dAreaWidth, _) <- widgetGetSize timelineDrawingArea+ (w, _) <- widgetGetSize timelineDrawingArea vadj_value <- adjustmentGetValue timelineVAdj prev_view <- readIORef timelinePrevView@@ -51,11 +51,10 @@ let renderToNewSurface = do new_surface <- withTargetSurface $ \surface ->- liftIO $ createSimilarSurface surface ContentColor- dAreaWidth (height params)+ liftIO $ createSimilarSurface surface ContentColor w (height params) renderWith new_surface $ do- clearWhite- renderTraces params hecs rect+ clearWhite+ renderTraces params hecs rect return new_surface surface <-@@ -63,28 +62,27 @@ Nothing -> renderToNewSurface Just (old_params, surface)- | old_params == params- -> return surface-- | width old_params == width params &&- height old_params == height params- -> do- if old_params { hadjValue = hadjValue params } == params- -- only the hadjValue changed- && abs (hadjValue params - hadjValue old_params) <- fromIntegral (width params) * scaleValue params- -- and the views overlap...- then do- scrollView surface old_params params hecs+ | old_params == params+ -> return surface - else do- renderWith surface $ do- clearWhite; renderTraces params hecs rect- return surface+ | width old_params == width params &&+ height old_params == height params+ -> do+ if old_params { hadjValue = hadjValue params } == params+ -- only the hadjValue changed+ && abs (hadjValue params - hadjValue old_params) <+ fromIntegral (width params) * scaleValue params+ -- and the views overlap...+ then+ scrollView surface old_params params hecs+ else do+ renderWith surface $ do+ clearWhite; renderTraces params hecs rect+ return surface - | otherwise- -> do surfaceFinish surface- renderToNewSurface+ | otherwise+ -> do surfaceFinish surface+ renderToNewSurface liftIO $ writeIORef timelinePrevView (Just (params, surface)) @@ -94,41 +92,59 @@ -- ^^ this is where we adjust for the vertical scrollbar setOperator OperatorSource paint- when (scaleValue params > 0) $ do- renderBookmarks bookmarks params- drawCursor cursor_t params+ renderBookmarks bookmarks params+ drawSelection params selection ------------------------------------------------------------------------------- -- Render the bookmarks renderBookmarks :: [Timestamp] -> ViewParameters -> Render () renderBookmarks bookmarks vp@ViewParameters{height} = do- setLineWidth 1- setSourceRGBAhex bookmarkColour 1.0- sequence_- [ do moveTo x 0- lineTo x (fromIntegral height)- stroke- | bookmark <- bookmarks- , let x = timestampToView vp bookmark ]+ setLineWidth 1+ setSourceRGBAhex bookmarkColour 1.0+ sequence_+ [ do moveTo x 0+ lineTo x (fromIntegral height)+ stroke+ | bookmark <- bookmarks+ , let x = timestampToView vp bookmark ] ------------------------------------------------------------------------------- -drawCursor :: Timestamp -> ViewParameters -> Render ()-drawCursor cursor_t vp@ViewParameters{height} = do- setLineWidth 3- setOperator OperatorOver- setSourceRGBAhex blue 1.0- let x = timestampToView vp cursor_t- moveTo x 0- lineTo x (fromIntegral height)- stroke+drawSelection :: ViewParameters -> TimeSelection -> Render ()+drawSelection vp@ViewParameters{height} (PointSelection x) = do+ setLineWidth 3+ setOperator OperatorOver+ setSourceRGBAhex blue 1.0+ moveTo xv 0+ lineTo xv (fromIntegral height)+ stroke+ where+ xv = timestampToView vp x +drawSelection vp@ViewParameters{height} (RangeSelection x x') = do+ setLineWidth 1.5+ setOperator OperatorOver++ setSourceRGBAhex blue 0.25+ rectangle xv 0 (xv' - xv) (fromIntegral height)+ fill++ setSourceRGBAhex blue 1.0+ moveTo xv 0+ lineTo xv (fromIntegral height)+ moveTo xv' 0+ lineTo xv' (fromIntegral height)+ stroke+ where+ xv = timestampToView vp x+ xv' = timestampToView vp x'+ ------------------------------------------------------------------------------- -- We currently have two different way of converting from logical units--- (ie timestamps in nanoseconds) to device units (ie pixels):--- * the first is to set the cairo context to the appropriate scale +-- (ie timestamps in micro-seconds) to device units (ie pixels):+-- * the first is to set the cairo context to the appropriate scale -- * the second is to do the conversion ourself -- -- While in principle the first is superior due to the simplicity: cairo@@ -143,11 +159,11 @@ -- withViewScale :: ViewParameters -> Render () -> Render () withViewScale ViewParameters{scaleValue, hadjValue} inner = do- save- scale (1/scaleValue) 1.0- translate (-hadjValue) 0- inner- restore+ save+ scale (1/scaleValue) 1.0+ translate (-hadjValue) 0+ inner+ restore -- | Manually convert from logical units (timestamps) to device units. --@@ -156,66 +172,66 @@ (fromIntegral ts - hadjValue) / scaleValue ---------------------------------------------------------------------------------- This function draws the current view of all the HECs with Cario+-- This function draws the current view of all the HECs with Cairo. renderTraces :: ViewParameters -> HECs -> Rectangle -> Render ()+renderTraces params@ViewParameters{..} hecs (Rectangle rx _ry rw _rh) = do+ let scale_rx = fromIntegral rx * scaleValue+ scale_rw = fromIntegral rw * scaleValue+ scale_width = fromIntegral width * scaleValue -renderTraces params@ViewParameters{..} hecs (Rectangle rx _ry rw _rh)- = do- let- scale_rx = fromIntegral rx * scaleValue- scale_rw = fromIntegral rw * scaleValue- scale_width = fromIntegral width * scaleValue+ startPos :: Timestamp+ startPos = fromIntegral $ truncate (scale_rx + hadjValue) - startPos :: Timestamp- startPos = fromIntegral (max 0 (truncate (scale_rx + hadjValue)))- -- hadj_value might be negative, as we leave a- -- small gap before the trace starts at the beginning+ endPos :: Timestamp+ endPos = minimum [+ ceiling (hadjValue + scale_width),+ ceiling (hadjValue + scale_rx + scale_rw),+ hecLastEventTime hecs+ ] - endPos :: Timestamp- endPos = minimum [- ceiling (max 0 (hadjValue + scale_width)),- ceiling (max 0 (hadjValue + scale_rx + scale_rw)),- hecLastEventTime hecs- ]+ -- For spark traces, round the start time down, and the end time up,+ -- to a slice boundary:+ start = (startPos `div` slice) * slice+ end = ((endPos + slice) `div` slice) * slice+ (slice, prof) = treesProfile scaleValue start end hecs - -- Now render the timeline drawing if we have a non-empty trace- when (scaleValue > 0) $ do- withViewScale params $ do- save- -- First render the ticks and tick times- renderTicks startPos endPos scaleValue height- restore+ withViewScale params $ do+ -- Render the vertical rulers across all the traces.+ renderVRulers scaleValue startPos endPos height XScaleTime - -- This function helps to render a single HEC...- let- renderTrace trace y = do- save- translate 0 (fromIntegral y)- case trace of- TraceHEC c ->- let (dtree, etree, _) = hecTrees hecs !! c- in renderHEC params startPos endPos (dtree, etree)- SparkCreationHEC c ->- let (_, _, stree) = hecTrees hecs !! c- maxV = maxSparkValue hecs- in renderSparkCreation params startPos endPos stree maxV- SparkConversionHEC c ->- let (_, _, stree) = hecTrees hecs !! c- maxV = maxSparkValue hecs- in renderSparkConversion params startPos endPos stree maxV- SparkPoolHEC c ->- let (_, _, stree) = hecTrees hecs !! c- maxP = maxSparkPool hecs- in renderSparkPool params startPos endPos stree maxP- TraceActivity ->- renderActivity params hecs startPos endPos- _ ->- return ()- restore- -- Now rennder all the HECs.- zipWithM_ renderTrace viewTraces (traceYPositions labelsMode viewTraces)+ -- This function helps to render a single HEC.+ -- Traces are rendered even if the y-region falls outside visible area.+ -- OTOH, trace rendering function tend to drawn only the visible+ -- x-region of the graph.+ let renderTrace trace y = do+ save+ translate 0 (fromIntegral y)+ case trace of+ TraceHEC c ->+ let (dtree, etree, _) = hecTrees hecs !! c+ in renderHEC params startPos endPos (dtree, etree)+ TraceInstantHEC c ->+ let (_, etree, _) = hecTrees hecs !! c+ in renderInstantHEC params startPos endPos etree+ TraceCreationHEC c ->+ renderSparkCreation params slice start end (prof !! c)+ TraceConversionHEC c ->+ renderSparkConversion params slice start end (prof !! c)+ TracePoolHEC c ->+ let maxP = maxSparkPool hecs+ in renderSparkPool params slice start end (prof !! c) maxP+ TraceHistogram ->+ renderSparkHistogram params hecs+ TraceGroup _ -> error "renderTrace"+ TraceActivity ->+ renderActivity params hecs startPos endPos+ restore+ histTotalHeight = histogramHeight + histXScaleHeight+ -- Now render all the HECs.+ zipWithM_ renderTrace viewTraces+ (traceYPositions labelsMode histTotalHeight viewTraces) ------------------------------------------------------------------------------- @@ -224,106 +240,191 @@ -> ViewParameters -> ViewParameters -> HECs -> Render Surface- scrollView surface old new hecs = do- -- scrolling on the same surface seems not to work, I get garbled results. -- Not sure what the best way to do this is. -- let new_surface = surface- new_surface <- withTargetSurface $ \surface ->- liftIO $ createSimilarSurface surface ContentColor- (width new) (height new)-- renderWith new_surface $ do+ new_surface <- withTargetSurface $ \surface ->+ liftIO $ createSimilarSurface surface ContentColor+ (width new) (height new) - let- scale = scaleValue new- old_hadj = hadjValue old- new_hadj = hadjValue new- w = fromIntegral (width new)- h = fromIntegral (height new)- off = (old_hadj - new_hadj) / scale+ renderWith new_surface $ do+ let scale = scaleValue new+ old_hadj = hadjValue old+ new_hadj = hadjValue new+ w = fromIntegral (width new)+ h = fromIntegral (height new)+ off = (old_hadj - new_hadj) / scale -- liftIO $ printf "scrollView: old: %f, new %f, dist = %f (%f pixels)\n" -- old_hadj new_hadj (old_hadj - new_hadj) off - -- copy the content from the old surface to the new surface,- -- shifted by the appropriate amount.- setSourceSurface surface off 0- if old_hadj > new_hadj- then do rectangle off 0 (w - off) h -- scroll right.- else do rectangle 0 0 (w + off) h -- scroll left.- fill-- let rect | old_hadj > new_hadj- = Rectangle 0 0 (ceiling off) (height new)- | otherwise- = Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new)+ -- copy the content from the old surface to the new surface,+ -- shifted by the appropriate amount.+ setSourceSurface surface off 0+ if old_hadj > new_hadj+ then rectangle off 0 (w - off) h -- scroll right.+ else rectangle 0 0 (w + off) h -- scroll left.+ fill - case rect of- Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y)- (fromIntegral w) (fromIntegral h)- setSourceRGBA 0xffff 0xffff 0xffff 0xffff- fill+ let rect | old_hadj > new_hadj+ = Rectangle 0 0 (ceiling off) (height new)+ | otherwise+ = Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new) - renderTraces new hecs rect+ case rect of+ Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y)+ (fromIntegral w) (fromIntegral h)+ setSourceRGBA 0xffff 0xffff 0xffff 0xffff+ fill - surfaceFinish surface- return new_surface+ renderTraces new hecs rect -------------------------------------------------------------------------------+ surfaceFinish surface+ return new_surface -toWholePixels :: Double -> Double -> Double-toWholePixels 0 _x = 0-toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale+-------------------------------------------------------------------------------- --------------------------------------------------------------------------------+-- | Update the X scale widget, based on the state of all timeline areas.+-- For simplicity, unlike for the traces, we redraw the whole area+-- and not only the newly exposed area. This is comparatively very cheap.+updateXScaleArea :: TimelineState -> Timestamp -> IO ()+updateXScaleArea TimelineState{..} lastTx = do+ win <- widgetGetDrawWindow timelineXScaleArea+ (width, _) <- widgetGetSize timelineDrawingArea+ (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea+ scaleValue <- readIORef scaleIORef+ -- Snap the view to whole pixels, to avoid blurring.+ hadjValue0 <- adjustmentGetValue timelineAdj+ let hadjValue = toWholePixels scaleValue hadjValue0+ off y = y + xScaleAreaHeight - 17+ renderWithDrawable win $+ renderXScale scaleValue hadjValue lastTx width off XScaleTime+ return () -updateLabelDrawingArea :: TimelineState -> Bool -> [Trace] -> IO ()-updateLabelDrawingArea TimelineState{timelineVAdj, timelineLabelDrawingArea} showLabels traces- = do win <- widgetGetDrawWindow timelineLabelDrawingArea- vadj_value <- adjustmentGetValue timelineVAdj- gc <- gcNew win- let ys = map (subtract (round vadj_value)) $- traceYPositions showLabels traces- zipWithM_ (drawLabel timelineLabelDrawingArea gc) traces ys+-------------------------------------------------------------------------------- -drawLabel :: DrawingArea -> GC -> Trace -> Int -> IO ()-drawLabel canvas gc trace y- = do win <- widgetGetDrawWindow canvas- txt <- canvas `widgetCreateLayout` (showTrace trace)- --FIXME: eliminate use of GC drawing and use cairo instead.- drawLayoutWithColors win gc 10 y txt (Just black) Nothing+-- | Render the Y scale area (an axis, ticks and a label for each graph),+-- based on view parameters and hecs.+renderYScaleArea :: ViewParameters -> HECs -> DrawingArea -> Render ()+renderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces,+ histogramHeight, minterval}+ hecs yScaleArea = do+ let maxP = maxSparkPool hecs+ maxH = fromIntegral $ maxYHistogram hecs+ (xoffset, _) <- liftIO $ widgetGetSize yScaleArea+ drawYScaleArea+ maxSpkValue maxP maxH minterval (fromIntegral xoffset) 0+ labelsMode histogramHeight viewTraces yScaleArea ---------------------------------------------------------------------------------+-- | Update the Y scale widget, based on the state of all timeline areas+-- and on traces (only for graph labels and relative positions).+updateYScaleArea :: TimelineState -> Double -> Double -> Maybe Interval+ -> Bool -> [Trace] -> IO ()+updateYScaleArea TimelineState{..} maxSparkPool maxYHistogram minterval+ labelsMode traces = do+ win <- widgetGetDrawWindow timelineYScaleArea+ maxSpkValue <- readIORef maxSpkIORef+ vadj_value <- adjustmentGetValue timelineVAdj+ (xoffset, _) <- widgetGetSize timelineYScaleArea+ renderWithDrawable win $+ drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval+ (fromIntegral xoffset) vadj_value labelsMode stdHistogramHeight traces+ timelineYScaleArea -traceYPositions :: Bool -> [Trace] -> [Int]-traceYPositions showLabels traces- = scanl (\a b -> a + (traceHeight b) + extra + tracePad) firstTraceY traces- where- extra = if showLabels then hecLabelExtra else 0+-- | Render the Y scale area, by rendering an axis, ticks and a label+-- for each graph-like trace in turn (and only labels for other traces).+drawYScaleArea :: Double -> Double -> Double -> Maybe Interval -> Double+ -> Double -> Bool -> Int -> [Trace] -> DrawingArea+ -> Render ()+drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval xoffset+ vadj_value labelsMode histogramHeight traces yScaleArea = do+ let histTotalHeight = histogramHeight + histXScaleHeight+ ys = map (subtract (round vadj_value)) $+ traceYPositions labelsMode histTotalHeight traces+ pcontext <- liftIO $ widgetCreatePangoContext yScaleArea+ zipWithM_+ (drawSingleYScale+ maxSpkValue maxSparkPool maxYHistogram minterval xoffset+ histogramHeight pcontext)+ traces ys - traceHeight (TraceHEC _) = hecTraceHeight- traceHeight (SparkCreationHEC _) = hecSparksHeight- traceHeight (SparkConversionHEC _) = hecSparksHeight- traceHeight (SparkPoolHEC _) = hecSparksHeight- traceHeight TraceActivity = activityGraphHeight- traceHeight _ = 0+-- | Render a single Y scale axis, set of ticks and label, or only a label,+-- if the trace is not a graph.+drawSingleYScale :: Double -> Double -> Double -> Maybe Interval -> Double -> Int+ -> PangoContext -> Trace -> Int+ -> Render ()+drawSingleYScale maxSpkValue maxSparkPool maxYHistogram minterval xoffset+ histogramHeight pcontext trace y = do+ setSourceRGBAhex black 1+ move_to (ox, y + 8)+ layout <- liftIO $ layoutText pcontext (showTrace minterval trace)+ liftIO $ do+ layoutSetWidth layout (Just $ xoffset - 50)+ -- Note: the following does not always work, see the HACK in Timeline.hs+ layoutSetAttributes layout [AttrSize minBound maxBound 8,+ AttrFamily minBound maxBound "sans serif"]+ showLayout layout+ case traceMaxSpark maxSpkValue maxSparkPool maxYHistogram trace of+ Just v ->+ renderYScale+ (traceHeight histogramHeight trace) 1 v (xoffset - 13) (fromIntegral y)+ Nothing -> return () -- not a graph-like trace -------------------------------------------------------------------------------- -showTrace :: Trace -> String-showTrace (TraceHEC n) = "HEC " ++ show n-showTrace (SparkCreationHEC n) = "Spark\ncreation\nrate\n(spark/ms)\nHEC " ++ show n-showTrace (SparkConversionHEC n) = "Spark\nconversion\nrate\n(spark/ms)\nHEC " ++ show n-showTrace (SparkPoolHEC n) = "Spark pool\nsize\nHEC " ++ show n-showTrace TraceActivity = "Activity"-showTrace _ = "?"+-- | Calculate Y positions of all traces.+traceYPositions :: Bool -> Int -> [Trace] -> [Int]+traceYPositions labelsMode histTotalHeight traces =+ scanl (\a b -> a + (height b) + extra + tracePad) firstTraceY traces+ where+ height b = traceHeight histTotalHeight b+ extra = if labelsMode then hecLabelExtra else 0 ---------------------------------------------------------------------------------+traceHeight :: Int -> Trace -> Int+traceHeight _ TraceHEC{} = hecTraceHeight+traceHeight _ TraceInstantHEC{} = hecInstantHeight+traceHeight _ TraceCreationHEC{} = hecSparksHeight+traceHeight _ TraceConversionHEC{} = hecSparksHeight+traceHeight _ TracePoolHEC{} = hecSparksHeight+traceHeight h TraceHistogram = h+traceHeight _ TraceGroup{} = error "traceHeight"+traceHeight _ TraceActivity = activityGraphHeight -calculateTotalTimelineHeight :: Bool -> [Trace] -> Int-calculateTotalTimelineHeight showLabels traces =- last (traceYPositions showLabels traces)+-- | Calculate the total Y span of all traces.+calculateTotalTimelineHeight :: Bool -> Int -> [Trace] -> Int+calculateTotalTimelineHeight labelsMode histTotalHeight traces =+ last (traceYPositions labelsMode histTotalHeight traces) ---------------------------------------------------------------------------------+-- | Produce a descriptive label for a trace.+showTrace :: Maybe Interval -> Trace -> String+showTrace _ (TraceHEC n) =+ "HEC " ++ show n+showTrace _ (TraceInstantHEC n) =+ "HEC " ++ show n ++ "\nInstant"+showTrace _ (TraceCreationHEC n) =+ "\nHEC " ++ show n ++ "\n\nSpark creation rate (spark/ms)"+showTrace _ (TraceConversionHEC n) =+ "\nHEC " ++ show n ++ "\n\nSpark conversion rate (spark/ms)"+showTrace _ (TracePoolHEC n) =+ "\nHEC " ++ show n ++ "\n\nSpark pool size"+showTrace Nothing TraceHistogram =+ "Sum of spark times\n(" ++ mu ++ "s)"+showTrace Just{} TraceHistogram =+ "Sum of selected spark times\n(" ++ mu ++ "s)"+showTrace _ TraceActivity =+ "Activity"+showTrace _ TraceGroup{} = error "Render.showTrace"++-- | Calcaulate the maximal Y value for a graph-like trace, or Nothing.+traceMaxSpark :: Double -> Double -> Double -> Trace -> Maybe Double+traceMaxSpark maxS _ _ TraceCreationHEC{} = Just $ maxS * 1000+traceMaxSpark maxS _ _ TraceConversionHEC{} = Just $ maxS * 1000+traceMaxSpark _ maxP _ TracePoolHEC{} = Just $ maxP+traceMaxSpark _ _ maxH TraceHistogram = Just $ maxH+traceMaxSpark _ _ _ _ = Nothing++-- | Snap a value to a whole pixel, based on drawing scale.+toWholePixels :: Double -> Double -> Double+toWholePixels 0 _ = 0+toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale
GUI/Timeline/Render/Constants.hs view
@@ -1,24 +1,22 @@ module GUI.Timeline.Render.Constants (- ox, oy, firstTraceY, tracePad,- hecTraceHeight, hecSparksHeight, hecBarOff, hecBarHeight, hecLabelExtra,- activityGraphHeight,+ ox, firstTraceY, tracePad,+ hecTraceHeight, hecInstantHeight, hecSparksHeight,+ hecBarOff, hecBarHeight, hecLabelExtra,+ activityGraphHeight, stdHistogramHeight, histXScaleHeight, ticksHeight, ticksPad ) where ------------------------------------------------------------------------------- --- Origin for graph+-- The standard gap in various graphs ox :: Int ox = 10 -oy :: Int-oy = 30---- Origin for capability bars+-- Origin for traces firstTraceY :: Int-firstTraceY = 60+firstTraceY = 13 -- Gap betweem traces in the timeline view @@ -27,12 +25,12 @@ -- HEC bar height -hecTraceHeight, hecSparksHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int+hecTraceHeight, hecInstantHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int -hecTraceHeight = 40-hecSparksHeight = activityGraphHeight-hecBarHeight = 20-hecBarOff = 10+hecTraceHeight = 40+hecInstantHeight = 25+hecBarHeight = 20+hecBarOff = 10 -- extra space to allow between HECs when labels are on. -- ToDo: should be calculated somehow@@ -42,6 +40,19 @@ activityGraphHeight :: Int activityGraphHeight = 100++-- Height of the spark graphs.+hecSparksHeight :: Int+hecSparksHeight = activityGraphHeight++-- Histogram graph height when displayed with other traces (e.g., in PNG/PDF).+stdHistogramHeight :: Int+stdHistogramHeight = hecSparksHeight++-- The X scale of histogram has this constant height, as opposed+-- to the timeline X scale, which takes its height from the .ui file.+histXScaleHeight :: Int+histXScaleHeight = 30 -- Ticks
GUI/Timeline/Sparks.hs view
@@ -1,118 +1,113 @@ module GUI.Timeline.Sparks (+ treesProfile,+ maxSparkRenderedValue, renderSparkCreation, renderSparkConversion, renderSparkPool,+ renderSparkHistogram, ) where import GUI.Timeline.Render.Constants +import Events.HECs import Events.SparkTree import qualified Events.SparkStats as SparkStats+ import GUI.Types-import GUI.Timeline.CairoDrawing import GUI.ViewerColours+import GUI.Timeline.Ticks import Graphics.Rendering.Cairo-import qualified Graphics.Rendering.Cairo as C-import Graphics.UI.Gtk -import GHC.RTS.Events hiding (Event, GCWork, GCIdle)- import Control.Monad -import Text.Printf- -- Rendering sparks. No approximation nor extrapolation is going on here. -- The sample data, recalculated for a given slice size in sparkProfile,--- is straightforwardly rendered.+-- before these functions are called, is straightforwardly rendered. --- TODO; Function sparkProfile, for a given slice size and viewport,--- is called separately by each render* function, The unused parts of the result--- won't get computed, but the drilling down the tree and allocating--- thunks is repeated for each graph, while it could be done just once,--- for a given zoom level and scroll directive.+maxSparkRenderedValue :: Timestamp -> SparkStats.SparkStats -> Double+maxSparkRenderedValue duration c =+ max (SparkStats.rateDud c ++ SparkStats.rateCreated c ++ SparkStats.rateOverflowed c)+ (SparkStats.rateFizzled c ++ SparkStats.rateConverted c ++ SparkStats.rateGCd c)+ / fromIntegral duration -renderSparkCreation :: ViewParameters -> Timestamp -> Timestamp -> SparkTree- -> Double -> Render ()-renderSparkCreation params !start0 !end0 t !maxSparkValue = do- let f1 c = SparkStats.rateDud c- f2 c = f1 c + SparkStats.rateCreated c+spark_detail :: Int+spark_detail = 4 -- in pixels++treesProfile :: Double -> Timestamp -> Timestamp -> HECs+ -> (Timestamp, [[SparkStats.SparkStats]])+treesProfile scale start end hecs =+ let slice = ceiling (fromIntegral spark_detail * scale)+ pr trees = let (_, _, stree) = trees+ in sparkProfile slice start end stree+ in (slice, map pr (hecTrees hecs))+++renderSparkCreation :: ViewParameters -> Timestamp -> Timestamp -> Timestamp+ -> [SparkStats.SparkStats]+ -> Render ()+renderSparkCreation params !slice !start !end prof = do+ let f1 c = SparkStats.rateCreated c+ f2 c = f1 c + SparkStats.rateDud c f3 c = f2 c + SparkStats.rateOverflowed c- renderSpark params start0 end0 t- f1 fizzledDudsColour f2 createdConvertedColour f3 overflowedColour- maxSparkValue+ renderSpark params slice start end prof+ f1 createdConvertedColour f2 fizzledDudsColour f3 overflowedColour -renderSparkConversion :: ViewParameters -> Timestamp -> Timestamp -> SparkTree- -> Double -> Render ()-renderSparkConversion params !start0 !end0 t !maxSparkValue = do- let f1 c = SparkStats.rateFizzled c- f2 c = f1 c + SparkStats.rateGCd c- f3 c = f2 c + SparkStats.rateConverted c- renderSpark params start0 end0 t- f1 fizzledDudsColour f2 gcColour f3 createdConvertedColour- maxSparkValue+renderSparkConversion :: ViewParameters -> Timestamp -> Timestamp -> Timestamp+ -> [SparkStats.SparkStats]+ -> Render ()+renderSparkConversion params !slice !start !end prof = do+ let f1 c = SparkStats.rateConverted c+ f2 c = f1 c + SparkStats.rateFizzled c+ f3 c = f2 c + SparkStats.rateGCd c+ renderSpark params slice start end prof+ f1 createdConvertedColour f2 fizzledDudsColour f3 gcColour -renderSparkPool :: ViewParameters -> Timestamp -> Timestamp -> SparkTree- -> Double -> Render ()-renderSparkPool params@ViewParameters{..} !start0 !end0 t !maxSparkPool = do- let slice = round (fromIntegral spark_detail * scaleValue)- -- round the start time down, and the end time up, to a slice boundary- start = (start0 `div` slice) * slice- end = ((end0 + slice) `div` slice) * slice- prof = sparkProfile slice start end t- f1 c = SparkStats.minPool c+renderSparkPool :: ViewParameters -> Timestamp -> Timestamp -> Timestamp+ -> [SparkStats.SparkStats]+ -> Double -> Render ()+renderSparkPool ViewParameters{..} !slice !start !end prof !maxSparkPool = do+ let f1 c = SparkStats.minPool c f2 c = SparkStats.meanPool c f3 c = SparkStats.maxPool c addSparks outerPercentilesColour maxSparkPool f1 f2 start slice prof addSparks outerPercentilesColour maxSparkPool f2 f3 start slice prof outlineSparks maxSparkPool f2 start slice prof outlineSparks maxSparkPool (const 0) start slice prof- addScale params maxSparkPool start end+ renderHRulers hecSparksHeight start end -renderSpark :: ViewParameters -> Timestamp -> Timestamp -> SparkTree- -> (SparkStats.SparkStats -> Double) -> Color- -> (SparkStats.SparkStats -> Double) -> Color- -> (SparkStats.SparkStats -> Double) -> Color- -> Double -> Render ()-renderSpark params@ViewParameters{..} start0 end0 t- f1 c1 f2 c2 f3 c3 maxSparkValue = do- let slice = round (fromIntegral spark_detail * scaleValue)- -- round the start time down, and the end time up, to a slice boundary- start = (start0 `div` slice) * slice- end = ((end0 + slice) `div` slice) * slice- prof = sparkProfile slice start end t- -- Maximum number of sparks per slice for current data.- maxSliceSpark = fromIntegral slice * maxSparkValue- -- Maximum spark transition rate in spark/ms.- maxSlice = maxSparkValue * 1000000+renderSpark :: ViewParameters -> Timestamp -> Timestamp -> Timestamp+ -> [SparkStats.SparkStats]+ -> (SparkStats.SparkStats -> Double) -> Color+ -> (SparkStats.SparkStats -> Double) -> Color+ -> (SparkStats.SparkStats -> Double) -> Color+ -> Render ()+renderSpark ViewParameters{..} slice start end prof f1 c1 f2 c2 f3 c3 = do+ -- maxSpkValue is maximal spark transition rate, so+ -- maxSliceSpark is maximal number of sparks per slice for current data.+ let maxSliceSpark = maxSpkValue * fromIntegral slice outlineSparks maxSliceSpark f3 start slice prof addSparks c1 maxSliceSpark (const 0) f1 start slice prof addSparks c2 maxSliceSpark f1 f2 start slice prof addSparks c3 maxSliceSpark f2 f3 start slice prof- addScale params maxSlice start end--spark_detail :: Int-spark_detail = 4 -- in pixels+ renderHRulers hecSparksHeight start end off :: Double -> (SparkStats.SparkStats -> Double)- -> SparkStats.SparkStats- -> Double-off maxSliceSpark f t = fromIntegral hecSparksHeight * (1 - f t / maxSliceSpark)--dashedLine1 :: Render ()-dashedLine1 = do- save- identityMatrix- setDash [10,10] 0.0- setLineWidth 1- stroke- restore+ -> SparkStats.SparkStats+ -> Double+off maxSliceSpark f t =+ let clipped = min 1 (f t / maxSliceSpark)+ in fromIntegral hecSparksHeight * (1 - clipped) outlineSparks :: Double- -> (SparkStats.SparkStats -> Double)- -> Timestamp -> Timestamp- -> [SparkStats.SparkStats]- -> Render ()+ -> (SparkStats.SparkStats -> Double)+ -> Timestamp -> Timestamp+ -> [SparkStats.SparkStats]+ -> Render () outlineSparks maxSliceSpark f start slice ts = do case ts of [] -> return ()@@ -125,19 +120,16 @@ moveTo (dstart-dslice/2) (snd $ head t) mapM_ (uncurry lineTo) t setSourceRGBAhex black 1.0- save- identityMatrix setLineWidth 1 stroke- restore addSparks :: Color- -> Double- -> (SparkStats.SparkStats -> Double)- -> (SparkStats.SparkStats -> Double)- -> Timestamp -> Timestamp- -> [SparkStats.SparkStats]- -> Render ()+ -> Double+ -> (SparkStats.SparkStats -> Double)+ -> (SparkStats.SparkStats -> Double)+ -> Timestamp -> Timestamp+ -> [SparkStats.SparkStats]+ -> Render () addSparks colour maxSliceSpark f0 f1 start slice ts = do case ts of [] -> return ()@@ -157,108 +149,97 @@ setSourceRGBAhex colour 1.0 fill ---- TODO: redesign and refactor the scales code after some feedback and testing.---- There are ten minor ticks to a major tick and a semi-major tick--- occurs half way through a major tick (overlapping the corresponding--- minor tick).--- The timestamp values are in nanoseconds (1e-9), i.e.,--- a timestamp value of 1000000000 represents 1s.--- The x-position on the drawing canvas is in milliseconds (ms) (1e-3).--- scaleValue is used to divide a timestamp value to yield a pixel value.-addScale :: ViewParameters -> Double -> Timestamp -> Timestamp -> Render ()-addScale ViewParameters{..} maxSpark start end = do- let dstart = fromIntegral start- dend = fromIntegral end- dheight = fromIntegral hecSparksHeight- -- TODO: this is slightly incorrect, but probably at most 1 pixel off- maxS = if maxSpark < 100- then maxSpark -- too small, accuracy would suffer- else fromIntegral (2 * (ceiling maxSpark ` div` 2))- -- TODO: divide maxSpark instead, for nicer round numbers display- incr = hecSparksHeight `div` 10- majorTick = 10 * incr-- -- dashed lines across the graphs- setSourceRGBAhex black 0.3- save- forM_ [0 .. 1] $ \h -> do- let y = fromIntegral (floor (fromIntegral h * fromIntegral majorTick / 2)) - 0.5- moveTo dstart y- lineTo dend y- dashedLine1- restore-- -- draw scales only if the drawn area includes the very start- -- TODO: this draws the scale too often, because the drawn area begins- -- to the left of the 0 mark; will be fixed when scales are moved outside- -- the scrollable area.- when (start == 0) $ do-- newPath- moveTo dstart 0- lineTo dstart dheight- setSourceRGBAhex blue 1.0- save- identityMatrix- setLineWidth 1- stroke- restore+-- | Render the spark duration histogram together with it's X scale and+-- horizontal and vertical rulers.+renderSparkHistogram :: ViewParameters -> HECs -> Render ()+renderSparkHistogram ViewParameters{..} hecs =+ let intDoub :: Integral a => a -> Double+ intDoub = fromIntegral+ inR :: Timestamp -> Bool+ inR = case minterval of+ Nothing -> const True+ Just (from, to) -> \ t -> t >= from && t <= to+ -- TODO: if xs is sorted, we can slightly optimize the filtering+ inRange :: [(Timestamp, Int, Timestamp)] -> [(Int, (Timestamp, Int))]+ inRange xs = [(logdur, (dur, 1))+ | (start, logdur, dur) <- xs, inR start]+ xs = durHistogram hecs+ bars :: [(Double, Double, Int)]+ bars = [(intDoub t, intDoub height, count)+ | (t, (height, count)) <- histogramCounts $ inRange xs]+ -- TODO: data processing up to this point could be done only at interval+ -- changes (keeping @bars@ in ViewParameters and in probably also in IOref.+ -- The rest has to be recomputed at each redraw, because resizing+ -- the window modifies the way the graph is drawn.+ -- TODO: at least pull the above out into a separate function. - selectFontFace "sans serif" FontSlantNormal FontWeightNormal- setFontSize 12- setSourceRGBAhex blue 1.0+ -- Define general parameters for visualization.+ width' = width - 5 -- add a little margin on the right+ (w, h) = (intDoub width', intDoub histogramHeight)+ (minX, maxX, maxY) = (intDoub (minXHistogram hecs),+ intDoub (maxXHistogram hecs),+ intDoub (maxYHistogram hecs))+ nBars = max 5 (maxX - minX + 1)+ segmentWidth = w / nBars+ -- Define parameters for drawing the bars.+ gapWidth = 10+ barWidth = segmentWidth - gapWidth+ sX x = gapWidth / 2 + (x - minX) * segmentWidth+ sY y = y * h / (max 2 maxY)+ plotRect (x, y, count) = do+ -- Draw a single bar.+ setSourceRGBAhex blue 1.0+ rectangle (sX x) (sY maxY) barWidth (sY (-y))+ fillPreserve+ setSourceRGBA 0 0 0 0.7+ setLineWidth 1+ stroke+ -- Print the number of sparks in the bar.+ selectFontFace "sans serif" FontSlantNormal FontWeightNormal+ setFontSize 10+ let above = sY (-y) > -20+ if above+ then setSourceRGBAhex black 1.0+ else setSourceRGBAhex white 1.0+ moveTo (sX x + 3) (sY (maxY - y) + if above then -3 else 13)+ showText (show count)+ drawHist = forM_ bars plotRect+ -- Define parameters for X scale.+ off y = 16 - y+ xScaleMode = XScaleLog minX segmentWidth+ drawXScale = renderXScale 1 0 maxBound width' off xScaleMode+ -- Define parameters for vertical rulers.+ nB = round nBars+ mult | nB <= 7 = 1+ | nB `mod` 5 == 0 = 5+ | nB `mod` 4 == 0 = 4+ | nB `mod` 3 == 0 = 3+ | nB `mod` 2 == 0 = nB `div` 2+ | otherwise = nB+ drawVRulers = renderVRulers 1 0 (fromIntegral width') histogramHeight+ (XScaleLog undefined (segmentWidth * fromIntegral mult))+ -- Define the horizontal rulers call.+ drawHRulers = renderHRulers histogramHeight 0 (fromIntegral width')+ in do+ -- Start the drawing by wiping out timeline vertical rules+ -- (for PNG/PDF that require clear, transparent background) save- scale scaleValue 1.0- setLineWidth 0.5- drawTicks maxS start scaleValue 0 incr majorTick hecSparksHeight+ translate hadjValue 0+ scale scaleValue 1+ rectangle 0 (fromIntegral $ - tracePad) (fromIntegral width)+ (fromIntegral $ histogramHeight + histXScaleHeight + 2 * tracePad)+ setSourceRGBAhex white 1+ op <- getOperator+ setOperator OperatorAtop -- TODO: fixme: it paints white vertical rulers+ fill+ setOperator op+ -- Draw the bars.+ drawHist+ -- Draw the rulers on top of the bars (they are partially transparent).+ drawVRulers+ drawHRulers+ -- Move to the bottom and draw the X scale. The Y scale is drawn+ -- independetly in another drawing area.+ translate 0 (fromIntegral histogramHeight)+ drawXScale restore---- TODO: make it more robust when parameters change, e.g., if incr is too small-drawTicks :: Double -> Timestamp -> Double -> Int -> Int -> Int -> Int -> Render ()-drawTicks maxS offset scaleValue pos incr majorTick endPos- = if pos <= endPos then do- draw_line (x0, hecSparksHeight - y0) (x1, hecSparksHeight - y1)- when (pos > 0- && (atMajorTick || atMidTick || tickWidthInPixels > 30)) $ do- move_to (offset + 15,- fromIntegral hecSparksHeight - pos + 4)- m <- getMatrix- identityMatrix- tExtent <- textExtents tickText- (fourPixels, _) <- deviceToUserDistance 4 0- when (textExtentsWidth tExtent + fourPixels < fromIntegral tickWidthInPixels || atMidTick || atMajorTick) $ do- textPath tickText- C.fill- setMatrix m- drawTicks maxS offset scaleValue (pos+incr) incr majorTick endPos- else- return ()- where- tickWidthInPixels :: Int- tickWidthInPixels = truncate ((fromIntegral incr) / scaleValue)- tickText = showTickText (maxS * fromIntegral pos- / fromIntegral hecSparksHeight)- atMidTick = pos `mod` (majorTick `div` 2) == 0- atMajorTick = pos `mod` majorTick == 0- (x0, y0, x1, y1) = if atMajorTick then- (offset, pos, offset+13, pos)- else- if atMidTick then- (offset, pos, offset+10, pos)- else- (offset, pos, offset+6, pos)--showTickText :: Double -> String-showTickText pos- = deZero (printf "%.2f" pos)--deZero :: String -> String-deZero str- = if length str >= 4 && take 3 revstr == "00." then- reverse (drop 3 revstr)- else- str- where- revstr = reverse str
GUI/Timeline/Ticks.hs view
@@ -1,149 +1,280 @@+{-# LANGUAGE CPP #-} module GUI.Timeline.Ticks (- renderTicks+ renderVRulers,+ XScaleMode(..),+ renderXScaleArea,+ renderXScale,+ renderHRulers,+ renderYScale,+ mu,+ deZero, ) where -import GUI.Timeline.Render.Constants+import Events.HECs+import GUI.Types import GUI.Timeline.CairoDrawing import GUI.ViewerColours import Graphics.Rendering.Cairo-import qualified Graphics.Rendering.Cairo as C---- Imports for GHC Events-import GHC.RTS.Events hiding (Event)- import Control.Monad----import Debug.Trace---import Text.Printf+import Text.Printf ----------------------------------------------------------------------------------- Minor, semi-major and major ticks are drawn and the absolute periods of+-- Minor, semi-major and major ticks are drawn and the absolute period of -- the ticks is determined by the zoom level. -- There are ten minor ticks to a major tick and a semi-major tick -- occurs half way through a major tick (overlapping the corresponding -- minor tick).---- The timestamp values are in nanos-seconds (1e-9) i.e.--- a timestamp value of 1000000000 represents 1s.--- The position on the drawing canvas is in milliseconds (ms) (1e-3).-+-- The timestamp values are in micro-seconds (1e-6) i.e.+-- a timestamp value of 1000000 represents 1s. The position on the drawing+-- canvas is in milliseconds (ms) (1e-3). -- scaleValue is used to divide a timestamp value to yield a pixel value.- -- NOTE: the code below will crash if the timestampFor100Pixels is 0. -- The zoom factor should be controlled to ensure that this never happens. --------------------------------------------------------------------------------+-- | Render vertical rulers (solid translucent lines), matching scale ticks.+renderVRulers :: Double -> Timestamp -> Timestamp -> Int -> XScaleMode+ -> Render()+renderVRulers scaleValue startPos endPos height xScaleMode = do+ let timestampFor100Pixels = truncate (100 * scaleValue)+ snappedTickDuration :: Timestamp+ snappedTickDuration =+ 10 ^ max 0 (truncate (logBase 10 (fromIntegral timestampFor100Pixels)+ :: Double))+ tickWidthInPixels :: Double+ tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue+ firstTick :: Timestamp+ firstTick = snappedTickDuration * (startPos `div` snappedTickDuration)+ setSourceRGBAhex black 0.15+ setLineWidth scaleValue+ case xScaleMode of+ XScaleTime ->+ drawVRulers tickWidthInPixels scaleValue+ (fromIntegral $ firstTick + snappedTickDuration)+ (fromIntegral snappedTickDuration) endPos height+ (1 + fromIntegral (startPos `div` snappedTickDuration))+ XScaleLog _ dx ->+ drawVRulers 1e1000 1 dx dx endPos height 1 -renderTicks :: Timestamp -> Timestamp -> Double -> Int -> Render()-renderTicks startPos endPos scaleValue height- = do- selectFontFace "sans serif" FontSlantNormal FontWeightNormal- setFontSize 12- setSourceRGBAhex blue 1.0- setLineWidth 1.0- -- trace (printf "startPos: %d, endPos: %d" startPos endPos) $ do- draw_line (startPos, oy) (endPos, oy)- let- timestampFor100Pixels = truncate (100 * scaleValue) -- ns time for 100 pixels- snappedTickDuration :: Timestamp- snappedTickDuration = 10 ^ truncate (logBase 10 (fromIntegral timestampFor100Pixels) :: Double)- tickWidthInPixels :: Int- tickWidthInPixels = truncate ((fromIntegral snappedTickDuration) / scaleValue)- firstTick :: Timestamp- firstTick = snappedTickDuration * (startPos `div` snappedTickDuration)- -- liftIO $- -- do putStrLn ("timestampFor100Pixels = " ++ show timestampFor100Pixels)- -- putStrLn ("tickWidthInPixels = " ++ show tickWidthInPixels)- -- putStrLn ("snappedTickDuration = " ++ show snappedTickDuration)- drawTicks tickWidthInPixels height scaleValue firstTick- snappedTickDuration (10*snappedTickDuration) endPos+-- | Render a single vertical ruler and then recurse.+drawVRulers :: Double -> Double -> Double -> Double+ -> Timestamp -> Int -> Int -> Render ()+drawVRulers tickWidthInPixels scaleValue pos incr endPos height i =+ if floor pos <= endPos then do+ when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do+ draw_line (round pos, 0) (round pos, height)+ drawVRulers+ tickWidthInPixels scaleValue (pos + incr) incr endPos height (i + 1)+ else+ return ()+ where+ atMidTick = i `mod` 5 == 0+ atMajorTick = i `mod` 10 == 0 -drawTicks :: Int -> Int -> Double -> Timestamp -> Timestamp ->- Timestamp -> Timestamp -> Render ()-drawTicks tickWidthInPixels height scaleValue pos incr majorTick endPos- = if pos <= endPos then- do setLineWidth scaleValue- draw_line (x0, y0) (x1, y1)- when (atMajorTick || atMidTick || tickWidthInPixels > 30) $ do- move_to (pos - truncate (scaleValue * 4.0), oy - 10)- m <- getMatrix- identityMatrix- tExtent <- textExtents tickTimeText- (fourPixels, _) <- deviceToUserDistance 4 0- when (textExtentsWidth tExtent + fourPixels < fromIntegral tickWidthInPixels || atMidTick || atMajorTick) $ do- textPath tickTimeText- C.fill- setMatrix m- setSourceRGBAhex blue 0.2- draw_line (x1, y1) (x1, height)- setSourceRGBAhex blue 1.0+-- | Render the X scale, based on view parameters and hecs.+renderXScaleArea :: ViewParameters -> HECs -> Render ()+renderXScaleArea ViewParameters{width, scaleValue, hadjValue, xScaleAreaHeight}+ hecs =+ let lastTx = hecLastEventTime hecs+ off y = y + xScaleAreaHeight - 17+ in renderXScale scaleValue hadjValue lastTx width off XScaleTime - drawTicks tickWidthInPixels height scaleValue (pos+incr) incr majorTick endPos- else- return ()- where- tickTimeText = showTickTime pos- atMidTick = pos `mod` (majorTick `div` 2) == 0- atMajorTick = pos `mod` majorTick == 0- (x0, y0, x1, y1) = if pos `mod` majorTick == 0 then- (pos, oy, pos, oy+16)- else- if pos `mod` (majorTick `div` 2) == 0 then- (pos, oy, pos, oy+12)- else- (pos, oy, pos, oy+8) ----------------------------------------------------------------------------------- This display the nano-second time unit with an appropriate suffix+data XScaleMode = XScaleTime | XScaleLog Double Double deriving Eq++-- | Render the X (vertical) scale: render X axis and call ticks rendering.+-- TODO: refactor common parts with renderVRulers, in particlar to expose+-- that ruler positions match tick positions.+renderXScale :: Double -> Double -> Timestamp -> Int+ -> (Int -> Int) -> XScaleMode+ -> Render ()+renderXScale scaleValue hadjValue lastTx width off xScaleMode = do+ let scale_width = fromIntegral width * scaleValue+ startPos :: Timestamp+ startPos = truncate hadjValue+ endPos :: Timestamp+ endPos = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx)+ save+ scale (1/scaleValue) 1.0+ translate (-hadjValue) 0+ selectFontFace "sans serif" FontSlantNormal FontWeightNormal+ setFontSize 12+ setSourceRGBAhex black 1.0+-- setLineCap LineCapRound -- TODO: breaks rendering currently (see BrokenX.png)+ setLineWidth 1.0 -- TODO: it's not really 1 pixel, due to the scale+ -- TODO: snap to pixels, currently looks semi-transparent+ draw_line (startPos, off 16) (endPos, off 16)+ let tFor100Pixels = truncate (100 * scaleValue)+ snappedTickDuration :: Timestamp+ snappedTickDuration =+ 10 ^ max 0 (truncate (logBase 10 (fromIntegral tFor100Pixels)+ :: Double))+ tickWidthInPixels :: Double+ tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue+ firstTick :: Timestamp+ firstTick = snappedTickDuration * (startPos `div` snappedTickDuration)+ setLineWidth scaleValue -- TODO: should be 0.5 pixels (when we rewrite stuff)+ case xScaleMode of+ XScaleTime ->+ drawXTicks tickWidthInPixels scaleValue (fromIntegral firstTick)+ (fromIntegral snappedTickDuration) endPos off xScaleMode+ (fromIntegral (startPos `div` snappedTickDuration))+ XScaleLog _ segmentWidth ->+ drawXTicks 1e1000 1 0 segmentWidth endPos off xScaleMode 0+ restore++-- | Render a single X scale tick and then recurse.+drawXTicks :: Double -> Double -> Double -> Double -> Timestamp+ -> (Int -> Int) -> XScaleMode -> Int+ -> Render ()+drawXTicks tickWidthInPixels scaleValue pos incr endPos off xScaleMode i =+ if floor pos <= endPos then do+ -- TODO: snap to pixels, currently looks semi-transparent+ when (pos /= 0 || xScaleMode == XScaleTime) $+ draw_line (x1, off 16) (x1, off (16 - tickLength))+ when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do+ tExtent <- textExtents tickTimeText+ let tExtentWidth = textExtentsWidth tExtent+ move_to textPos+ m <- getMatrix+ identityMatrix+ when (floor (pos + incr) <= endPos+ && (tExtentWidth + tExtentWidth / 3 < width || atMajorTick)) $+ showText tickTimeText+ setMatrix m+ drawXTicks+ tickWidthInPixels scaleValue (pos + incr) incr endPos off xScaleMode (i+1)+ else+ return ()+ where+ atMidTick = xScaleMode == XScaleTime && i `mod` 5 == 0+ atMajorTick = xScaleMode == XScaleTime && i `mod` 10 == 0+ textPos =+ if xScaleMode == XScaleTime+ then (x1 + ceiling (scaleValue * 3), off (-3))+ else (x1 + ceiling (scaleValue * 2), tickLength + 13)+ tickLength | atMajorTick = 16+ | atMidTick = 10+ | otherwise = if xScaleMode == XScaleTime then 6 else 8+ posTime = case xScaleMode of+ XScaleTime -> round pos+ XScaleLog minX _ -> round $ 2 ** (minX + pos / incr)+ tickTimeText = showMultiTime posTime+ width = if atMidTick then 5 * tickWidthInPixels+ else tickWidthInPixels+ -- We cheat at pos 0, to avoid half covering the tick by the grey label area.+ lineWidth = scaleValue+ x1 = round $ if pos == 0 && xScaleMode == XScaleTime then lineWidth else pos++-- | Display the micro-second time unit with an appropriate suffix -- depending on the actual time value. -- For times < 1e-6 the time is shown in micro-seconds. -- For times >= 1e-6 and < 0.1 seconds the time is shown in ms -- For times >= 0.5 seconds the time is shown in seconds--showTickTime :: Timestamp -> String-showTickTime pos- = if pos == 0 then- "0s"- else- if pos < 1000000 then -- Show time as micro-seconds for times < 1e-6- reformatMS (posf / 1000) ++ (mu ++ "s") -- microsecond (1e-6s).- else- if pos < 100000000 then -- Show miliseonds for time < 0.1s- reformatMS (posf / 1000000) ++ "ms" -- miliseconds 1e-3- else -- Show time in seconds- reformatMS (posf / 1000000000) ++ "s"- where+showMultiTime :: Timestamp -> String+showMultiTime pos =+ if pos == 0 then "0s"+ else if pos < 1000 then -- Show time as micro-seconds for times < 1e-6+ reformatMS posf ++ (mu ++ "s") -- microsecond (1e-6s).+ else if pos < 100000 then -- Show miliseonds for time < 0.1s+ reformatMS (posf / 1000) ++ "ms" -- miliseconds 1e-3+ else -- Show time in seconds+ reformatMS (posf / 1000000) ++ "s"+ where posf :: Double posf = fromIntegral pos- mu :: String--- here we assume that cairo 0.12.1 will have proper Unicode support-#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1)- -- this version of cairo doesn't handle Unicode properly. Thus, we do the- -- encoding by hand:- mu = "\194\181"-#else- mu = "\x00b5"-#endif-+ reformatMS :: Show a => a -> String+ reformatMS pos = deZero (show pos) ------------------------------------------------------------------------------- -reformatMS :: Num a => a -> String-reformatMS pos- = deZero (show pos)+-- | Render horizontal rulers (dashed translucent lines),+-- matching scale ticks (visible in the common @incr@ value and starting at 0).+renderHRulers :: Int -> Timestamp -> Timestamp -> Render ()+renderHRulers hecSparksHeight start end = do+ let dstart = fromIntegral start+ dend = fromIntegral end+ incr = fromIntegral hecSparksHeight / 10+ -- dashed lines across the graphs+ setSourceRGBAhex black 0.15+ setLineWidth 1+ save+ forM_ [0, 5] $ \h -> do+ let y = h * incr+ moveTo dstart y+ lineTo dend y+ stroke+ restore --------------------------------------------------------------------------------+-- | Render one of the Y (horizontal) scales: render the Y axis+-- and call ticks rendering.+renderYScale :: Int -> Double -> Double -> Double -> Double -> Render ()+renderYScale hecSparksHeight scaleValue maxSpark xoffset yoffset = do+ let -- This is slightly off (by 1% at most), but often avoids decimal dot:+ maxS = if maxSpark < 100+ then maxSpark -- too small, would be visible on screen+ else fromIntegral (2 * (ceiling maxSpark ` div` 2))+ incr = fromIntegral hecSparksHeight / 10+ save+ newPath+ moveTo (xoffset + 12) yoffset+ lineTo (xoffset + 12) (yoffset + fromIntegral hecSparksHeight)+ setSourceRGBAhex black 1.0+ setLineCap LineCapRound+ setLineWidth 1.0 -- TODO: it's not really 1 pixel, due to the scale+ stroke+ selectFontFace "sans serif" FontSlantNormal FontWeightNormal+ setFontSize 12+ scale scaleValue 1.0+ setLineWidth 0.5 -- TODO: it's not really 0.5 pixels, due to the scale+ drawYTicks maxS 0 incr xoffset yoffset 0+ restore -deZero :: String -> String-deZero str- = if length str >= 3 && take 2 revstr == "0." then- reverse (drop 2 revstr)- else- str- where- revstr = reverse str+-- | Render a single Y scale tick and then recurse.+drawYTicks :: Double -> Double -> Double -> Double -> Double -> Int -> Render ()+drawYTicks maxS pos incr xoffset yoffset i =+ if i <= 10 then do+ -- TODO: snap to pixels, currently looks semi-transparent+ moveTo (xoffset + 12) (yoffset + majorTick - pos)+ lineTo (xoffset + 12 - tickLength) (yoffset + majorTick - pos)+ stroke+ when (atMajorTick || atMidTick) $ do+ tExtent <- textExtents tickText+ (fewPixels, yPix) <- deviceToUserDistance 3 4+ moveTo (xoffset - textExtentsWidth tExtent - fewPixels)+ (yoffset + majorTick - pos + yPix)+ when (atMidTick || atMajorTick) $+ showText tickText+ drawYTicks maxS (pos + incr) incr xoffset yoffset (i + 1)+ else+ return ()+ where+ atMidTick = i `mod` 5 == 0+ atMajorTick = i `mod` 10 == 0+ majorTick = 10 * incr+ tickText = reformatV (fromIntegral i * maxS / 10)+ tickLength | atMajorTick = 11+ | atMidTick = 9+ | otherwise = 6+ reformatV :: Double -> String+ reformatV v = deZero (printf "%.2f" v) ------------------------------------------------------------------------------- +-- | The 'micro' symbol.+mu :: String+#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1)+-- this version of cairo doesn't handle Unicode properly.+-- Thus, we do the encoding by hand:+mu = "\194\181"+#else+-- Haskell cairo bindings 0.12.1 have proper Unicode support+mu = "\x00b5"+#endif++-- | Remove all meaningless trailing zeroes.+deZero :: String -> String+deZero s+ | '.' `elem` s =+ reverse . dropWhile (=='.') . dropWhile (=='0') . reverse $ s+ | otherwise = s
GUI/Timeline/Types.hs view
@@ -1,5 +1,6 @@ module GUI.Timeline.Types ( TimelineState(..),+ TimeSelection(..), ) where @@ -12,14 +13,25 @@ ----------------------------------------------------------------------------- data TimelineState = TimelineState {- timelineDrawingArea :: DrawingArea,- timelineLabelDrawingArea :: DrawingArea,- timelineAdj :: Adjustment,- timelineVAdj :: Adjustment,+ timelineDrawingArea :: DrawingArea,+ timelineYScaleArea :: DrawingArea,+ timelineXScaleArea :: DrawingArea,+ timelineAdj :: Adjustment,+ timelineVAdj :: Adjustment, - timelinePrevView :: IORef (Maybe (ViewParameters, Surface)),+ timelinePrevView :: IORef (Maybe (ViewParameters, Surface)), - scaleIORef :: IORef Double -- in ns/pixel+ -- This scale value is used to map a micro-second value to a pixel unit.+ -- To convert a timestamp value to a pixel value, multiply it by scale.+ -- To convert a pixel value to a micro-second value, divide it by scale.+ scaleIORef :: IORef Double,++ -- Maximal number of sparks/slice measured after every zoom to fit.+ maxSpkIORef :: IORef Double }+++data TimeSelection = PointSelection Timestamp+ | RangeSelection Timestamp Timestamp -----------------------------------------------------------------------------
GUI/TraceView.hs view
@@ -67,10 +67,11 @@ where renderTrace (TraceHEC hec) = "HEC " ++ show hec- renderTrace (SparkCreationHEC hec) = "HEC " ++ show hec- renderTrace (SparkConversionHEC hec) = "HEC " ++ show hec- renderTrace (SparkPoolHEC hec) = "HEC " ++ show hec- renderTrace (TraceThread tid) = "Thread " ++ show tid+ renderTrace (TraceInstantHEC hec) = "HEC " ++ show hec+ renderTrace (TraceCreationHEC hec) = "HEC " ++ show hec+ renderTrace (TraceConversionHEC hec) = "HEC " ++ show hec+ renderTrace (TracePoolHEC hec) = "HEC " ++ show hec+ renderTrace (TraceHistogram) = "Spark Histogram" renderTrace (TraceGroup label) = label renderTrace (TraceActivity) = "Activity Profile" @@ -99,23 +100,30 @@ traceViewSetHECs :: TraceView -> HECs -> IO () traceViewSetHECs TraceView{tracesStore} hecs = do treeStoreClear tracesStore+ -- for testing only (e.g., to compare with histogram of data from interval+ -- or to compare visually with other traces):+ -- treeStoreInsert tracesStore [] 0 (TraceHistogram, Visible) go 0 treeStoreInsert tracesStore [] 0 (TraceActivity, Visible) where- newt = Node { rootLabel = (TraceGroup "HEC Traces", Visible),+ newT = Node { rootLabel = (TraceGroup "HEC Traces", Visible), subForest = [ Node { rootLabel = (TraceHEC k, Visible), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] }+ newI = Node { rootLabel = (TraceGroup "Instant Events", Hidden),+ subForest = [ Node { rootLabel = (TraceInstantHEC k, Hidden),+ subForest = [] }+ | k <- [ 0 .. hecCount hecs - 1 ] ] } nCre = Node { rootLabel = (TraceGroup "Spark Creation", Hidden),- subForest = [ Node { rootLabel = (SparkCreationHEC k, Hidden),+ subForest = [ Node { rootLabel = (TraceCreationHEC k, Hidden), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } nCon = Node { rootLabel = (TraceGroup "Spark Conversion", Hidden),- subForest = [ Node { rootLabel = (SparkConversionHEC k, Hidden),+ subForest = [ Node { rootLabel = (TraceConversionHEC k, Hidden), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } nPoo = Node { rootLabel = (TraceGroup "Spark Pool", Hidden),- subForest = [ Node { rootLabel = (SparkPoolHEC k, Hidden),+ subForest = [ Node { rootLabel = (TracePoolHEC k, Hidden), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } go n = do@@ -125,12 +133,17 @@ treeStoreInsertTree tracesStore [] 0 nPoo treeStoreInsertTree tracesStore [] 0 nCon treeStoreInsertTree tracesStore [] 0 nCre- treeStoreInsertTree tracesStore [] 0 newt+ treeStoreInsertTree tracesStore [] 0 newI+ treeStoreInsertTree tracesStore [] 0 newT Just t -> case t of Node { rootLabel = (TraceGroup "HEC Traces", _) } -> do treeStoreRemove tracesStore [n]- treeStoreInsertTree tracesStore [] n newt+ treeStoreInsertTree tracesStore [] n newT+ go (n+1)+ Node { rootLabel = (TraceGroup "HEC Instant Events", _) } -> do+ treeStoreRemove tracesStore [n]+ treeStoreInsertTree tracesStore [] n newI go (n+1) Node { rootLabel = (TraceGroup "Spark Creation", _) } -> do treeStoreRemove tracesStore [n]
GUI/Types.hs view
@@ -1,6 +1,8 @@ module GUI.Types ( ViewParameters(..), Trace(..),+ Timestamp,+ Interval, ) where import GHC.RTS.Events@@ -9,15 +11,19 @@ data Trace = TraceHEC Int- | SparkCreationHEC Int- | SparkConversionHEC Int- | SparkPoolHEC Int- | TraceThread ThreadId+ | TraceInstantHEC Int+ | TraceCreationHEC Int+ | TraceConversionHEC Int+ | TracePoolHEC Int+ | TraceHistogram | TraceGroup String | TraceActivity -- more later ...+ -- | TraceThread ThreadId deriving Eq +type Interval = (Timestamp, Timestamp)+ -- the parameters for a timeline render; used to figure out whether -- we're drawing the same thing twice. data ViewParameters = ViewParameters {@@ -25,7 +31,11 @@ viewTraces :: [Trace], hadjValue :: Double, scaleValue :: Double,+ maxSpkValue :: Double, detail :: Int,- bwMode, labelsMode :: Bool+ bwMode, labelsMode :: Bool,+ histogramHeight :: Int,+ minterval :: Maybe Interval,+ xScaleAreaHeight :: Int } deriving Eq
GUI/ViewerColours.hs view
@@ -3,7 +3,7 @@ --- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $ ------------------------------------------------------------------------------- -module GUI.ViewerColours where+module GUI.ViewerColours (Color, module GUI.ViewerColours) where import Graphics.UI.Gtk import Graphics.Rendering.Cairo@@ -13,23 +13,20 @@ -- Colours runningColour :: Color-runningColour = green+runningColour = darkGreen gcColour :: Color gcColour = orange gcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color gcStartColour = orange-gcWorkColour = green+gcWorkColour = orange gcIdleColour = white gcEndColour = orange createThreadColour :: Color createThreadColour = lightBlue -threadRunnableColour :: Color-threadRunnableColour = darkGreen- seqGCReqColour :: Color seqGCReqColour = cyan @@ -40,7 +37,7 @@ migrateThreadColour = darkRed threadWakeupColour :: Color-threadWakeupColour = purple+threadWakeupColour = green shutdownColour :: Color shutdownColour = darkBrown@@ -53,9 +50,12 @@ fizzledDudsColour, createdConvertedColour, overflowedColour :: Color fizzledDudsColour = grey-createdConvertedColour = green+createdConvertedColour = darkGreen overflowedColour = red +userMessageColour :: Color+userMessageColour = darkRed+ outerPercentilesColour :: Color outerPercentilesColour = lightGrey @@ -70,6 +70,9 @@ lightGrey :: Color lightGrey = Color 0xD000 0xD000 0xD000 +gtkBorderGrey :: Color+gtkBorderGrey = Color 0xF200 0xF100 0xF000+ red :: Color red = Color 0xFFFF 0 0 @@ -104,7 +107,7 @@ darkRed = Color 0xcc00 0x0000 0x0000 orange :: Color-orange = Color 0xFFFF 0x9900 0x0000 -- orange+orange = Color 0xE000 0x7000 0x0000 -- orange profileBackground :: Color profileBackground = Color 0xFFFF 0xFFFF 0xFFFF
Main.hs view
@@ -1,6 +1,3 @@--- ThreadScope: a graphical viewer for Haskell event log information.--- Maintainer: satnams@microsoft.com, s.singh@ieee.org- module Main where import GUI.Main (runGUI)@@ -39,7 +36,9 @@ usageHeader = "Usage: threadscope [eventlog]\n" ++ " or: threadscope [FLAGS]" helpHeader = usageHeader ++ "\n\nFlags: "- printHelp = putStrLn (usageInfo helpHeader flagDescrs)+ printHelp = putStrLn (usageInfo helpHeader flagDescrs+ ++ "\nFor more details see http://www.haskell.org/haskellwiki/ThreadScope_Tour\n")+ -------------------------------------------------------------------------------
threadscope.cabal view
@@ -1,8 +1,8 @@ Name: threadscope-Version: 0.2.0+Version: 0.2.1 Category: Development, Profiling, Trace Synopsis: A graphical tool for profiling parallel Haskell programs.-Description: ThreadScope is a graphical viewer for thread profile +Description: ThreadScope is a graphical viewer for thread profile information generated by the Glasgow Haskell compiler (GHC). .@@ -18,15 +18,20 @@ 2009 Donnie Jones, 2011 Duncan Coutts, 2011 Mikolaj Konarski+ 2011 Nicolas Wu+ 2011 Eric Kow Author: Satnam Singh <s.singh@ieee.org>, Simon Marlow <marlowsd@gmail.com>, Donnie Jones <donnie@darthik.com>, Duncan Coutts <duncan@well-typed.com>,- Mikolaj Konarski <mikolaj.konarski@gmail.com>+ Mikolaj Konarski <mikolaj@well-typed.com>,+ Nicolas Wu <nick@well-typed.com>,+ Eric Kow <eric@well-typed.com> Maintainer: Satnam Singh <s.singh@ieee.org>+Homepage: http://www.haskell.org/haskellwiki/ThreadScope Bug-reports: http://trac.haskell.org/ThreadScope/ Build-Type: Simple-cabal-version: >= 1.6+Cabal-version: >= 1.6 Data-files: threadscope.ui, threadscope.png source-repository head@@ -38,11 +43,11 @@ Build-Depends: base >= 4.0 && < 5, gtk >= 0.12, cairo, glib, pango, binary, array, mtl, filepath,- ghc-events == 0.3.*,- containers >= 0.2 && < 0.5- extensions: RecordWildCards, NamedFieldPuns,- BangPatterns, PatternGuards,- CPP+ ghc-events == 0.4.*,+ containers >= 0.2 && < 0.5,+ deepseq >= 1.1,+ time >= 1.1+ Extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards Other-Modules: Events.HECs, Events.EventDuration, Events.EventTree,@@ -56,9 +61,12 @@ GUI.Dialogs, GUI.SaveAs, GUI.Timeline,+ GUI.Histogram, GUI.TraceView, GUI.BookmarkView, GUI.KeyView,+ GUI.StartupInfoView,+ GUI.SummaryView, GUI.Types, GUI.ConcurrencyControl, GUI.ProgressView,@@ -79,14 +87,9 @@ -fno-warn-unused-do-bind -- Note: we do not want to use -threaded with gtk2hs. - if impl(ghc >= 7.0)- -- GHC 7.0 and later require a flag to enable the options in ghcrts.c- ghc-options: -rtsopts -fno-warn-unused-do-bind- if impl(ghc < 6.12) -- GHC before 6.12 gave spurious warnings for RecordWildCards ghc-options: -fno-warn-unused-matches if !os(windows) build-depends: unix >= 2.3 && < 2.6-
threadscope.ui view
@@ -17,12 +17,42 @@ <property name="can_focus">False</property> <property name="stock">gtk-save-as</property> </object>+ <object class="GtkImage" id="image4">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-goto-first</property>+ </object>+ <object class="GtkImage" id="image5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-home</property>+ </object>+ <object class="GtkImage" id="image6">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-goto-last</property>+ </object>+ <object class="GtkImage" id="image7">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-zoom-in</property>+ </object>+ <object class="GtkImage" id="image8">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-zoom-out</property>+ </object>+ <object class="GtkImage" id="image9">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-zoom-fit</property>+ </object> <object class="GtkWindow" id="main_window"> <property name="width_request">600</property> <property name="height_request">400</property> <property name="can_focus">True</property> <property name="title" translatable="yes">ThreadScope</property>- <property name="default_width">1280</property>+ <property name="default_width">1200</property> <property name="default_height">600</property> <child> <object class="GtkVBox" id="vbox1">@@ -49,6 +79,7 @@ <property name="visible">True</property> <property name="can_focus">False</property> <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property> <property name="use_stock">True</property> <accelerator key="o" signal="activate" modifiers="GDK_CONTROL_MASK"/> </object>@@ -110,7 +141,7 @@ <property name="visible">True</property> <property name="can_focus">False</property> <property name="use_action_appearance">False</property>- <property name="label" translatable="yes">Events</property>+ <property name="label" translatable="yes">Information pane</property> <property name="use_underline">True</property> <property name="active">True</property> </object>@@ -120,11 +151,20 @@ <property name="visible">True</property> <property name="can_focus">False</property> <property name="use_action_appearance">False</property>- <property name="label" translatable="yes">Black/white</property>+ <property name="label" translatable="yes">Black & white</property> <property name="use_underline">True</property> </object> </child> <child>+ <object class="GtkCheckMenuItem" id="view_labels_mode">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">Event labels</property>+ <property name="use_underline">True</property>+ </object>+ </child>+ <child> <object class="GtkSeparatorMenuItem" id="separatormenuitem2"> <property name="visible">True</property> <property name="can_focus">False</property>@@ -147,6 +187,93 @@ </object> </child> <child>+ <object class="GtkMenuItem" id="menuitem2dot5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">_Move</property>+ <property name="use_underline">True</property>+ <child type="submenu">+ <object class="GtkMenu" id="menu2dot5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkImageMenuItem" id="move_first">+ <property name="label" translatable="yes">Jump to start</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="image">image4</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="move_centre">+ <property name="label" translatable="yes">Centre on cursor</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="image">image5</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="move_last">+ <property name="label" translatable="yes">Jump to end</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="image">image6</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ <child>+ <object class="GtkSeparatorMenuItem" id="separatormenuitem2dot5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="move_zoomin">+ <property name="label" translatable="yes">Zoom in</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="image">image7</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="move_zoomout">+ <property name="label" translatable="yes">Zoom out</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="image">image8</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="move_zoomfit">+ <property name="label" translatable="yes">Fit to window</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="image">image9</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ </object>+ </child>+ </object>+ </child>+ <child> <object class="GtkMenuItem" id="menuitem3"> <property name="visible">True</property> <property name="can_focus">False</property>@@ -158,6 +285,31 @@ <property name="visible">True</property> <property name="can_focus">False</property> <child>+ <object class="GtkMenuItem" id="tutorialMenuItem">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">Online tutorial</property>+ <property name="use_underline">True</property>+ </object>+ </child>+ <child>+ <object class="GtkMenuItem" id="websiteMenuItem">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">Website</property>+ <property name="use_underline">True</property>+ </object>+ </child>+ <child>+ <object class="GtkSeparatorMenuItem" id="menuitem5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ </object>+ </child>+ <child> <object class="GtkImageMenuItem" id="aboutMenuItem"> <property name="label">gtk-about</property> <property name="visible">True</property>@@ -185,10 +337,33 @@ <property name="toolbar_style">both-horiz</property> <property name="show_arrow">False</property> <child>+ <object class="GtkToolButton" id="cpus_open">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Open an eventlog</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="stock_id">gtk-open</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkSeparatorToolItem" id="separatortoolitem5dot5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ <packing>+ <property name="expand">False</property>+ </packing>+ </child>+ <child> <object class="GtkToolButton" id="cpus_first"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="tooltip_text" translatable="yes">Jump to start</property>+ <property name="tooltip_text" translatable="yes">Jump to the start</property> <property name="use_action_appearance">False</property> <property name="use_underline">True</property> <property name="stock_id">gtk-goto-first</property>@@ -273,30 +448,6 @@ <property name="homogeneous">True</property> </packing> </child>- <child>- <object class="GtkSeparatorToolItem" id="separatortoolitem4">- <property name="visible">True</property>- <property name="can_focus">False</property>- </object>- <packing>- <property name="expand">False</property>- </packing>- </child>- <child>- <object class="GtkToggleToolButton" id="cpus_showlabels">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="tooltip_text" translatable="yes">Display labels</property>- <property name="use_action_appearance">False</property>- <property name="label" translatable="yes">Show labels</property>- <property name="use_underline">True</property>- <property name="stock_id">gtk-info</property>- </object>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child> </object> <packing> <property name="expand">False</property>@@ -530,32 +681,50 @@ <property name="events">GDK_KEY_PRESS_MASK | GDK_KEY_RELEASE_MASK | GDK_STRUCTURE_MASK</property> <property name="resize_mode">queue</property> <child>- <object class="GtkHBox" id="hbox1">+ <object class="GtkTable" id="table2"> <property name="visible">True</property> <property name="can_focus">False</property>+ <property name="n_rows">2</property>+ <property name="n_columns">2</property> <child>- <object class="GtkDrawingArea" id="timeline_labels_drawingarea">- <property name="width_request">100</property>+ <object class="GtkDrawingArea" id="timeline_yscale_area">+ <property name="width_request">110</property> <property name="visible">True</property> <property name="can_focus">False</property> </object> <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">0</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="x_options">GTK_SHRINK</property> </packing> </child> <child>+ <object class="GtkDrawingArea" id="timeline_xscale_area">+ <property name="height_request">38</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="y_options">GTK_SHRINK</property>+ </packing>+ </child>+ <child> <object class="GtkDrawingArea" id="timeline_drawingarea"> <property name="visible">True</property> <property name="can_focus">True</property> </object> <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">1</property>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property> </packing> </child>+ <child>+ <placeholder/>+ </child> </object> </child> </object>@@ -577,86 +746,374 @@ </packing> </child> <child>- <object class="GtkVBox" id="eventsbox">+ <object class="GtkNotebook" id="eventsbox"> <property name="visible">True</property>- <property name="can_focus">False</property>+ <property name="can_focus">True</property> <child>- <object class="GtkLabel" id="label4">- <property name="visible">True</property>+ <object class="GtkScrolledWindow" id="scrolledwindowSummary">+ <property name="can_focus">True</property>+ <property name="no_show_all">True</property>+ <property name="hscrollbar_policy">automatic</property>+ <property name="vscrollbar_policy">automatic</property>+ <child>+ <object class="GtkLayout" id="eventsLayoutSummary">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="reorderable">True</property>+ </packing>+ </child>+ <child type="tab">+ <object class="GtkLabel" id="label7"> <property name="can_focus">False</property>- <property name="xalign">0</property>- <property name="xpad">4</property>- <property name="ypad">4</property>- <property name="label" translatable="yes"><b>Events</b></property>- <property name="use_markup">True</property>+ <property name="no_show_all">True</property>+ <property name="label" translatable="yes">Summary stats</property> </object> <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">0</property>+ <property name="tab_fill">False</property> </packing> </child> <child>- <object class="GtkEntry" id="events_entry">+ <object class="GtkScrolledWindow" id="scrolledwindow3"> <property name="visible">True</property> <property name="can_focus">True</property>- <property name="invisible_char">●</property>- <property name="width_chars">20</property>- <property name="secondary_icon_stock">gtk-find</property>- <property name="primary_icon_activatable">False</property>- <property name="secondary_icon_activatable">False</property>- <property name="primary_icon_sensitive">True</property>- <property name="secondary_icon_sensitive">True</property>- <property name="secondary_icon_tooltip_text">Search for event</property>+ <property name="hscrollbar_policy">automatic</property>+ <property name="vscrollbar_policy">automatic</property>+ <child>+ <object class="GtkViewport" id="viewport1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkTable" id="table4">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="border_width">4</property>+ <property name="n_rows">5</property>+ <property name="n_columns">2</property>+ <property name="column_spacing">8</property>+ <property name="row_spacing">4</property>+ <child>+ <object class="GtkLabel" id="label9">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="label" translatable="yes">Executable:</property>+ </object>+ <packing>+ <property name="x_options">GTK_FILL</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="label10">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="label" translatable="yes">Arguments:</property>+ </object>+ <packing>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="x_options">GTK_FILL</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="label11">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="label" translatable="yes">Start time:</property>+ </object>+ <packing>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ <property name="x_options">GTK_FILL</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="label12">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="label" translatable="yes">RTS Id:</property>+ </object>+ <packing>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ <property name="x_options">GTK_FILL</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="label13">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="label" translatable="yes">Environment:</property>+ </object>+ <packing>+ <property name="top_attach">4</property>+ <property name="bottom_attach">5</property>+ <property name="x_options">GTK_FILL</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="labelProgName">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">The name and path of the program's executable file</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="selectable">True</property>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="labelProgStartTime">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">The time at which the program was started</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="selectable">True</property>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkScrolledWindow" id="scrolledwindow4">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="hscrollbar_policy">automatic</property>+ <property name="vscrollbar_policy">automatic</property>+ <child>+ <object class="GtkTreeView" id="treeviewProgArguments">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">The arguments supplied when the program was run</property>+ <property name="headers_visible">False</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ </packing>+ </child>+ <child>+ <object class="GtkScrolledWindow" id="scrolledwindow5">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="hscrollbar_policy">automatic</property>+ <property name="vscrollbar_policy">automatic</property>+ <child>+ <object class="GtkTreeView" id="treeviewProgEnvironment">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">The environment variables available when the program was started</property>+ <property name="headers_visible">False</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">4</property>+ <property name="bottom_attach">5</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="labelProgRtsIdentifier">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="tooltip_text" translatable="yes">The name and version of the compiler/runtime used by the program</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="selectable">True</property>+ </object>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ <property name="y_options">GTK_FILL</property>+ </packing>+ </child>+ </object>+ </child>+ </object>+ </child> </object> <packing>- <property name="expand">False</property>- <property name="fill">True</property> <property name="position">1</property> </packing> </child>+ <child type="tab">+ <object class="GtkLabel" id="label8">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Startup info</property>+ </object>+ <packing>+ <property name="position">1</property>+ <property name="tab_fill">False</property>+ </packing>+ </child> <child>- <object class="GtkHBox" id="eventsHBox">- <property name="height_request">120</property>+ <object class="GtkTable" id="table3"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="spacing">3</property>+ <property name="n_columns">2</property> <child>- <object class="GtkViewport" id="viewport2">+ <object class="GtkDrawingArea" id="timeline_yscale_area2">+ <property name="width_request">110</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="resize_mode">queue</property>- <child>- <object class="GtkDrawingArea" id="eventsDrawingArea">- <property name="visible">True</property>- <property name="can_focus">True</property>- </object>- </child> </object> <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">0</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="x_options">GTK_SHRINK</property> </packing> </child> <child>- <object class="GtkVScrollbar" id="eventsVScroll">+ <object class="GtkDrawingArea" id="histogram_drawingarea"> <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="adjustment">adjustment1</property>+ <property name="can_focus">True</property> </object> <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ </child>+ </object>+ <packing>+ <property name="position">2</property>+ <property name="reorderable">True</property>+ </packing>+ </child>+ <child type="tab">+ <object class="GtkLabel" id="label6">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Spark sizes</property>+ </object>+ <packing>+ <property name="position">2</property>+ <property name="tab_fill">False</property>+ </packing>+ </child>+ <child>+ <object class="GtkVBox" id="eventsbox_old">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkEntry" id="events_entry">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="invisible_char">●</property>+ <property name="width_chars">20</property>+ <property name="secondary_icon_stock">gtk-find</property>+ <property name="primary_icon_activatable">False</property>+ <property name="secondary_icon_activatable">False</property>+ <property name="primary_icon_sensitive">True</property>+ <property name="secondary_icon_sensitive">True</property>+ <property name="secondary_icon_tooltip_text">Search for event</property>+ </object>+ <packing> <property name="expand">False</property> <property name="fill">True</property> <property name="position">1</property> </packing> </child>+ <child>+ <object class="GtkHBox" id="eventsHBox">+ <property name="height_request">120</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="spacing">3</property>+ <child>+ <object class="GtkViewport" id="viewport2">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="resize_mode">queue</property>+ <child>+ <object class="GtkDrawingArea" id="eventsDrawingArea">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkVScrollbar" id="eventsVScroll">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="adjustment">adjustment1</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">2</property>+ </packing>+ </child> </object> <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="padding">3</property>- <property name="position">2</property>+ <property name="position">3</property>+ <property name="reorderable">True</property>+ </packing>+ </child>+ <child type="tab">+ <object class="GtkLabel" id="label4">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Raw events</property>+ </object>+ <packing>+ <property name="position">3</property>+ <property name="tab_fill">False</property> </packing> </child> </object>