threadscope 0.1.3 → 0.2.0
raw patch · 64 files changed
+6003/−4484 lines, 64 filesdep +glibdep +pangodep −gladedep ~ghc-eventsdep ~gtkdep ~unixsetup-changednew-uploader
Dependencies added: glib, pango
Dependencies removed: glade
Dependency ranges changed: ghc-events, gtk, unix
Files
- About.hs +0/−35
- CairoDrawing.hs +0/−96
- EventDuration.hs +0/−176
- EventTree.hs +0/−272
- Events/EventDuration.hs +177/−0
- Events/EventTree.hs +270/−0
- Events/HECs.hs +53/−0
- Events/ReadEvents.hs +152/−0
- Events/SparkStats.hs +101/−0
- Events/SparkTree.hs +261/−0
- Events/TestEvents.hs +332/−0
- EventsWindow.hs +0/−269
- FileDialog.hs +0/−29
- GUI/BookmarkView.hs +128/−0
- GUI/ConcurrencyControl.hs +66/−0
- GUI/Dialogs.hs +164/−0
- GUI/EventsView.hs +343/−0
- GUI/GtkExtras.hs +83/−0
- GUI/KeyView.hs +101/−0
- GUI/Main.hs +411/−0
- GUI/MainWindow.hs +201/−0
- GUI/ProgressView.hs +122/−0
- GUI/SaveAs.hs +39/−0
- GUI/Timeline.hs +317/−0
- GUI/Timeline/Activity.hs +173/−0
- GUI/Timeline/CairoDrawing.hs +96/−0
- GUI/Timeline/HEC.hs +259/−0
- GUI/Timeline/Motion.hs +128/−0
- GUI/Timeline/Render.hs +329/−0
- GUI/Timeline/Render/Constants.hs +52/−0
- GUI/Timeline/Sparks.hs +264/−0
- GUI/Timeline/Ticks.hs +149/−0
- GUI/Timeline/Types.hs +25/−0
- GUI/TraceView.hs +170/−0
- GUI/Types.hs +31/−0
- GUI/ViewerColours.hs +130/−0
- Main.hs +82/−0
- Options.hs +0/−26
- ReadEvents.hs +0/−190
- SaveAsPDF.hs +0/−42
- SaveAsPNG.hs +0/−45
- Setup.hs +1/−1
- ShowEvents.hs +0/−62
- Sidebar.hs +0/−89
- State.hs +0/−125
- TestEvents.hs +0/−332
- ThreadScope.hs +0/−271
- Timeline.hs +0/−182
- Timeline/Activity.hs +0/−177
- Timeline/HEC.hs +0/−253
- Timeline/Key.hs +0/−74
- Timeline/Motion.hs +0/−147
- Timeline/Render.hs +0/−355
- Timeline/Render/Constants.hs +0/−51
- Timeline/RenderBookmarks.hs +0/−42
- Timeline/Ticks.hs +0/−150
- Timeline/WithViewScale.hs +0/−18
- Traces.hs +0/−55
- Utils.hs +0/−15
- ViewerColours.hs +0/−122
- ghcrts.c +0/−1
- threadscope.cabal +92/−75
- threadscope.glade +0/−707
- threadscope.ui +701/−0
− About.hs
@@ -1,35 +0,0 @@-------------------------------------------------------------------------------- ---- $Id: About.hs#1 2009/03/20 13:27:50 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/About.hs $ -------------------------------------------------------------------------------- - -module About where - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Paths_threadscope -import Data.Version (showVersion) - -------------------------------------------------------------------------------- - -showAboutDialog :: Window -> IO () -showAboutDialog parent - = do aboutDialog <- aboutDialogNew - logoPath <- getDataFileName "threadscope.png" - logo <- pixbufNewFromFile logoPath - set aboutDialog [ - aboutDialogName := "ThreadScope", - aboutDialogVersion := showVersion version, - aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.", - aboutDialogComments := "A GHC eventlog profile viewer", - aboutDialogAuthors := ["Donnie Jones (donnie@darthik.com)", - "Simon Marlow (simonm@microsoft.com)", - "Satnam Singh (s.singh@ieee.org)"], - aboutDialogLogo := Just logo, - aboutDialogWebsite := "http://research.microsoft.com/threadscope" - ] - windowSetTransientFor aboutDialog parent - afterResponse aboutDialog $ \_ -> widgetDestroy aboutDialog - widgetShow aboutDialog - --------------------------------------------------------------------------------
− CairoDrawing.hs
@@ -1,96 +0,0 @@-------------------------------------------------------------------------------- ---- $Id: CairoDrawing.hs#3 2009/07/18 22:48:30 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/CairoDrawing.hs $ -------------------------------------------------------------------------------- - -module CairoDrawing -where - -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C -import Control.Monad - -------------------------------------------------------------------------------- - -{-# INLINE draw_line #-} -draw_line :: (Integral a, Integral b, Integral c, Integral d) => - (a, b) -> (c, d) -> Render () -draw_line (x0, y0) (x1, y1) - = do move_to (x0, y0) - lineTo (fromIntegral x1) (fromIntegral y1) - stroke - -{-# INLINE move_to #-} -move_to :: (Integral a, Integral b) => (a, b) -> Render () -move_to (x, y) - = moveTo (fromIntegral x) (fromIntegral y) - -{-# INLINE rel_line_to #-} -rel_line_to :: (Integral a, Integral b) => (a, b) -> Render () -rel_line_to (x, y) - = relLineTo (fromIntegral x) (fromIntegral y) - -------------------------------------------------------------------------------- - -{-# INLINE draw_rectangle #-} -draw_rectangle :: (Integral x, Integral y, Integral w, Integral h) - => x -> y -> w -> h - -> Render () -draw_rectangle x y w h = do - rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - C.fill - -------------------------------------------------------------------------------- - -{-# INLINE draw_outlined_rectangle #-} -draw_outlined_rectangle :: (Integral x, Integral y, Integral w, Integral h) - => x -> y -> w -> h - -> Render () -draw_outlined_rectangle x y w h = do - rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - fillPreserve - setLineWidth 1 - setSourceRGBA 0 0 0 0.7 - stroke - -------------------------------------------------------------------------------- - -{-# INLINE draw_rectangle_opt #-} -draw_rectangle_opt :: (Integral x, Integral y, Integral w, Integral h) - => Bool -> x -> y -> w -> h - -> Render () -draw_rectangle_opt opt x y w h - = draw_rectangle_opt' opt (fromIntegral x) (fromIntegral y) - (fromIntegral w) (fromIntegral h) - -draw_rectangle_opt' :: Bool -> Double -> Double -> Double -> Double - -> Render () -draw_rectangle_opt' opt x y w h - = do rectangle x y (1.0 `max` w) h - C.fill - when opt $ do - setLineWidth 1 - setSourceRGBA 0 0 0 0.7 - rectangle x y w h - stroke - -------------------------------------------------------------------------------- - -{-# INLINE draw_rectangle_outline #-} -draw_rectangle_outline :: (Integral x, Integral y, Integral w, Integral h) - => x -> y -> w -> h - -> Render () -draw_rectangle_outline x y w h = do - setLineWidth 2 - rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - stroke - -------------------------------------------------------------------------------- - -clearWhite :: Render () -clearWhite = do - save - setOperator OperatorSource - setSourceRGBA 0xffff 0xffff 0xffff 0xffff - paint - restore
− EventDuration.hs
@@ -1,176 +0,0 @@--- This module supports a duration-based data-type to represent thread --- execution and GC information. - -module EventDuration ( - EventDuration(..), - isGCDuration, - startTimeOf, endTimeOf, durationOf, - eventsToDurations, - isDiscreteEvent - ) where - --- Imports for GHC Events -import qualified GHC.RTS.Events as GHC -import GHC.RTS.Events hiding (Event,GCWork,GCIdle) - -------------------------------------------------------------------------------- --- This datastructure is a duration-based representation of the event --- loginformation where thread-runs and GCs are explicitly represented --- by a single constructor identifying their start and end points. - -data EventDuration - = ThreadRun {-#UNPACK#-}!ThreadId - ThreadStopStatus - {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCStart {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCWork {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCIdle {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCEnd {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - deriving Show - -{- - GCStart GCWork GCIdle GCEnd - gc start -----> work -----> idle ------+> done -----> gc end - | | - `-------<-------<-----' --} - -isGCDuration :: EventDuration -> Bool -isGCDuration GCStart{} = True -isGCDuration GCWork{} = True -isGCDuration GCIdle{} = True -isGCDuration GCEnd{} = True -isGCDuration _ = False - -------------------------------------------------------------------------------- --- The start time of an event. - -startTimeOf :: EventDuration -> Timestamp -startTimeOf ed - = case ed of - ThreadRun _ _ startTime _ -> startTime - GCStart startTime _ -> startTime - GCWork startTime _ -> startTime - GCIdle startTime _ -> startTime - GCEnd startTime _ -> startTime - -------------------------------------------------------------------------------- --- The emd time of an event. - -endTimeOf :: EventDuration -> Timestamp -endTimeOf ed - = case ed of - ThreadRun _ _ _ endTime -> endTime - GCStart _ endTime -> endTime - GCWork _ endTime -> endTime - GCIdle _ endTime -> endTime - GCEnd _ endTime -> endTime - -------------------------------------------------------------------------------- --- The duration of an EventDuration - -durationOf :: EventDuration -> Timestamp -durationOf ed = endTimeOf ed - startTimeOf ed - -------------------------------------------------------------------------------- - -eventsToDurations :: [GHC.Event] -> [EventDuration] -eventsToDurations [] = [] -eventsToDurations (event : events) = - case spec event of - RunThread{thread=t} -> runDuration t : rest - StopThread{} -> rest - StartGC -> gcStart (time event) events - EndGC{} -> rest - _otherEvent -> rest - where - rest = eventsToDurations events - - runDuration t = ThreadRun t s (time event) endTime - where (endTime, s) = case findRunThreadTime events of - Nothing -> error $ "findRunThreadTime for " ++ (show event) - Just x -> x - -isDiscreteEvent :: GHC.Event -> Bool -isDiscreteEvent e = - case spec e of - RunThread{} -> False - StopThread{} -> False - StartGC{} -> False - EndGC{} -> False - GHC.GCWork{} -> False - GHC.GCIdle{} -> False - GHC.GCDone{} -> False - _ -> True - -gcStart :: Timestamp -> [GHC.Event] -> [EventDuration] -gcStart t0 [] = [] -gcStart t0 (event : events) = - case spec event of - GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events - GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events - GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events - GHC.EndGC{} -> GCStart t0 t1 : eventsToDurations events - RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -gcWork :: Timestamp -> [GHC.Event] -> [EventDuration] -gcWork t0 [] = [] -gcWork t0 (event : events) = - case spec event of - GHC.GCWork{} -> gcWork t0 events - GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events - GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events - GHC.EndGC{} -> GCWork t0 t1 : eventsToDurations events - RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -gcIdle :: Timestamp -> [GHC.Event] -> [EventDuration] -gcIdle t0 [] = [] -gcIdle t0 (event : events) = - case spec event of - GHC.GCIdle{} -> gcIdle t0 events - GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events - GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events - GHC.EndGC{} -> GCIdle t0 t1 : eventsToDurations events - RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -gcDone :: Timestamp -> [GHC.Event] -> [EventDuration] -gcDone t0 [] = [] -gcDone t0 (event : events) = - case spec event of - GHC.GCDone{} -> gcDone t0 events - GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events - GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events - GHC.EndGC{} -> GCEnd t0 t1 : eventsToDurations events - RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -------------------------------------------------------------------------------- - -findRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus) -findRunThreadTime [] = Nothing -findRunThreadTime (e : es) - = case spec e of - StopThread{status=s} -> Just (time e, s) - _ -> findRunThreadTime es - --------------------------------------------------------------------------------
− EventTree.hs
@@ -1,272 +0,0 @@-module EventTree (- DurationTree(..),- mkDurationTree,-- runTimeOf, gcTimeOf,- reportDurationTree,- durationTreeCountNodes,- durationTreeMaxDepth,-- EventTree(..), EventNode(..),- mkEventTree,- reportEventTree, eventTreeMaxDepth,- ) where--import EventDuration--import qualified GHC.RTS.Events as GHC-import GHC.RTS.Events hiding (Event)--import Data.List--- import Debug.Trace-import Text.Printf------------------------------------------------------------------------------------- We map the events onto a binary search tree, so that we can easily--- find the events that correspond to a particular view of the--- timeline. Additionally, each node of the tree contains a summary--- of the information below it, so that we can render views at various--- levels of resolution. For example, if a tree node would represent--- less than one pixel on the display, there is no point is descending--- the tree further.---- We only split at event boundaries; we never split an event into--- multiple pieces. Therefore, the binary tree is only roughly split--- by time, the actual split depends on the distribution of events--- below it.--data DurationTree- = DurationSplit- {-#UNPACK#-}!Timestamp -- The start time of this run-span- {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts- {-#UNPACK#-}!Timestamp -- The end time of this run-span- DurationTree -- The LHS split; all events lie completely between- -- start and split- DurationTree -- The RHS split; all events lie completely between- -- split and end- {-#UNPACK#-}!Timestamp -- The total amount of time spent running a thread- {-#UNPACK#-}!Timestamp -- The total amount of time spend in GC-- | DurationTreeLeaf- EventDuration-- | DurationTreeEmpty-- deriving Show-----------------------------------------------------------------------------------mkDurationTree :: [EventDuration] -> Timestamp -> DurationTree-mkDurationTree es endTime = - -- trace (show tree) $- tree- where- tree = splitDurations es endTime--splitDurations :: [EventDuration] -- events- -> 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--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-- | 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 - DurationSplit startTime- lhs_end- endTime - ltree- rtree- runTime- gcTime- where- startTime = startTimeOf (head es)- splitTime = startTime + (endTime - startTime) `div` 2-- (lhs, lhs_end, rhs) = splitDurationList es [] splitTime 0-- ltree = splitDurations lhs lhs_end- rtree = splitDurations rhs endTime-- runTime = runTimeOf ltree + runTimeOf rtree- gcTime = gcTimeOf ltree + gcTimeOf rtree---splitDurationList :: [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- -- have at least one event on each side of the split.-splitDurationList (e:es) acc !tsplit !tmax- | tstart < tsplit -- pick all events that start before the split- = splitDurationList es (e:acc) tsplit (max tmax tend)- | otherwise- = (reverse acc, tmax, e:es)- where- tstart = startTimeOf e- tend = endTimeOf e-----------------------------------------------------------------------------------runTimeOf :: DurationTree -> Timestamp-runTimeOf (DurationSplit _ _ _ _ _ runTime _) = runTime-runTimeOf (DurationTreeLeaf e) | ThreadRun{} <- e = durationOf e-runTimeOf _ = 0-----------------------------------------------------------------------------------gcTimeOf :: DurationTree -> Timestamp-gcTimeOf (DurationSplit _ _ _ _ _ _ gcTime) = gcTime-gcTimeOf (DurationTreeLeaf e) | isGCDuration e = durationOf e-gcTimeOf _ = 0-----------------------------------------------------------------------------------reportDurationTree :: Int -> DurationTree -> IO ()-reportDurationTree hecNumber eventTree- = putStrLn ("HEC " ++ show hecNumber ++ reportText)- where- reportText = " nodes = " ++ show (durationTreeCountNodes eventTree) ++ - " max depth = " ++ show (durationTreeMaxDepth eventTree)-----------------------------------------------------------------------------------durationTreeCountNodes :: DurationTree -> Int-durationTreeCountNodes (DurationSplit _ _ _ lhs rhs _ _)- = 1 + durationTreeCountNodes lhs + durationTreeCountNodes rhs-durationTreeCountNodes _ = 1-----------------------------------------------------------------------------------durationTreeMaxDepth :: DurationTree -> Int-durationTreeMaxDepth (DurationSplit _ _ _ lhs rhs _ _)- = 1 + durationTreeMaxDepth lhs `max` durationTreeMaxDepth rhs-durationTreeMaxDepth _ = 1-----------------------------------------------------------------------------------data EventTree- = EventTree - {-#UNPACK#-}!Timestamp -- The start time of this run-span- {-#UNPACK#-}!Timestamp -- The end time of this run-span- EventNode--data EventNode- = EventSplit- {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts- EventNode -- The LHS split; all events lie completely between- -- start and split- EventNode -- The RHS split; all events lie completely between- -- split and end-- | EventTreeLeaf [GHC.Event]- -- sometimes events happen "simultaneously" (at the same time- -- given the resolution of our clock source), so we can't- -- separate them.-- | EventTreeOne GHC.Event- -- This is a space optimisation for the common case of- -- EventTreeLeaf [e].--mkEventTree :: [GHC.Event] -> Timestamp -> EventTree-mkEventTree es endTime = - EventTree s e $- -- trace (show tree) $- tree- where- tree = splitEvents es endTime- (s,e) = if null es then (0,0) else (time (head es), endTime)--splitEvents :: [GHC.Event] -- events- -> Timestamp -- end time of last event in the list- -> EventNode-splitEvents [] !_endTime = - -- if len /= 0 then error "splitEvents0" else- EventTreeLeaf [] -- The case for an empty list of events--splitEvents [e] !_endTime =- EventTreeOne e--splitEvents es !endTime- | duration == 0- = EventTreeLeaf es-- | null rhs- = 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)-- | 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 - EventSplit (time (head rhs))- ltree- rtree- where- startTime = time (head es)- splitTime = startTime + (endTime - startTime) `div` 2- duration = endTime - startTime-- (lhs, lhs_end, rhs) = splitEventList es [] splitTime 0-- ltree = splitEvents lhs lhs_end- rtree = splitEvents rhs endTime---splitEventList :: [GHC.Event]- -> [GHC.Event]- -> Timestamp- -> Timestamp- -> ([GHC.Event], Timestamp, [GHC.Event])-splitEventList [] acc !tsplit !tmax- = (reverse acc, tmax, [])-splitEventList (e:es) acc !tsplit !tmax- | t < tsplit -- pick all events that start before the split- = splitEventList es (e:acc) tsplit (max tmax t)- | otherwise- = (reverse acc, tmax, e:es)- where- t = time e-----------------------------------------------------------------------------------reportEventTree :: Int -> EventTree -> IO ()-reportEventTree hecNumber (EventTree _ _ eventTree)- = putStrLn ("HEC " ++ show hecNumber ++ reportText)- where- reportText = " nodes = " ++ show (eventTreeCountNodes eventTree) ++ - " max depth = " ++ show (eventNodeMaxDepth eventTree)-----------------------------------------------------------------------------------eventTreeCountNodes :: EventNode -> Int-eventTreeCountNodes (EventSplit _ lhs rhs)- = 1 + eventTreeCountNodes lhs + eventTreeCountNodes rhs-eventTreeCountNodes _ = 1-----------------------------------------------------------------------------------eventTreeMaxDepth :: EventTree -> Int-eventTreeMaxDepth (EventTree _ _ t) = eventNodeMaxDepth t--eventNodeMaxDepth :: EventNode -> Int-eventNodeMaxDepth (EventSplit _ lhs rhs)- = 1 + eventNodeMaxDepth lhs `max` eventNodeMaxDepth rhs-eventNodeMaxDepth _ = 1
+ Events/EventDuration.hs view
@@ -0,0 +1,177 @@+-- This module supports a duration-based data-type to represent thread+-- execution and GC information.++module Events.EventDuration (+ EventDuration(..),+ isGCDuration,+ startTimeOf, endTimeOf, durationOf,+ eventsToDurations,+ isDiscreteEvent+ ) where++-- Imports for GHC Events+import qualified GHC.RTS.Events as GHC+import GHC.RTS.Events hiding (Event,GCWork,GCIdle)++-------------------------------------------------------------------------------+-- This datastructure is a duration-based representation of the event+-- loginformation where thread-runs and GCs are explicitly represented+-- by a single constructor identifying their start and end points.++data EventDuration+ = ThreadRun {-#UNPACK#-}!ThreadId+ ThreadStopStatus+ {-#UNPACK#-}!Timestamp+ {-#UNPACK#-}!Timestamp++ | GCStart {-#UNPACK#-}!Timestamp+ {-#UNPACK#-}!Timestamp++ | GCWork {-#UNPACK#-}!Timestamp+ {-#UNPACK#-}!Timestamp++ | GCIdle {-#UNPACK#-}!Timestamp+ {-#UNPACK#-}!Timestamp++ | GCEnd {-#UNPACK#-}!Timestamp+ {-#UNPACK#-}!Timestamp+ deriving Show++{-+ GCStart GCWork GCIdle GCEnd+ gc start -----> work -----> idle ------+> done -----> gc end+ | |+ `-------<-------<-----'+-}++isGCDuration :: EventDuration -> Bool+isGCDuration GCStart{} = True+isGCDuration GCWork{} = True+isGCDuration GCIdle{} = True+isGCDuration GCEnd{} = True+isGCDuration _ = False++-------------------------------------------------------------------------------+-- The start time of an event.++startTimeOf :: EventDuration -> Timestamp+startTimeOf ed+ = case ed of+ ThreadRun _ _ startTime _ -> startTime+ GCStart startTime _ -> startTime+ GCWork startTime _ -> startTime+ GCIdle startTime _ -> startTime+ GCEnd startTime _ -> startTime++-------------------------------------------------------------------------------+-- The emd time of an event.++endTimeOf :: EventDuration -> Timestamp+endTimeOf ed+ = case ed of+ ThreadRun _ _ _ endTime -> endTime+ GCStart _ endTime -> endTime+ GCWork _ endTime -> endTime+ GCIdle _ endTime -> endTime+ GCEnd _ endTime -> endTime++-------------------------------------------------------------------------------+-- The duration of an EventDuration++durationOf :: EventDuration -> Timestamp+durationOf ed = endTimeOf ed - startTimeOf ed++-------------------------------------------------------------------------------++eventsToDurations :: [GHC.Event] -> [EventDuration]+eventsToDurations [] = []+eventsToDurations (event : events) =+ case spec event of+ RunThread{thread=t} -> runDuration t : rest+ StopThread{} -> rest+ StartGC -> gcStart (time event) events+ EndGC{} -> rest+ _otherEvent -> rest+ where+ rest = eventsToDurations events++ runDuration t = ThreadRun t s (time event) endTime+ where (endTime, s) = case findRunThreadTime events of+ Nothing -> error $ "findRunThreadTime for " ++ (show event)+ Just x -> x++isDiscreteEvent :: GHC.Event -> Bool+isDiscreteEvent e =+ case spec e of+ RunThread{} -> False+ StopThread{} -> False+ StartGC{} -> False+ EndGC{} -> False+ GHC.GCWork{} -> False+ GHC.GCIdle{} -> False+ GHC.GCDone{} -> False+ GHC.SparkCounters{} -> False+ _ -> True++gcStart :: Timestamp -> [GHC.Event] -> [EventDuration]+gcStart _ [] = []+gcStart t0 (event : events) =+ case spec event of+ GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events+ GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events+ GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events+ GHC.EndGC{} -> GCStart t0 t1 : eventsToDurations events+ RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events)+ _other -> gcStart t0 events+ where+ t1 = time event++gcWork :: Timestamp -> [GHC.Event] -> [EventDuration]+gcWork _ [] = []+gcWork t0 (event : events) =+ case spec event of+ GHC.GCWork{} -> gcWork t0 events+ GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events+ GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events+ GHC.EndGC{} -> GCWork t0 t1 : eventsToDurations events+ RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events)+ _other -> gcStart t0 events+ where+ t1 = time event++gcIdle :: Timestamp -> [GHC.Event] -> [EventDuration]+gcIdle _ [] = []+gcIdle t0 (event : events) =+ case spec event of+ GHC.GCIdle{} -> gcIdle t0 events+ GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events+ GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events+ GHC.EndGC{} -> GCIdle t0 t1 : eventsToDurations events+ RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events)+ _other -> gcStart t0 events+ where+ t1 = time event++gcDone :: Timestamp -> [GHC.Event] -> [EventDuration]+gcDone _ [] = []+gcDone t0 (event : events) =+ case spec event of+ GHC.GCDone{} -> gcDone t0 events+ GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events+ GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events+ GHC.EndGC{} -> GCEnd t0 t1 : eventsToDurations events+ RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events)+ _other -> gcStart t0 events+ where+ t1 = time event++-------------------------------------------------------------------------------++findRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus)+findRunThreadTime [] = Nothing+findRunThreadTime (e : es)+ = case spec e of+ StopThread{status=s} -> Just (time e, s)+ _ -> findRunThreadTime es++-------------------------------------------------------------------------------
+ Events/EventTree.hs view
@@ -0,0 +1,270 @@+module Events.EventTree (+ DurationTree(..),+ mkDurationTree,++ runTimeOf, gcTimeOf,+ reportDurationTree,+ durationTreeCountNodes,+ durationTreeMaxDepth,++ EventTree(..), EventNode(..),+ mkEventTree,+ reportEventTree, eventTreeMaxDepth,+ ) where++import Events.EventDuration++import qualified GHC.RTS.Events as GHC+import GHC.RTS.Events hiding (Event)++import Text.Printf++-------------------------------------------------------------------------------++-- We map the events onto a binary search tree, so that we can easily+-- find the events that correspond to a particular view of the+-- timeline. Additionally, each node of the tree contains a summary+-- of the information below it, so that we can render views at various+-- levels of resolution. For example, if a tree node would represent+-- less than one pixel on the display, there is no point is descending+-- the tree further.++-- We only split at event boundaries; we never split an event into+-- multiple pieces. Therefore, the binary tree is only roughly split+-- by time, the actual split depends on the distribution of events+-- below it.++data DurationTree+ = DurationSplit+ {-#UNPACK#-}!Timestamp -- The start time of this run-span+ {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts+ {-#UNPACK#-}!Timestamp -- The end time of this run-span+ DurationTree -- The LHS split; all events lie completely between+ -- start and split+ DurationTree -- The RHS split; all events lie completely between+ -- split and end+ {-#UNPACK#-}!Timestamp -- The total amount of time spent running a thread+ {-#UNPACK#-}!Timestamp -- The total amount of time spend in GC++ | DurationTreeLeaf+ EventDuration++ | DurationTreeEmpty++ deriving Show++-------------------------------------------------------------------------------++mkDurationTree :: [EventDuration] -> Timestamp -> DurationTree+mkDurationTree es endTime =+ -- trace (show tree) $+ tree+ where+ tree = splitDurations es endTime++splitDurations :: [EventDuration] -- events+ -> 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++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++ | 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+ DurationSplit startTime+ lhs_end+ endTime+ ltree+ rtree+ runTime+ gcTime+ where+ startTime = startTimeOf (head es)+ splitTime = startTime + (endTime - startTime) `div` 2++ (lhs, lhs_end, rhs) = splitDurationList es [] splitTime 0++ ltree = splitDurations lhs lhs_end+ rtree = splitDurations rhs endTime++ runTime = runTimeOf ltree + runTimeOf rtree+ gcTime = gcTimeOf ltree + gcTimeOf rtree+++splitDurationList :: [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+ -- have at least one event on each side of the split.+splitDurationList (e:es) acc !tsplit !tmax+ | tstart < tsplit -- pick all events that start before the split+ = splitDurationList es (e:acc) tsplit (max tmax tend)+ | otherwise+ = (reverse acc, tmax, e:es)+ where+ tstart = startTimeOf e+ tend = endTimeOf e++-------------------------------------------------------------------------------++runTimeOf :: DurationTree -> Timestamp+runTimeOf (DurationSplit _ _ _ _ _ runTime _) = runTime+runTimeOf (DurationTreeLeaf e) | ThreadRun{} <- e = durationOf e+runTimeOf _ = 0++-------------------------------------------------------------------------------++gcTimeOf :: DurationTree -> Timestamp+gcTimeOf (DurationSplit _ _ _ _ _ _ gcTime) = gcTime+gcTimeOf (DurationTreeLeaf e) | isGCDuration e = durationOf e+gcTimeOf _ = 0++-------------------------------------------------------------------------------++reportDurationTree :: Int -> DurationTree -> IO ()+reportDurationTree hecNumber eventTree+ = putStrLn ("HEC " ++ show hecNumber ++ reportText)+ where+ reportText = " nodes = " ++ show (durationTreeCountNodes eventTree) +++ " max depth = " ++ show (durationTreeMaxDepth eventTree)++-------------------------------------------------------------------------------++durationTreeCountNodes :: DurationTree -> Int+durationTreeCountNodes (DurationSplit _ _ _ lhs rhs _ _)+ = 1 + durationTreeCountNodes lhs + durationTreeCountNodes rhs+durationTreeCountNodes _ = 1++-------------------------------------------------------------------------------++durationTreeMaxDepth :: DurationTree -> Int+durationTreeMaxDepth (DurationSplit _ _ _ lhs rhs _ _)+ = 1 + durationTreeMaxDepth lhs `max` durationTreeMaxDepth rhs+durationTreeMaxDepth _ = 1++-------------------------------------------------------------------------------++data EventTree+ = EventTree+ {-#UNPACK#-}!Timestamp -- The start time of this run-span+ {-#UNPACK#-}!Timestamp -- The end time of this run-span+ EventNode++data EventNode+ = EventSplit+ {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts+ EventNode -- The LHS split; all events lie completely between+ -- start and split+ EventNode -- The RHS split; all events lie completely between+ -- split and end++ | EventTreeLeaf [GHC.Event]+ -- sometimes events happen "simultaneously" (at the same time+ -- given the resolution of our clock source), so we can't+ -- separate them.++ | EventTreeOne GHC.Event+ -- This is a space optimisation for the common case of+ -- EventTreeLeaf [e].++mkEventTree :: [GHC.Event] -> Timestamp -> EventTree+mkEventTree es endTime =+ EventTree s e $+ -- trace (show tree) $+ tree+ where+ tree = splitEvents es endTime+ (s,e) = if null es then (0,0) else (time (head es), endTime)++splitEvents :: [GHC.Event] -- events+ -> Timestamp -- end time of last event in the list+ -> EventNode+splitEvents [] !_endTime =+ -- if len /= 0 then error "splitEvents0" else+ EventTreeLeaf [] -- The case for an empty list of events++splitEvents [e] !_endTime =+ EventTreeOne e++splitEvents es !endTime+ | duration == 0+ = EventTreeLeaf es++ | null rhs+ = 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)++ | 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+ EventSplit (time (head rhs))+ ltree+ rtree+ where+ startTime = time (head es)+ splitTime = startTime + (endTime - startTime) `div` 2+ duration = endTime - startTime++ (lhs, lhs_end, rhs) = splitEventList es [] splitTime 0++ ltree = splitEvents lhs lhs_end+ rtree = splitEvents rhs endTime+++splitEventList :: [GHC.Event]+ -> [GHC.Event]+ -> Timestamp+ -> Timestamp+ -> ([GHC.Event], Timestamp, [GHC.Event])+splitEventList [] acc !_tsplit !tmax+ = (reverse acc, tmax, [])+splitEventList (e:es) acc !tsplit !tmax+ | t < tsplit -- pick all events that start before the split+ = splitEventList es (e:acc) tsplit (max tmax t)+ | otherwise+ = (reverse acc, tmax, e:es)+ where+ t = time e++-------------------------------------------------------------------------------++reportEventTree :: Int -> EventTree -> IO ()+reportEventTree hecNumber (EventTree _ _ eventTree)+ = putStrLn ("HEC " ++ show hecNumber ++ reportText)+ where+ reportText = " nodes = " ++ show (eventTreeCountNodes eventTree) +++ " max depth = " ++ show (eventNodeMaxDepth eventTree)++-------------------------------------------------------------------------------++eventTreeCountNodes :: EventNode -> Int+eventTreeCountNodes (EventSplit _ lhs rhs)+ = 1 + eventTreeCountNodes lhs + eventTreeCountNodes rhs+eventTreeCountNodes _ = 1++-------------------------------------------------------------------------------++eventTreeMaxDepth :: EventTree -> Int+eventTreeMaxDepth (EventTree _ _ t) = eventNodeMaxDepth t++eventNodeMaxDepth :: EventNode -> Int+eventNodeMaxDepth (EventSplit _ lhs rhs)+ = 1 + eventNodeMaxDepth lhs `max` eventNodeMaxDepth rhs+eventNodeMaxDepth _ = 1
+ Events/HECs.hs view
@@ -0,0 +1,53 @@+module Events.HECs (+ HECs(..),+ Event,+ CapEvent,+ Timestamp,++ eventIndexToTimestamp,+ timestampToEventIndex,+ extractUserMessages,+ ) where++import Events.EventTree+import Events.SparkTree+import GHC.RTS.Events++import Data.Array++-----------------------------------------------------------------------------++-- all the data from a .eventlog file+data HECs = HECs {+ hecCount :: Int,+ hecTrees :: [(DurationTree, EventTree, SparkTree)],+ hecEventArray :: Array Int CapEvent,+ hecLastEventTime :: Timestamp,+ maxSparkValue :: Double,+ maxSparkPool :: Double+ }++-----------------------------------------------------------------------------++eventIndexToTimestamp :: HECs -> Int -> Timestamp+eventIndexToTimestamp HECs{hecEventArray=arr} n =+ time (ce_event (arr ! n))++timestampToEventIndex :: HECs -> Timestamp -> Int+timestampToEventIndex HECs{hecEventArray=arr} ts =+ search l (r+1)+ where+ (l,r) = bounds arr++ search !l !r+ | (r - l) <= 1 = if ts > time (ce_event (arr!l)) then r else l+ | ts < tmid = search l mid+ | otherwise = search mid r+ where+ mid = l + (r - l) `quot` 2+ tmid = time (ce_event (arr!mid))++extractUserMessages :: HECs -> [(Timestamp, String)]+extractUserMessages hecs =+ [ (ts, msg)+ | CapEvent _ (Event ts (UserMessage msg)) <- elems (hecEventArray hecs) ]
+ Events/ReadEvents.hs view
@@ -0,0 +1,152 @@+module Events.ReadEvents (+ registerEventsFromFile, registerEventsFromTrace+ ) where++import Events.EventTree+import Events.SparkTree+import Events.HECs (HECs(..))+import Events.TestEvents+import Events.EventDuration+import qualified GUI.ProgressView as ProgressView+import GUI.ProgressView (ProgressView)++import qualified GHC.RTS.Events as GHCEvents+import GHC.RTS.Events hiding (Event)++import Data.Array+import Data.List+import Text.Printf+import System.FilePath+import Control.Monad+import Control.Exception++-------------------------------------------------------------------------------+-- The GHC.RTS.Events library returns the profile information+-- in a data-streucture which contains a list data structure+-- representing the events i.e. [GHCEvents.Event]+-- ThreadScope transforms this list into an alternative representation+-- which (for each HEC) records event *durations* which are ordered in time.+-- The durations represent the run-lengths for thread execution and+-- run-lengths for garbage colleciton. This data-structure is called+-- EventDuration.+-- ThreadScope then transformations this data-structure into another+-- data-structure which gives a binary-tree view of the event information+-- by performing a binary split on the time domain i.e. the EventTree+-- data structure.++-- GHCEvents.Event => [EventDuration] => EventTree++-------------------------------------------------------------------------------++rawEventsToHECs :: [(Maybe Int, [GHCEvents.Event])] -> Timestamp+ -> [((Double, Double), (DurationTree, EventTree, SparkTree))]+rawEventsToHECs eventList endTime+ = map (toTree . flip lookup heclists) [0 .. maximum0 (map fst heclists)]+ where+ heclists = [ (h,events) | (Just h,events) <- eventList ]++ toTree Nothing = ( (0, 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++-------------------------------------------------------------------------------++registerEventsFromFile :: String -> ProgressView -> IO (HECs, String, Int, Double)+registerEventsFromFile filename = registerEvents (Left filename)++registerEventsFromTrace :: String -> ProgressView -> IO (HECs, String, Int, Double)+registerEventsFromTrace traceName = registerEvents (Right traceName)++registerEvents :: Either FilePath String+ -> ProgressView+ -> IO (HECs, String, Int, Double)++registerEvents from progress = do++ let msg = case from of+ Left filename -> filename+ Right test -> test++ ProgressView.setTitle progress ("Loading " ++ takeFileName msg)++ buildEventLog progress from++-------------------------------------------------------------------------------++-- Runs in a background thread+--+buildEventLog :: ProgressView -> Either FilePath String -> IO (HECs, String, Int, Double)+buildEventLog progress from =+ case from of+ Right test -> build test (testTrace test)+ Left filename -> do+ stopPulse <- ProgressView.startPulse progress+ fmt <- readEventLogFromFile filename+ stopPulse+ case fmt of+ 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++ lastTx = maximum (0 : map eventBlockEnd (events (dat evs)))++ 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++ -- 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+ }++ 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 ()++ zipWithM_ treeProgress [0..] trees++ --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 * 1.0e-9)++-------------------------------------------------------------------------------
+ Events/SparkStats.hs view
@@ -0,0 +1,101 @@+module Events.SparkStats (+ SparkStats(rateCreated, rateDud, rateOverflowed,+ rateConverted, rateFizzled, rateGCd,+ meanPool, maxPool, minPool),+ initial, create, rescale, aggregate, agEx,+ ) where++import Data.Word (Word64)++-- | Sparks change state. Each state transition process has a duration.+-- Spark statistics, for a given duration, record the spark transition rate+-- (the number of sparks that enter a given state within the interval)+-- and the absolute mean, maximal and minimal number of sparks+-- in the spark pool within the duration.+data SparkStats =+ SparkStats { rateCreated, rateDud, rateOverflowed,+ rateConverted, rateFizzled, rateGCd,+ meanPool, maxPool, minPool :: {-# UNPACK #-}!Double }+ deriving (Show, Eq)++-- | Initial, default value of spark stats, at the start of runtime,+-- before any spark activity is recorded.+initial :: SparkStats+initial = SparkStats 0 0 0 0 0 0 0 0 0++-- | Create spark stats for a duration, given absolute+-- numbers of sparks in all categories at the start and end of the duration.+-- The units for spark transitions (first 6 counters) is [spark/duration]:+-- the fact that intervals may have different lenghts is ignored here.+-- The units for the pool stats are just [spark].+-- The values in the second counter have to be greater or equal+-- to the values in the first counter, except for the spark pool size.+-- For pool size, we take into account only the first sample,+-- to visualize more detail at high zoom levels, at the cost+-- of a slight shift of the graph. Mathematically, this corresponds+-- to taking the initial durations as centered around samples,+-- 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 (crt1, dud1, ovf1, cnv1, fiz1, gcd1, remaining1)+ (crt2, dud2, ovf2, cnv2, fiz2, gcd2, _remaining2) =+ let (crt, dud, ovf, cnv, fiz, gcd) =+ (fromIntegral $ crt2 - crt1,+ fromIntegral $ dud2 - dud1,+ fromIntegral $ ovf2 - ovf1,+ fromIntegral $ cnv2 - cnv1,+ fromIntegral $ fiz2 - fiz1,+ fromIntegral $ gcd2 - gcd1)+ p = fromIntegral remaining1+ in SparkStats crt dud ovf cnv fiz gcd p p p++-- | Reduce a list of spark stats; spark pool stats are overwritten.+foldStats :: (Double -> Double -> Double)+ -> Double -> Double -> Double+ -> [SparkStats] -> SparkStats+foldStats f meanP maxP minP l+ = SparkStats+ (foldr f 0 (map rateCreated l))+ (foldr f 0 (map rateDud l))+ (foldr f 0 (map rateOverflowed l))+ (foldr f 0 (map rateConverted l))+ (foldr f 0 (map rateFizzled l))+ (foldr f 0 (map rateGCd l))+ meanP maxP minP++-- | Rescale the spark transition stats, e.g., to change their units.+rescale :: Double -> SparkStats -> SparkStats+rescale scale s =+ let f w _ = scale * w+ in foldStats f (meanPool s) (maxPool s) (minPool s) [s]++-- | Derive spark stats for an interval from a list of spark stats,+-- in reverse chronological order, of consecutive subintervals+-- that sum up to the original interval.+aggregate :: [SparkStats] -> SparkStats+aggregate [s] = s -- optimization+aggregate l =+ let meanP = sum (map meanPool l) / fromIntegral (length l) -- TODO: inaccurate+ maxP = maximum (map maxPool l)+ minP = minimum (map minPool l)+ in foldStats (+) meanP maxP minP l++-- | Extrapolate spark stats from previous data.+-- Absolute pools size values extrapolate by staying constant,+-- rates of change of spark status extrapolate by dropping to 0+-- (which corresponds to absolute numbers of sparks staying constant).+extrapolate :: SparkStats -> SparkStats+extrapolate s =+ let f w _ = 0 * w+ in foldStats f (meanPool s) (maxPool s) (minPool s) [s]++-- | Aggregate, if any data provided. Extrapolate from previous data, otherwise.+-- In both cases, the second component is the new choice of "previous data".+-- The list of stats is expected in reverse chronological order,+-- as for aggregate.+agEx :: [SparkStats] -> SparkStats -> (SparkStats, SparkStats)+agEx [] s = (extrapolate s, s)+agEx l@(s:_) _ = (aggregate l, s)
+ Events/SparkTree.hs view
@@ -0,0 +1,261 @@+module Events.SparkTree (+ SparkTree,+ sparkTreeMaxDepth,+ emptySparkTree,+ eventsToSparkDurations,+ mkSparkTree,+ sparkProfile,+ ) where++import qualified Events.SparkStats as SparkStats++import qualified GHC.RTS.Events as GHC+import GHC.RTS.Events (Timestamp)++import Text.Printf+-- import Debug.Trace++-- | Sparks change state. Each state transition process has a duration.+-- SparkDuration is a condensed description of such a process,+-- containing a start time of the duration interval,+-- 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 }+ 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 es =+ let aux _startTime _startCounters [] = ((0, 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+ 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) =+ aux endTime endCounters events+ in ((max oldMaxSparkValue newMaxSparkValue,+ 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.+-- Additionally, each node of the tree contains a summary+-- of the information below it, so that we can render views at various+-- levels of resolution. For example, if a tree node would represent+-- less than one pixel on the display, there is no point is descending+-- the tree further.+data SparkTree+ = SparkTree+ {-#UNPACK#-}!Timestamp -- ^ start time of span represented by the tree+ {-#UNPACK#-}!Timestamp -- ^ end time of the span represented by the tree+ SparkNode+ deriving Show++data SparkNode+ = SparkSplit+ {-#UNPACK#-}!Timestamp -- ^ time used to split the span into two parts+ SparkNode+ -- ^ 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+ | SparkTreeLeaf+ 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++sparkTreeMaxDepth :: SparkTree -> Int+sparkTreeMaxDepth (SparkTree _ _ t) = sparkNodeMaxDepth t++sparkNodeMaxDepth :: SparkNode -> Int+sparkNodeMaxDepth (SparkSplit _ lhs rhs _)+ = 1 + sparkNodeMaxDepth lhs `max` sparkNodeMaxDepth rhs+sparkNodeMaxDepth _ = 1++emptySparkTree :: SparkTree+emptySparkTree = SparkTree 0 0 SparkTreeEmpty++-- | Create spark tree from spark durations.+-- Note that the last event may be not a spark event, in which case+-- 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+mkSparkTree es endTime =+ SparkTree s e $+ -- trace (show tree) $+ tree+ where+ tree = splitSparks es endTime+ (s, e) = if null es then (0, 0) else (startT (head es), endTime)++-- | Construct spark tree, by recursively splitting time intervals..+-- We only split at spark transition duration boundaries;+-- we never split a duration into multiple pieces.+-- Therefore, the binary tree is only roughly split by time,+-- the actual split depends on the distribution of sample points below it.+splitSparks :: [SparkDuration] -> Timestamp -> SparkNode+splitSparks [] !_endTime =+ SparkTreeEmpty++splitSparks [e] !_endTime =+ SparkTreeLeaf (deltaC e)++splitSparks es !endTime+ | 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)+ | 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))++ where+ startTime = startT $ head es+ splitTime = startTime + (endTime - startTime) `div` 2++ (lhs, lhs_end, rhs) = splitSparkList es [] splitTime 0++ ltree = splitSparks lhs lhs_end+ rtree = splitSparks rhs endTime++ subDelta (SparkSplit _ _ _ delta) = [delta]+ subDelta (SparkTreeLeaf delta) = [delta]+ subDelta SparkTreeEmpty = []+++splitSparkList :: [SparkDuration]+ -> [SparkDuration]+ -> Timestamp+ -> Timestamp+ -> ([SparkDuration], Timestamp, [SparkDuration])+splitSparkList [] acc !_tsplit !tmax+ = (reverse acc, tmax, [])+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))+ | otherwise+ = (reverse acc, tmax, e:es)+++-- | For each timeslice, give the spark stats calculated for that interval.+-- The spark stats are Approximated from the aggregated data+-- at the level of the spark tree covering intervals of the size+-- similar to the timeslice size.+sparkProfile :: Timestamp -> Timestamp -> Timestamp -> SparkTree+ -> [SparkStats.SparkStats]+sparkProfile slice start0 end0 t+ = {- trace (show flat) $ -} chopped++ where+ -- do an extra slice at both ends+ start = if start0 < slice then start0 else start0 - slice+ end = end0 + slice++ flat = flatten start t []+ -- TODO: redefine chop so that it's obvious this error will not happen+ -- e.g., catch pathological cases, like a tree with only SparkTreeEmpty+ -- inside and/or make it tail-recursive instead of+ -- taking the 'previous' argument+ chopped0 = chop (error "Fatal error in sparkProfile.") [] start flat++ chopped | start0 < slice = SparkStats.initial : chopped0+ | otherwise = chopped0++ flatten :: Timestamp -> SparkTree -> [SparkTree] -> [SparkTree]+ flatten _start (SparkTree _s _e SparkTreeEmpty) rest = rest+ flatten start t@(SparkTree s e (SparkSplit split l r _)) rest+ | e <= start = rest+ | end <= s = rest+ | start >= split = flatten start (SparkTree split e r) rest+ | end <= split = flatten start (SparkTree s split l) rest+ | e - s > slice = flatten start (SparkTree s split l) $+ flatten start (SparkTree split e r) rest+ -- A rule of thumb: if a node is narrower than slice, don't drill down,+ -- even if the node sits astride slice boundaries and so the readings+ -- for each of the two neigbouring slices will not be accurate+ -- (but for the pair as a whole, they will be). Smooths the curve down+ -- even more than averaging over the timeslice already does.+ | otherwise = t : rest+ flatten _start t@(SparkTree _s _e (SparkTreeLeaf _)) rest+ = t : rest++ chop :: SparkStats.SparkStats -> [SparkStats.SparkStats]+ -> Timestamp -> [SparkTree] -> [SparkStats.SparkStats]+ chop _previous sofar start1 _ts+ | start1 >= end+ = case sofar of+ _ : _ -> [SparkStats.aggregate sofar]+ [] -> []+ chop _previous sofar _start1 [] -- data too short for the redrawn area+ | null sofar -- no data at all in the redrawn area+ = []+ | otherwise+ = [SparkStats.aggregate sofar]+ chop previous sofar start1 (t : ts)+ | e <= start1 -- skipping data left of the slice+ = case sofar of+ _ : _ -> error "chop"+ [] -> chop previous sofar start1 ts+ | s >= start1 + slice -- postponing data right of the slice+ = let (c, p) = SparkStats.agEx sofar previous+ in c : chop p [] (start1 + slice) (t : ts)+ | e > start1 + slice+ = let (c, p) = SparkStats.agEx (created_in_this_slice t ++ sofar) previous+ in c : chop p [] (start1 + slice) (t : ts)+ | otherwise+ = chop previous (created_in_this_slice t ++ sofar) start1 ts+ where+ (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+ -- 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)++ -- Spark transitions in the tree are in units spark/duration.+ -- Here the numbers are rescaled so that the units are spark/ms.+ created_in_this_slice (SparkTree _ _ node) = case node of+ SparkTreeLeaf delta -> [SparkStats.rescale proportion delta]+ SparkTreeEmpty -> []+ SparkSplit _ _ _ delta -> [SparkStats.rescale proportion delta]
+ Events/TestEvents.hs view
@@ -0,0 +1,332 @@+module Events.TestEvents (testTrace)+where++import GHC.RTS.Events+import Data.Word++-------------------------------------------------------------------------------+++testTrace :: String -> EventLog+testTrace name = eventLog (test name)++-------------------------------------------------------------------------------++eventLog :: [Event] -> EventLog+eventLog events+ = EventLog (Header testEventTypes) (Data events)++-------------------------------------------------------------------------------++create :: Word16+create = 0++-------------------------------------------------------------------------------++runThread :: Word16+runThread = 1++-------------------------------------------------------------------------------++stop :: Word16+stop = 2++-------------------------------------------------------------------------------++runnable :: Word16+runnable = 3++-------------------------------------------------------------------------------++migrate :: Word16+migrate = 4++-------------------------------------------------------------------------------++runSpark :: Word16+runSpark = 5++-------------------------------------------------------------------------------++stealSpark :: Word16+stealSpark = 6++-------------------------------------------------------------------------------++shutdown :: Word16+shutdown = 7++-------------------------------------------------------------------------------++wakeup :: Word16+wakeup = 8++-------------------------------------------------------------------------------++startGC :: Word16+startGC = 9++------------------------------------------------------------------------------++finishGC :: Word16+finishGC = 10++------------------------------------------------------------------------------++reqSeqGC :: Word16+reqSeqGC = 11++------------------------------------------------------------------------------++reqParGC :: Word16+reqParGC = 12++------------------------------------------------------------------------------++createSparkThread :: Word16+createSparkThread = 15++------------------------------------------------------------------------------++logMessage :: Word16+logMessage = 16++------------------------------------------------------------------------------++startup :: Word16+startup = 17++------------------------------------------------------------------------------++blockMarker :: Word16+blockMarker = 18++------------------------------------------------------------------------------++testEventTypes :: [EventType]+testEventTypes+ = [EventType create "Create thread" (Just 8),+ EventType runThread "Run thread" (Just 8),+ EventType stop "Stop thread" (Just 10),+ EventType runnable "Thread runnable" (Just 8),+ EventType migrate "Migrate thread" (Just 10),+ EventType runSpark "Run spark" (Just 8),+ EventType stealSpark "Steal spark" (Just 10),+ EventType shutdown "Shutdown" (Just 0),+ EventType wakeup "Wakeup thread" (Just 10),+ EventType startGC "Start GC" (Just 0),+ EventType finishGC "Finish GC" (Just 0),+ EventType reqSeqGC "Request sequetial GC" (Just 0),+ EventType reqParGC "Reqpargc parallel GC" (Just 0),+ EventType createSparkThread "Create spark thread" (Just 8),+ EventType logMessage "Log message" Nothing,+ EventType startup "Startup" (Just 0),+ EventType blockMarker "Block marker" (Just 14)+ ]++-------------------------------------------------------------------------------+test :: String -> [Event]+-------------------------------------------------------------------------------++test "empty0"+ = [+ Event 0 (Startup 1)+ ]++-------------------------------------------------------------------------------+++test "empty1"+ = [+ Event 0 (Startup 1),+ Event 0 $ EventBlock 4000000 0 []+ ]++-------------------------------------------------------------------------------++test "test0"+ = [+ Event 0 (Startup 1),+ Event 0 $ EventBlock 4000000 0 [+ Event 4000000 Shutdown+ ]+ ]+-------------------------------------------------------------------------------++test "small"+ = [+ Event 0 (Startup 1),+ Event 0 $ EventBlock 4000000 0 [+ Event 1000000 (CreateThread 1),+ Event 2000000 (RunThread 1),+ Event 3000000 (StopThread 1 ThreadFinished),+ Event 4000000 (Shutdown)+ ]+ ]++-------------------------------------------------------------------------------++test "tick"+ = [-- A thread from 2s to 3s+ Event 0 (Startup 3),+ Event 0 $ EventBlock 4000000000 0 [+ Event 1000000000 (CreateThread 1),+ Event 2000000000 (RunThread 1),+ Event 3000000000 (StopThread 1 ThreadFinished),+ Event 4000000000 (Shutdown)+ ],+ -- A thread from 0.2ms to 0.3ms+ Event 0 $ EventBlock 4000000000 1 [+ Event 1000000 (CreateThread 2),+ Event 2000000 (RunThread 2),+ Event 3000000 (StopThread 2 ThreadFinished),+ Event 4000000 (Shutdown)+ ],+ -- A thread from 0.2us to 0.3us+ Event 0 $ EventBlock 4000000000 2 [+ Event 1000 (CreateThread 3),+ Event 2000 (RunThread 3),+ Event 3000 (StopThread 3 ThreadFinished),+ Event 4000 (Shutdown)+ ]+ ]++-------------------------------------------------------------------------------++test "tick2"+ = [-- A thread create but no run+ Event 0 (Startup 1),+ Event 0 $ EventBlock 4000000000 0 [+ Event 1000000000 (CreateThread 1),+ Event 4000000000 (Shutdown)+ ]+ ]++-------------------------------------------------------------------------------++test "tick3"+ = [-- A thread from 2s to 3s+ Event 0 (Startup 1),+ Event 0 $ EventBlock 4000000000 0 [+ Event 1000000000 (CreateThread 1),+ Event 2000000000 (RunThread 1),+ Event 3000000000 (StopThread 1 ThreadFinished),+ Event 4000000000 (Shutdown)+ ]+ ]++-------------------------------------------------------------------------------++test "tick4"+ = [-- A test for scale values close to 1.0+ Event 0 (Startup 1),+ Event 0 $ EventBlock 4000000000 0 [+ Event 100 (CreateThread 1),+ Event 200 (RunThread 1),+ Event 300 (StopThread 1 ThreadFinished),+ Event 400 (Shutdown)+ ]+ ]++-------------------------------------------------------------------------------++test "tick5"+ = [-- A thread from 2s to 3s+ Event 0 (Startup 1),+ Event 0 $ EventBlock 4000000000 0 [+ Event 1000000000 (CreateThread 1),+ Event 2000000000 (RunThread 1),+ Event 3000000000 (StopThread 1 ThreadFinished),+ Event 4000000000 (Shutdown)+ ]+ ]++-------------------------------------------------------------------------------+-- A long tick run to check small and large tick labels++test "tick6" = chequered 2 100 10000000++-------------------------------------------------------------------------------++test "overlap"+ = [-- A thread from 2s to 3s+ Event 0 (Startup 1),+ Event 0 $ EventBlock 3000 0 [+ Event 1000 (CreateThread 1),+ Event 1100 (RunThread 1),+ Event 1200 (CreateThread 2),+ Event 1300 (StopThread 1 ThreadFinished),++ Event 1400 (RunThread 2),+ Event 1500 (CreateThread 3),+ Event 1500 (CreateThread 4),+ Event 1500 (StopThread 2 ThreadFinished),++ Event 1600 (RunThread 3),+ Event 1600 (CreateThread 5),+ Event 1600 (StopThread 3 ThreadFinished),++ Event 1700 (RunThread 4),+ Event 1700 (CreateThread 6),+ Event 1800 (StopThread 4 ThreadFinished),++ Event 3000 (Shutdown)+ ]+ ]++-------------------------------------------------------------------------------+-- These tests are for chequered patterns to help check for rendering+-- problems and also to help test the performance of scrolling etc.+-- Each line has a fixed frequency of a thread running and then performing GC.+-- Each successive HEC runs thread at half the frequency of the previous HEC.++test "ch1" = chequered 1 100 100000+test "ch2" = chequered 2 100 100000+test "ch3" = chequered 3 100 100000+test "ch4" = chequered 4 100 100000+test "ch5" = chequered 5 100 100000+test "ch6" = chequered 6 100 100000+test "ch7" = chequered 7 100 100000+test "ch8" = chequered 8 100 100000+++-------------------------------------------------------------------------------++test _ = []++-------------------------------------------------------------------------------++chequered :: ThreadId -> Timestamp -> Timestamp -> [Event]+chequered numThreads basicDuration runLength+ = Event 0 (Startup (fromIntegral numThreads)) :+ makeChequered 1 numThreads basicDuration runLength++-------------------------------------------------------------------------------++makeChequered :: ThreadId -> ThreadId -> Timestamp -> Timestamp -> [Event]+makeChequered currentThread numThreads _basicDuration _runLength+ | currentThread > numThreads = [] -- All threads rendered+makeChequered currentThread numThreads basicDuration runLength+ = Event 0 eventBlock :+ makeChequered (currentThread+1) numThreads (2*basicDuration) runLength+ where+ eventBlock :: EventInfo+ eventBlock = EventBlock runLength (fromIntegral (currentThread-1))+ (Event 0 (CreateThread currentThread)+ : chequeredPattern currentThread 0 basicDuration runLength)++-------------------------------------------------------------------------------++chequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event]+chequeredPattern currentThread currentPos basicDuration runLength+ = if currentPos + 2*basicDuration > runLength then+ [Event runLength (Shutdown)]+ else+ [Event currentPos (RunThread currentThread),+ Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding),+ Event (currentPos+basicDuration) StartGC,+ Event (currentPos+2*basicDuration) EndGC+ ] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength++-------------------------------------------------------------------------------+
− EventsWindow.hs
@@ -1,269 +0,0 @@-module EventsWindow (- setupEventsWindow,- updateEventsWindow,- eventsWindowResize,- getCursorLine,- drawEvents- ) where--import State-import ViewerColours-import Timeline--import Graphics.UI.Gtk-import Graphics.UI.Gtk.Gdk.EventM-import Graphics.Rendering.Cairo --import GHC.RTS.Events as GHC-import Graphics.UI.Gtk.ModelView as New--import Control.Monad.Reader-import Data.Array-import Data.IORef-import Text.Printf-----------------------------------------------------------------------------------setupEventsWindow :: ViewerState -> IO ()-setupEventsWindow state@ViewerState{..} = do-- -- make the background white- widgetModifyBg eventsDrawingArea StateNormal (Color 0xffff 0xffff 0xffff)-- adj <- rangeGetAdjustment eventsVScrollbar- adjustmentSetLower adj 0- adjustmentSetStepIncrement adj 4-- widgetSetCanFocus eventsDrawingArea True-- on eventsDrawingArea configureEvent $ eventsWindowResize state-- on eventsDrawingArea exposeEvent $ updateEventsWindow state-- on eventsDrawingArea buttonPressEvent $ tryEvent $ do- button <- eventButton- (_,y) <- eventCoordinates- liftIO $ do- widgetGrabFocus eventsDrawingArea- setCursor state y-- on eventsDrawingArea focusInEvent $ liftIO $ do- f <- get eventsDrawingArea widgetHasFocus- when debug $ putStrLn ("focus in: " ++ show f)--- set eventsDrawingArea [widgetHasFocus := True]- return False-- on eventsDrawingArea focusOutEvent $ liftIO $ do- f <- get eventsDrawingArea widgetHasFocus- when debug $ putStrLn ("focus out: " ++ show f)--- set eventsDrawingArea [widgetHasFocus := False]- return False-- on eventsDrawingArea keyPressEvent $ do- key <- eventKeyName- when debug $ liftIO $ putStrLn ("key " ++ key)- return True-- on eventsDrawingArea scrollEvent $ do- dir <- eventScrollDirection- liftIO $ do- val <- adjustmentGetValue adj- step <- adjustmentGetStepIncrement adj- case dir of- ScrollUp -> adjustmentSetValue adj (val - step)- ScrollDown -> adjustmentSetValue adj (val + step)- _ -> return ()- return True-- onValueChanged adj $- widgetQueueDraw eventsDrawingArea-- onToolButtonClicked eventsFirstButton $ do- putStrLn "eventsFirstButton"- adjustmentSetValue adj 0-- onToolButtonClicked eventsLastButton $ do- upper <- adjustmentGetUpper adj- adjustmentSetValue adj upper-- onToolButtonClicked eventsHomeButton $ do- cursorpos <- getCursorLine state- page <- adjustmentGetPageSize adj- adjustmentSetValue adj (fromIntegral (max 0 (cursorpos - round page `quot` 2)))--- -- Button for adding the cursor position to the boomark list- onToolButtonClicked addBookmarkButton $ do- when debug $ putStrLn "Add bookmark\n"- cursorPos <- readIORef cursorIORef- New.listStoreAppend bookmarkStore cursorPos- queueRedrawTimelines state-- -- Button for deleting a bookmark- onToolButtonClicked deleteBookmarkButton $ do- when debug $ putStrLn "Delete bookmark\n"- sel <- treeViewGetSelection bookmarkTreeView- selection <- treeSelectionGetSelected sel - case selection of- Nothing -> return ()- Just (TreeIter _ pos _ _) -> listStoreRemove bookmarkStore (fromIntegral pos)- queueRedrawTimelines state- - -- Button for jumping to bookmark- onToolButtonClicked gotoBookmarkButton $ do- sel <- treeViewGetSelection bookmarkTreeView- selection <- treeSelectionGetSelected sel - case selection of- Nothing -> return ()- Just (TreeIter _ pos _ _) -> do- l <- listStoreToList bookmarkStore- when debug $ putStrLn ("gotoBookmark: " ++ show l++ " pos = " ++ show pos)- setCursorToTime state (l!!(fromIntegral pos))- queueRedrawTimelines state-- exts <- withImageSurface FormatARGB32 0 0 $ \s -> renderWith s eventsFont- writeIORef eventsFontExtents exts-- return ()-----------------------------------------------------------------------------------eventsWindowResize :: ViewerState -> EventM EConfigure Bool-eventsWindowResize state@ViewerState{..} = liftIO $ do- (_,h) <- widgetGetSize eventsDrawingArea- win <- widgetGetDrawWindow eventsDrawingArea- exts <- readIORef eventsFontExtents- let page = fromIntegral (truncate (fromIntegral h / fontExtentsHeight exts))- mb_hecs <- readIORef hecsIORef- case mb_hecs of- Nothing -> return True- Just hecs -> do- let arr = hecEventArray hecs- let (_, n_events) = bounds arr- adjustmentSetPageIncrement eventsAdj page- adjustmentSetPageSize eventsAdj page- adjustmentSetUpper eventsAdj (fromIntegral n_events + 1)- -- printf "eventsWindowResize: %f" page- return True-----------------------------------------------------------------------------------updateEventsWindow :: ViewerState -> EventM EExpose Bool-updateEventsWindow state@ViewerState{..} = liftIO $ do- value <- adjustmentGetValue eventsAdj- mb_hecs <- readIORef hecsIORef- case mb_hecs of- Nothing -> return True- Just hecs -> do- let arr = hecEventArray hecs- win <- widgetGetDrawWindow eventsDrawingArea- (w,h) <- widgetGetSize eventsDrawingArea- - cursorpos <- getCursorLine state- when debug $ printf "cursorpos: %d\n" cursorpos- renderWithDrawable win $ do- drawEvents value arr w h cursorpos- return True-----------------------------------------------------------------------------------getCursorLine :: ViewerState -> IO Int-getCursorLine state@ViewerState{..} = do- -- locate the cursor position as a line number- current_cursor <- readIORef cursorIORef- eventsCursor <- readIORef eventsCursorIORef- mb_hecs <- readIORef hecsIORef- case mb_hecs of- Nothing -> return 0- Just hecs -> do- let arr = hecEventArray hecs- case eventsCursor of- Just (cursort, cursorpos) | cursort == current_cursor ->- return cursorpos- _other -> do- let cursorpos = locateCursor arr current_cursor- writeIORef eventsCursorIORef (Just (current_cursor, cursorpos))- return cursorpos---------------------------------------------------------------------------------- -setCursor :: ViewerState -> Double -> IO ()-setCursor state@ViewerState{..} eventY = do- val <- adjustmentGetValue eventsAdj- mb_hecs <- readIORef hecsIORef- case mb_hecs of- Nothing -> return ()- Just hecs -> do- let arr = hecEventArray hecs- exts <- readIORef eventsFontExtents- let - line' = truncate (val + eventY / fontExtentsHeight exts)- arr_max = snd $ bounds arr- line = if line' > arr_max then arr_max else line' - t = time (ce_event (arr!line))- --- writeIORef cursorIORef t- writeIORef eventsCursorIORef (Just (t,line))- widgetQueueDraw eventsDrawingArea---- find the line that corresponds to the next event after the cursor-locateCursor :: Array Int GHC.CapEvent -> Timestamp -> Int-locateCursor arr cursor = search l (r+1)- where- (l,r) = bounds arr-- search !l !r- | (r - l) <= 1 = if cursor > time (ce_event (arr!l)) then r else l- | cursor < tmid = search l mid- | otherwise = search mid r- where- mid = l + (r - l) `quot` 2- tmid = time (ce_event (arr!mid))--eventsFont :: Render FontExtents-eventsFont = do- selectFontFace "Monospace" FontSlantNormal FontWeightNormal- setFontSize 12- fontExtents-----------------------------------------------------------------------------------drawEvents :: Double -> Array Int GHC.CapEvent -> Int -> Int -> Int -> Render ()-drawEvents value arr width height cursor = do- let val = truncate value :: Int- exts <- eventsFont- let h = fontExtentsHeight exts- (_, upper) = bounds arr- lines = ceiling (fromIntegral height / h)- end = min upper (val + lines)-- draw y ev = do moveTo 0 y; showText (ppEvent' ev)-- zipWithM_ draw [ h, h*2 .. ] [ arr ! n | n <- [ val .. end ] ]-- when (val <= cursor && cursor <= end) $ do- setLineWidth 3- setOperator OperatorOver- setSourceRGBAhex blue 1.0- let cursory = fromIntegral (cursor - val) * h + 3- moveTo 0 cursory- lineTo (fromIntegral width) cursory- stroke------------------------------------------------------------------------------------ppEvent' :: CapEvent -> String-ppEvent' (CapEvent cap (GHC.Event time spec)) =- printf "%9d: " time ++- (case cap of- Nothing -> ""- Just c -> printf "cap %d: " c) ++- case spec of- UnknownEvent{ ref=ref } ->- printf "unknown event; %d" ref-- Message msg -> msg- UserMessage msg -> msg-- _other -> showEventTypeSpecificInfo spec
− FileDialog.hs
@@ -1,29 +0,0 @@-------------------------------------------------------------------------------- ---- $Id: FileDialog.hs#1 2009/03/20 13:27:50 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/FileDialog.hs $ -------------------------------------------------------------------------------- - -module FileDialog -where - -import Graphics.UI.Gtk - -------------------------------------------------------------------------------- - -openFileDialog :: Window -> IO (Maybe String) -openFileDialog parentWindow - = do dialog <- fileChooserDialogNew - (Just "Open Profile... ") - (Just parentWindow) - FileChooserActionOpen - [("gtk-cancel", ResponseCancel) - ,("gtk-open", ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - widgetHide dialog - case response of - ResponseAccept -> fileChooserGetFilename dialog - _ -> return Nothing - -------------------------------------------------------------------------------- -
+ GUI/BookmarkView.hs view
@@ -0,0 +1,128 @@+module GUI.BookmarkView (+ BookmarkView,+ bookmarkViewNew,+ BookmarkViewActions(..),++ bookmarkViewGet,+ bookmarkViewAdd,+ bookmarkViewRemove,+ bookmarkViewClear,+ bookmarkViewSetLabel,+ ) where++import GHC.RTS.Events (Timestamp)++import Graphics.UI.Gtk+import Numeric++---------------------------------------------------------------------------++-- | Abstract bookmark view object.+--+data BookmarkView = BookmarkView {+ bookmarkStore :: ListStore (Timestamp, String)+ }++-- | The actions to take in response to TraceView events.+--+data BookmarkViewActions = BookmarkViewActions {+ bookmarkViewAddBookmark :: IO (),+ bookmarkViewRemoveBookmark :: Int -> IO (),+ bookmarkViewGotoBookmark :: Timestamp -> IO (),+ bookmarkViewEditLabel :: Int -> String -> IO ()+ }++---------------------------------------------------------------------------++bookmarkViewAdd :: BookmarkView -> Timestamp -> String -> IO ()+bookmarkViewAdd BookmarkView{bookmarkStore} ts label = do+ listStoreAppend bookmarkStore (ts, label)+ return ()++bookmarkViewRemove :: BookmarkView -> Int -> IO ()+bookmarkViewRemove BookmarkView{bookmarkStore} n = do+ listStoreRemove bookmarkStore n+ return ()++bookmarkViewClear :: BookmarkView -> IO ()+bookmarkViewClear BookmarkView{bookmarkStore} =+ listStoreClear bookmarkStore++bookmarkViewGet :: BookmarkView -> IO [(Timestamp, String)]+bookmarkViewGet BookmarkView{bookmarkStore} =+ listStoreToList bookmarkStore++bookmarkViewSetLabel :: BookmarkView -> Int -> String -> IO ()+bookmarkViewSetLabel BookmarkView{bookmarkStore} n label = do+ (ts,_) <- listStoreGetValue bookmarkStore n+ listStoreSetValue bookmarkStore n (ts, label)++---------------------------------------------------------------------------++bookmarkViewNew :: Builder -> BookmarkViewActions -> IO BookmarkView+bookmarkViewNew builder BookmarkViewActions{..} = do++ let getWidget cast name = builderGetObject builder cast name++ ---------------------------------------------------------------------------++ bookmarkTreeView <- getWidget castToTreeView "bookmark_list"+ bookmarkStore <- listStoreNew []+ columnTs <- treeViewColumnNew+ cellTs <- cellRendererTextNew+ columnLabel <- treeViewColumnNew+ cellLabel <- cellRendererTextNew+ selection <- treeViewGetSelection bookmarkTreeView++ treeViewColumnSetTitle columnTs "Time"+ treeViewColumnSetTitle columnLabel "Label"+ treeViewColumnPackStart columnTs cellTs False+ treeViewColumnPackStart columnLabel cellLabel True+ treeViewAppendColumn bookmarkTreeView columnTs+ treeViewAppendColumn bookmarkTreeView columnLabel++ treeViewSetModel bookmarkTreeView bookmarkStore++ cellLayoutSetAttributes columnTs cellTs bookmarkStore $ \(ts,_) ->+ [ cellText := showFFloat (Just 6) (fromIntegral ts / 1000000000) "s" ]++ cellLayoutSetAttributes columnLabel cellLabel bookmarkStore $ \(_,label) ->+ [ cellText := label ]++ ---------------------------------------------------------------------------++ addBookmarkButton <- getWidget castToToolButton "add_bookmark_button"+ deleteBookmarkButton <- getWidget castToToolButton "delete_bookmark"+ gotoBookmarkButton <- getWidget castToToolButton "goto_bookmark_button"++ onToolButtonClicked addBookmarkButton $+ bookmarkViewAddBookmark++ onToolButtonClicked deleteBookmarkButton $ do+ selected <- treeSelectionGetSelected selection+ case selected of+ Nothing -> return ()+ Just iter ->+ let pos = listStoreIterToIndex iter+ in bookmarkViewRemoveBookmark pos++ onToolButtonClicked gotoBookmarkButton $ do+ selected <- treeSelectionGetSelected selection+ case selected of+ Nothing -> return ()+ Just iter -> do+ let pos = listStoreIterToIndex iter+ (ts,_) <- listStoreGetValue bookmarkStore pos+ bookmarkViewGotoBookmark ts++ onRowActivated bookmarkTreeView $ \[pos] _ -> do+ (ts, _) <- listStoreGetValue bookmarkStore pos+ bookmarkViewGotoBookmark ts++ set cellLabel [ cellTextEditable := True ]+ on cellLabel edited $ \[pos] val -> do+ bookmarkViewEditLabel pos val++ ---------------------------------------------------------------------------++ return BookmarkView{..}
+ GUI/ConcurrencyControl.hs view
@@ -0,0 +1,66 @@++module GUI.ConcurrencyControl (+ ConcurrencyControl,+ start,+ fullSpeed,+ ) where++import qualified System.Glib.MainLoop as Glib+import qualified Control.Concurrent as Concurrent+import qualified Control.Exception as Exception+import Control.Concurrent.MVar+++newtype ConcurrencyControl = ConcurrencyControl (MVar (Int, Glib.HandlerId))++-- | Setup cooperative thread scheduling with Gtk+.+--+start :: IO ConcurrencyControl+start = do+ handlerId <- normalScheduling+ return . ConcurrencyControl =<< newMVar (0, handlerId)++-- | Run an expensive action that needs to use all the available CPU power.+--+-- The normal cooperative GUI thread scheduling does not work so well in this+-- case so we use an alternative technique. We can't use this one all the time+-- however or we'd hog the CPU even when idle.+--+fullSpeed :: ConcurrencyControl -> IO a -> IO a+fullSpeed (ConcurrencyControl handlerRef) =+ Exception.bracket_ begin end+ where+ -- remove the normal scheduling handler and put in the full speed one+ begin = do+ (count, handlerId) <- takeMVar handlerRef+ if count == 0+ -- nobody else is running fullSpeed+ then do Glib.timeoutRemove handlerId+ handlerId' <- fullSpeedScheduling+ putMVar handlerRef (1, handlerId')+ -- we're already running fullSpeed, just inc the count+ else do putMVar handlerRef (count+1, handlerId)++ -- reinstate the normal scheduling+ end = do+ (count, handlerId) <- takeMVar handlerRef+ if count == 1+ -- just us running fullSpeed so we clean up+ then do Glib.timeoutRemove handlerId+ handlerId' <- normalScheduling+ putMVar handlerRef (0, handlerId')+ -- someone else running fullSpeed, they're responsible for stopping+ else do putMVar handlerRef (count-1, handlerId)++normalScheduling :: IO Glib.HandlerId+normalScheduling =+ Glib.timeoutAddFull+ (Concurrent.yield >> return True)+ Glib.priorityDefaultIdle 50+ --50ms, ie 20 times a second.++fullSpeedScheduling :: IO Glib.HandlerId+fullSpeedScheduling =+ Glib.idleAdd+ (Concurrent.yield >> return True)+ Glib.priorityDefaultIdle
+ GUI/Dialogs.hs view
@@ -0,0 +1,164 @@+-------------------------------------------------------------------------------+--- $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)++import Graphics.UI.Gtk++import Data.Version (showVersion)+import System.FilePath+++-------------------------------------------------------------------------------++aboutDialog :: WindowClass window => window -> IO ()+aboutDialog parent+ = do dialog <- aboutDialogNew+ logoPath <- getDataFileName "threadscope.png"+ logo <- pixbufNewFromFile logoPath+ set dialog [+ aboutDialogName := "ThreadScope",+ aboutDialogVersion := showVersion version,+ aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.",+ aboutDialogComments := "A GHC eventlog profile viewer",+ aboutDialogAuthors := ["Donnie Jones <donnie@darthik.com>",+ "Simon Marlow <simonm@microsoft.com>",+ "Satnam Singh <s.singh@ieee.org>",+ "Duncan Coutts <duncan@well-typed.com>",+ "Mikolaj Konarski <mikolaj@well-typed.com>"],+ aboutDialogLogo := Just logo,+ aboutDialogWebsite := "http://research.microsoft.com/threadscope",+ windowTransientFor := toWindow parent+ ]+ onResponse dialog $ \_ -> widgetDestroy dialog+ widgetShow dialog++-------------------------------------------------------------------------------++openFileDialog :: WindowClass window => window -> (FilePath -> IO ()) -> IO ()+openFileDialog parent open+ = do dialog <- fileChooserDialogNew+ (Just "Open Profile...")+ (Just (toWindow parent))+ FileChooserActionOpen+ [("gtk-cancel", ResponseCancel)+ ,("gtk-open", ResponseAccept)]+ set dialog [+ windowModal := True+ ]++ eventlogfiles <- fileFilterNew+ fileFilterSetName eventlogfiles "GHC eventlog files (*.eventlog)"+ fileFilterAddPattern eventlogfiles "*.eventlog"+ fileChooserAddFilter dialog eventlogfiles++ allfiles <- fileFilterNew+ fileFilterSetName allfiles "All files"+ fileFilterAddPattern allfiles "*"+ fileChooserAddFilter dialog allfiles++ onResponse dialog $ \response -> do+ case response of+ ResponseAccept -> do+ mfile <- fileChooserGetFilename dialog+ case mfile of+ Just file -> open file+ Nothing -> return ()+ _ -> return ()+ widgetDestroy dialog++ widgetShowAll dialog++-------------------------------------------------------------------------------++data FileExportFormat = FormatPDF | FormatPNG++exportFileDialog :: WindowClass window => window+ -> FilePath+ -> (FilePath -> FileExportFormat -> IO ())+ -> IO ()+exportFileDialog parent oldfile save = do+ dialog <- fileChooserDialogNew+ (Just "Save timeline image...")+ (Just (toWindow parent))+ FileChooserActionSave+ [("gtk-cancel", ResponseCancel)+ ,("gtk-save", ResponseAccept)]+ set dialog [+ fileChooserDoOverwriteConfirmation := True,+ windowModal := True+ ]++ let (olddir, oldfilename) = splitFileName oldfile+ fileChooserSetCurrentName dialog (replaceExtension oldfilename "png")+ fileChooserSetCurrentFolder dialog olddir++ pngFiles <- fileFilterNew+ fileFilterSetName pngFiles "PNG bitmap files"+ fileFilterAddPattern pngFiles "*.png"+ fileChooserAddFilter dialog pngFiles++ pdfFiles <- fileFilterNew+ fileFilterSetName pdfFiles "PDF files"+ fileFilterAddPattern pdfFiles "*.pdf"+ fileChooserAddFilter dialog pdfFiles++ onResponse dialog $ \response ->+ case response of+ ResponseAccept -> do+ mfile <- fileChooserGetFilename dialog+ case mfile of+ Just file+ | takeExtension file == ".pdf" -> do+ save file FormatPDF+ widgetDestroy dialog+ | takeExtension file == ".png" -> do+ save file FormatPNG+ widgetDestroy dialog+ | otherwise ->+ formatError dialog+ Nothing -> widgetDestroy dialog+ _ -> widgetDestroy dialog++ widgetShowAll dialog+ where+ formatError dialog = do+ msg <- messageDialogNew (Just (toWindow dialog))+ [DialogModal, DialogDestroyWithParent]+ MessageError ButtonsClose+ "The file format is unknown or unsupported"+ set msg [+ messageDialogSecondaryText := Just $+ "The PNG and PDF formats are supported. "+ ++ "Please use a file extension of '.png' or '.pdf'."+ ]+ dialogRun msg+ widgetDestroy msg++++-------------------------------------------------------------------------------++errorMessageDialog :: WindowClass window => window -> String -> String -> IO ()+errorMessageDialog parent headline explanation = do++ dialog <- messageDialogNew (Just (toWindow parent))+ [] MessageError ButtonsNone ""++ set dialog+ [ windowModal := True+ , windowTransientFor := toWindow parent+ , messageDialogText := Just headline+ , messageDialogSecondaryText := Just explanation+ , windowResizable := True+ ]++ dialogAddButton dialog "Close" ResponseClose+ dialogSetDefaultResponse dialog ResponseClose++ onResponse dialog $ \_-> widgetDestroy dialog+ widgetShowAll dialog
+ GUI/EventsView.hs view
@@ -0,0 +1,343 @@+module GUI.EventsView (+ EventsView,+ eventsViewNew,+ EventsViewActions(..),++ eventsViewSetEvents,++ eventsViewGetCursor,+ eventsViewSetCursor,+ eventsViewScrollToLine,+ ) where++import GHC.RTS.Events++import Graphics.UI.Gtk+import GUI.GtkExtras as GtkExt++import Control.Monad.Reader+import Data.Array+import Data.IORef+import Numeric++-------------------------------------------------------------------------------++data EventsView = EventsView {+ drawArea :: !Widget,+ adj :: !Adjustment,+ stateRef :: !(IORef ViewState)+ }++data EventsViewActions = EventsViewActions {+ timelineViewCursorChanged :: Int -> IO ()+ }++data ViewState = ViewState {+ lineHeight :: !Double,+ eventsState :: !EventsState+ }++data EventsState+ = EventsEmpty+ | EventsLoaded {+ cursorPos :: !Int,+ eventsArr :: Array Int CapEvent+ }++-------------------------------------------------------------------------------++eventsViewNew :: Builder -> EventsViewActions -> IO EventsView+eventsViewNew builder EventsViewActions{..} = do++ stateRef <- newIORef undefined++ let getWidget cast = builderGetObject builder cast+ drawArea <- getWidget castToWidget "eventsDrawingArea"+ vScrollbar <- getWidget castToVScrollbar "eventsVScroll"+ adj <- get vScrollbar rangeAdjustment++ -- make the background white+ widgetModifyBg drawArea StateNormal (Color 0xffff 0xffff 0xffff)+ widgetSetCanFocus drawArea True+ --TODO: needs to be reset on each style change ^^++ -----------------------------------------------------------------------------+ -- Line height++ -- Calculate the height of each line based on the current font+ let getLineHeight = do+ pangoCtx <- widgetGetPangoContext drawArea+ fontDesc <- contextGetFontDescription pangoCtx+ metrics <- contextGetMetrics pangoCtx fontDesc emptyLanguage+ return $ ascent metrics + descent metrics --TODO: padding?++ -- We cache the height of each line+ initialLineHeight <- getLineHeight+ -- but have to update it when the font changes+ on drawArea styleSet $ \_ -> do+ lineHeight' <- getLineHeight+ modifyIORef stateRef $ \viewstate -> viewstate { lineHeight = lineHeight' }++ -----------------------------------------------------------------------------++ writeIORef stateRef ViewState {+ lineHeight = initialLineHeight,+ eventsState = EventsEmpty+ }++ let eventsView = EventsView {..}++ -----------------------------------------------------------------------------+ -- Drawing++ on drawArea exposeEvent $ liftIO $ do+ drawEvents eventsView =<< readIORef stateRef+ return True++ -----------------------------------------------------------------------------+ -- Key navigation++ on drawArea keyPressEvent $ do+ let scroll by = liftIO $ do+ ViewState{eventsState, lineHeight} <- readIORef stateRef+ pagesize <- get adj adjustmentPageSize+ let pagejump = max 1 (truncate (pagesize / lineHeight) - 1)+ case eventsState of+ EventsEmpty -> return ()+ EventsLoaded{cursorPos, eventsArr} ->+ timelineViewCursorChanged cursorPos'+ where+ cursorPos' = clampBounds range (by pagejump end cursorPos)+ range@(_,end) = bounds eventsArr+ return True++ key <- eventKeyName+ case key of+ "Up" -> scroll (\_page _end pos -> pos-1)+ "Down" -> scroll (\_page _end pos -> pos+1)+ "Page_Up" -> scroll (\ page _end pos -> pos-page)+ "Page_Down" -> scroll (\ page _end pos -> pos+page)+ "Home" -> scroll (\_page _end _pos -> 0)+ "End" -> scroll (\_page end _pos -> end)+ "Left" -> return True+ "Right" -> return True+ _ -> return False++ -----------------------------------------------------------------------------+ -- Scrolling++ set adj [ adjustmentLower := 0 ]++ on drawArea sizeAllocate $ \_ ->+ updateScrollAdjustment eventsView =<< readIORef stateRef++ let hitpointToLine :: ViewState -> Double -> Double -> Maybe Int+ hitpointToLine ViewState{eventsState = EventsEmpty} _ _ = Nothing+ hitpointToLine ViewState{eventsState = EventsLoaded{eventsArr}, lineHeight}+ yOffset eventY+ | hitLine > maxIndex = Nothing+ | otherwise = Just hitLine+ where+ hitLine = truncate ((yOffset + eventY) / lineHeight)+ maxIndex = snd (bounds eventsArr)++ on drawArea buttonPressEvent $ tryEvent $ do+ (_,y) <- eventCoordinates+ liftIO $ do+ viewState <- readIORef stateRef+ yOffset <- get adj adjustmentValue+ widgetGrabFocus drawArea+ case hitpointToLine viewState yOffset y of+ Nothing -> return ()+ Just n -> timelineViewCursorChanged n++ on drawArea scrollEvent $ do+ dir <- eventScrollDirection+ liftIO $ do+ val <- get adj adjustmentValue+ upper <- get adj adjustmentUpper+ pagesize <- get adj adjustmentPageSize+ step <- get adj adjustmentStepIncrement+ case dir of+ ScrollUp -> set adj [ adjustmentValue := val - step ]+ ScrollDown -> set adj [ adjustmentValue := min (val + step)+ (upper - pagesize) ]+ _ -> return ()+ return True++ onValueChanged adj $+ widgetQueueDraw drawArea++ -----------------------------------------------------------------------------++ return eventsView++-------------------------------------------------------------------------------++eventsViewSetEvents :: EventsView -> Maybe (Array Int CapEvent) -> IO ()+eventsViewSetEvents eventWin@EventsView{drawArea, stateRef} mevents = do+ viewState <- readIORef stateRef+ let eventsState' = case mevents of+ Nothing -> EventsEmpty+ Just events -> EventsLoaded {+ cursorPos = 0,+ eventsArr = events+ }+ viewState' = viewState { eventsState = eventsState' }+ writeIORef stateRef viewState'+ updateScrollAdjustment eventWin viewState'+ widgetQueueDraw drawArea++-------------------------------------------------------------------------------++eventsViewGetCursor :: EventsView -> IO (Maybe Int)+eventsViewGetCursor EventsView{stateRef} = do+ ViewState{eventsState} <- readIORef stateRef+ case eventsState of+ EventsEmpty -> return Nothing+ EventsLoaded{cursorPos} -> return (Just cursorPos)++eventsViewSetCursor :: EventsView -> Int -> IO ()+eventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n = 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' }+ }+ eventsViewScrollToLine eventsView n'+ widgetQueueDraw drawArea++eventsViewScrollToLine :: EventsView -> Int -> IO ()+eventsViewScrollToLine EventsView{adj, stateRef} n = do+ ViewState{lineHeight} <- readIORef stateRef+ -- make sure that the range [n..n+1] is within the current page:+ adjustmentClampPage adj+ (fromIntegral n * lineHeight)+ (fromIntegral (n+1) * lineHeight)++-------------------------------------------------------------------------------++updateScrollAdjustment :: EventsView -> ViewState -> IO ()+updateScrollAdjustment EventsView{drawArea, adj}+ ViewState{lineHeight, eventsState} = do++ (_,windowHeight) <- widgetGetSize drawArea+ let numLines = case eventsState of+ EventsEmpty -> 0+ EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1+ linesHeight = fromIntegral numLines * lineHeight+ upper = max linesHeight (fromIntegral windowHeight)+ pagesize = fromIntegral windowHeight++ set adj [+ adjustmentUpper := upper,+ adjustmentPageSize := pagesize,+ adjustmentStepIncrement := pagesize * 0.2,+ adjustmentPageIncrement := pagesize * 0.9+ ]+ val <- get adj adjustmentValue+ when (val > upper - pagesize) $+ set adj [ adjustmentValue := max 0 (upper - pagesize) ]++-------------------------------------------------------------------------------++drawEvents :: EventsView -> ViewState -> IO ()+drawEvents _ ViewState {eventsState = EventsEmpty} = return ()+drawEvents EventsView{drawArea, adj}+ ViewState {lineHeight, eventsState = EventsLoaded{..}} = do++ yOffset <- get adj adjustmentValue+ pageSize <- get adj adjustmentPageSize++ -- calculate which lines are visible+ let lower = truncate (yOffset / lineHeight)+ upper = ceiling ((yOffset + pageSize) / lineHeight)++ -- the array indexes [begin..end] inclusive+ -- are partially or fully visible+ begin = lower+ end = min upper (snd (bounds eventsArr))++ win <- widgetGetDrawWindow drawArea+ style <- get drawArea widgetStyle+ focused <- get drawArea widgetIsFocus+ let state | focused = StateSelected+ | otherwise = StateActive++ pangoCtx <- widgetGetPangoContext drawArea+ layout <- layoutEmpty pangoCtx+ layoutSetEllipsize layout EllipsizeEnd++ (width,clipHeight) <- widgetGetSize drawArea+ let clipRect = Rectangle 0 0 width clipHeight++ let --TODO: calculate based on average char width and n digits+ timeWidth = 120+ columnGap = 20+ descrWidth = width - timeWidth - columnGap++ sequence_+ [ do when selected $+ GtkExt.stylePaintFlatBox+ style win+ state 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+ clipRect+ drawArea ""+ 0 (round y)+ layout++ -- The event description text+ layoutSetText layout (showEventDescr event)+ layoutSetAlignment layout AlignLeft+ layoutSetWidth layout (Just (fromIntegral descrWidth))+ GtkExt.stylePaintLayout+ style win+ state' True+ clipRect+ drawArea ""+ (timeWidth + columnGap) (round y)+ layout++ | n <- [begin..end]+ , let y = fromIntegral n * lineHeight - yOffset+ event = eventsArr ! n+ selected = cursorPos == n+ ]++ where+ showEventTime (CapEvent _cap (Event time _spec)) =+ showFFloat (Just 6) (fromIntegral time / 1000000000) "s"+ showEventDescr (CapEvent cap (Event _time spec)) =+ (case cap of+ Nothing -> ""+ Just c -> "cap " ++ show c ++ ": ")+ ++ case spec of+ UnknownEvent{ref} -> "unknown event; " ++ show ref+ Message msg -> msg+ UserMessage msg -> msg+ _ -> showEventInfo spec++-------------------------------------------------------------------------------++clampBounds :: Ord a => (a, a) -> a -> a+clampBounds (lower, upper) x+ | x <= lower = lower+ | x > upper = upper+ | otherwise = x
+ GUI/GtkExtras.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module GUI.GtkExtras where++-- This is all stuff that should be bound in the gtk package but is not yet+-- (as of gtk-0.12.0)++import Graphics.UI.GtkInternals+import Graphics.UI.Gtk (Rectangle)+import System.Glib.MainLoop+import Graphics.Rendering.Pango.Types+import Graphics.Rendering.Pango.BasicTypes+import Graphics.UI.Gtk.General.Enums (StateType, ShadowType)++import Foreign+import Foreign.C+import Control.Concurrent.MVar++waitGUI :: IO ()+waitGUI = do+ resultVar <- newEmptyMVar+ idleAdd (putMVar resultVar () >> return False) priorityDefaultIdle+ takeMVar resultVar++-------------------------------------------------------------------------------++stylePaintFlatBox :: WidgetClass widget+ => Style+ -> DrawWindow+ -> StateType+ -> ShadowType+ -> Rectangle+ -> widget+ -> String+ -> Int -> Int -> Int -> Int+ -> IO ()+stylePaintFlatBox style window stateType shadowType+ clipRect widget detail x y width height =+ with clipRect $ \rectPtr ->+ withCString detail $ \detailPtr ->+ (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 arg10 arg11 -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 -> gtk_paint_flat_box argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 arg10 arg11)+ style+ window+ ((fromIntegral.fromEnum) stateType)+ ((fromIntegral.fromEnum) shadowType)+ (castPtr rectPtr)+ (toWidget widget)+ detailPtr+ (fromIntegral x) (fromIntegral y)+ (fromIntegral width) (fromIntegral height)++stylePaintLayout :: WidgetClass widget+ => Style+ -> DrawWindow+ -> StateType+ -> Bool+ -> Rectangle+ -> widget+ -> String+ -> Int -> Int+ -> PangoLayout+ -> IO ()+stylePaintLayout style window stateType useText+ clipRect widget detail x y (PangoLayout _ layout) =+ with clipRect $ \rectPtr ->+ withCString detail $ \detailPtr ->+ (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 (PangoLayoutRaw arg10) -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 ->withForeignPtr arg10 $ \argPtr10 -> gtk_paint_layout argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 argPtr10)+ style+ window+ ((fromIntegral.fromEnum) stateType)+ (fromBool useText)+ (castPtr rectPtr)+ (toWidget widget)+ detailPtr+ (fromIntegral x) (fromIntegral y)+ layout++-------------------------------------------------------------------------------++foreign import ccall safe "gtk_paint_flat_box"+ gtk_paint_flat_box :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> CInt -> CInt -> IO ()++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 ()
+ GUI/KeyView.hs view
@@ -0,0 +1,101 @@+module GUI.KeyView (+ KeyView,+ keyViewNew,+ ) where++import GUI.ViewerColours+import GUI.Timeline.Render.Constants++import Graphics.UI.Gtk+import Graphics.Rendering.Cairo as C+++---------------------------------------------------------------------------++-- | Abstract key view object.+--+data KeyView = KeyView++---------------------------------------------------------------------------++keyViewNew :: Builder -> IO KeyView+keyViewNew builder = do++ keyTreeView <- builderGetObject builder castToTreeView "key_list"++ dw <- widgetGetDrawWindow keyTreeView+ keyEntries <- createKeyEntries dw keyData++ keyStore <- listStoreNew keyEntries+ keyColumn <- treeViewColumnNew+ imageCell <- cellRendererPixbufNew+ labelCell <- cellRendererTextNew++ treeViewColumnPackStart keyColumn imageCell False+ treeViewColumnPackStart keyColumn labelCell True+ treeViewAppendColumn keyTreeView keyColumn++ selection <- treeViewGetSelection keyTreeView+ treeSelectionSetMode selection SelectionNone++ treeViewSetModel keyTreeView keyStore++ cellLayoutSetAttributes keyColumn imageCell keyStore $ \(_,img) ->+ [ cellPixbuf := img ]+ cellLayoutSetAttributes keyColumn labelCell keyStore $ \(label,_) ->+ [ cellText := label ]++ ---------------------------------------------------------------------------++ return KeyView++-------------------------------------------------------------------------------++data KeyStyle = Box | Vertical++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)+ ]+++createKeyEntries :: DrawableClass dw => dw+ -> [(String, KeyStyle, Color)] -> IO [(String, Pixbuf)]+createKeyEntries similar entries =+ sequence+ [ do pixbuf <- renderToPixbuf similar (50, hecBarHeight) $ do+ setSourceRGB 1 1 1+ paint+ renderKeyIcon style colour+ return (label, pixbuf)++ | (label, style, colour) <- entries ]++renderKeyIcon :: KeyStyle -> Color -> Render ()+renderKeyIcon Box keyColour = do+ setSourceRGBAhex keyColour 1.0+ rectangle 0 0 50 (fromIntegral (hecBarHeight `div` 2))+ C.fill+renderKeyIcon Vertical keyColour = do+ setSourceRGBAhex keyColour 1.0+ setLineWidth 3.0+ moveTo 10 0+ relLineTo 0 25+ C.stroke++renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> Render () -> IO Pixbuf+renderToPixbuf similar (w, h) draw = do+ pixmap <- pixmapNew (Just similar) w h Nothing+ renderWithDrawable pixmap draw+ Just pixbuf <- pixbufGetFromDrawable pixmap (Rectangle 0 0 w h)+ return pixbuf++-------------------------------------------------------------------------------
+ GUI/Main.hs view
@@ -0,0 +1,411 @@+{-# 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 System.Glib.GError (failOnGError)++-- Imports from Haskell library+import Text.Printf+import Control.Monad+#ifndef mingw32_HOST_OS+import System.Posix+#endif+import Control.Concurrent+import qualified Control.Concurrent.Chan as Chan+import Control.Exception+import Prelude hiding (catch)+import Data.Array+import Data.Maybe++import Paths_threadscope++-- Imports for ThreadScope+import GUI.MainWindow as MainWindow+import GUI.Types+import Events.HECs hiding (Event)+import GUI.Dialogs+import Events.ReadEvents+import GUI.EventsView+import GUI.Timeline+import GUI.TraceView+import GUI.BookmarkView+import GUI.KeyView+import GUI.SaveAs+import qualified GUI.ConcurrencyControl as ConcurrencyControl+import qualified GUI.ProgressView as ProgressView++-------------------------------------------------------------------------------++data UIEnv = UIEnv {++ mainWin :: MainWindow,+ eventsView :: EventsView,+ timelineWin :: TimelineView,+ traceView :: TraceView,+ bookmarkView :: BookmarkView,+ keyView :: KeyView,++ eventQueue :: Chan Event,+ concCtl :: ConcurrencyControl.ConcurrencyControl+ }++data EventlogState+ = NoEventlogLoaded+ | EventlogLoaded {+ mfilename :: Maybe FilePath, --test traces have no filepath+ hecs :: HECs,+ cursorTs :: Timestamp,+ cursorPos :: Int+ }++postEvent :: Chan Event -> Event -> IO ()+postEvent = Chan.writeChan++getEvent :: Chan Event -> IO Event+getEvent = Chan.readChan++data Event+ = EventOpenDialog+ | EventExportDialog+ | EventAboutDialog+ | EventQuit++ | EventFileLoad FilePath+ | EventTestLoad String+ | EventFileReload+ | EventFileExport FilePath FileExportFormat++-- | EventStateClear+ | EventSetState HECs (Maybe FilePath) String Int Double++ | EventShowSidebar Bool+ | EventShowEvents Bool++ | EventTimelineJumpStart+ | EventTimelineJumpEnd+ | EventTimelineJumpCursor+ | EventTimelineScrollLeft+ | EventTimelineScrollRight+ | EventTimelineZoomIn+ | EventTimelineZoomOut+ | EventTimelineZoomToFit+ | EventTimelineShowLabels Bool+ | EventTimelineShowBW Bool++ | EventCursorChangedIndex Int+ | EventCursorChangedTimestamp Timestamp++ | EventTracesChanged [Trace]++ | EventBookmarkAdd+ | EventBookmarkRemove Int+ | EventBookmarkEdit Int String++ | EventUserError String SomeException+ -- can add more specific ones if necessary++constructUI :: IO UIEnv+constructUI = failOnGError $ do++ builder <- builderNew+ builderAddFromFile builder =<< getDataFileName "threadscope.ui"++ eventQueue <- Chan.newChan+ let post = postEvent eventQueue++ mainWin <- mainWindowNew builder MainWindowActions {+ mainWinOpen = post EventOpenDialog,+ mainWinExport = post EventExportDialog,+ mainWinQuit = post EventQuit,+ mainWinViewSidebar = post . EventShowSidebar,+ mainWinViewEvents = post . EventShowEvents,+ mainWinViewReload = post EventFileReload,+ mainWinAbout = post EventAboutDialog,+ mainWinJumpStart = post EventTimelineJumpStart,+ mainWinJumpEnd = post EventTimelineJumpEnd,+ mainWinJumpCursor = post EventTimelineJumpCursor,+ mainWinScrollLeft = post EventTimelineScrollLeft,+ mainWinScrollRight = post EventTimelineScrollRight,+ mainWinJumpZoomIn = post EventTimelineZoomIn,+ mainWinJumpZoomOut = post EventTimelineZoomOut,+ mainWinJumpZoomFit = post EventTimelineZoomToFit,+ mainWinDisplayLabels = post . EventTimelineShowLabels,+ mainWinViewBW = post . EventTimelineShowBW+ }++ timelineWin <- timelineViewNew builder TimelineViewActions {+ timelineViewCursorChanged = post . EventCursorChangedTimestamp+ }++ eventsView <- eventsViewNew builder EventsViewActions {+ timelineViewCursorChanged = post . EventCursorChangedIndex+ }++ traceView <- traceViewNew builder TraceViewActions {+ traceViewTracesChanged = post . EventTracesChanged+ }++ bookmarkView <- bookmarkViewNew builder BookmarkViewActions {+ bookmarkViewAddBookmark = post EventBookmarkAdd,+ bookmarkViewRemoveBookmark = post . EventBookmarkRemove,+ bookmarkViewGotoBookmark = \ts -> post (EventCursorChangedTimestamp ts)+ >> post EventTimelineJumpCursor,+ bookmarkViewEditLabel = \n v -> post (EventBookmarkEdit n v)+ }++ keyView <- keyViewNew builder++ concCtl <- ConcurrencyControl.start++ return UIEnv{..}++-------------------------------------------------------------------------------++data LoopDone = LoopDone++eventLoop :: UIEnv -> EventlogState -> IO ()+eventLoop uienv@UIEnv{..} eventlogState = do++ event <- getEvent eventQueue+ next <- dispatch event eventlogState+#if __GLASGOW_HASKELL__ <= 612+ -- workaround for a wierd exception handling bug in ghc-6.12+ `catch` \e -> throwIO (e :: SomeException)+#endif+ case next of+ Left LoopDone -> return ()+ Right eventlogState' -> eventLoop uienv eventlogState'++ where+ dispatch :: Event -> EventlogState -> IO (Either LoopDone EventlogState)++ dispatch EventQuit _ = return (Left LoopDone)++ dispatch EventOpenDialog _ = do+ openFileDialog mainWin $ \filename ->+ post (EventFileLoad filename)+ continue++ dispatch (EventFileLoad filename) _ = do+ async "loading the eventlog" $+ loadEvents (Just filename) (registerEventsFromFile filename)+ --TODO: set state to be empty during loading+ continue++ dispatch (EventTestLoad testname) _ = do+ async "loading the test eventlog" $+ loadEvents Nothing (registerEventsFromTrace testname)+ --TODO: set state to be empty during loading+ continue++ dispatch EventFileReload EventlogLoaded{mfilename = Just filename} = do+ async "reloading the eventlog" $+ loadEvents (Just filename) (registerEventsFromFile filename)+ --TODO: set state to be empty during loading+ continue++ dispatch EventFileReload EventlogLoaded{mfilename = Nothing} =+ continue++-- dispatch EventClearState _++ dispatch (EventSetState hecs mfilename name nevents timespan) _ = do++ MainWindow.setFileLoaded mainWin (Just name)+ MainWindow.setStatusMessage mainWin $+ printf "%s (%d events, %.3fs)" name nevents timespan++ eventsViewSetEvents eventsView (Just (hecEventArray hecs))+ traceViewSetHECs traceView hecs+ traces' <- traceViewGetTraces traceView+ timelineWindowSetHECs timelineWin (Just hecs)+ timelineWindowSetTraces timelineWin traces'++ -- 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)++ continueWith EventlogLoaded {+ mfilename = mfilename,+ hecs = hecs,+ cursorTs = 0,+ cursorPos = 0+ }++ dispatch EventExportDialog+ EventlogLoaded {mfilename} = do+ exportFileDialog mainWin (fromMaybe "" mfilename) $ \filename' format ->+ post (EventFileExport filename' format)+ continue++ dispatch (EventFileExport filename format)+ EventlogLoaded {hecs} = do+ viewParams <- timelineGetViewParameters timelineWin+ let viewParams' = viewParams {+ detail = 1,+ bwMode = False,+ labelsMode = False+ }+ case format of+ FormatPDF -> saveAsPDF filename hecs viewParams'+ FormatPNG -> saveAsPNG filename hecs viewParams'+ continue++ dispatch EventAboutDialog _ = do+ aboutDialog mainWin+ continue++ dispatch (EventShowSidebar visible) _ = do+ MainWindow.sidebarSetVisibility mainWin visible+ continue++ dispatch (EventShowEvents visible) _ = do+ MainWindow.eventsSetVisibility mainWin visible+ continue++ dispatch EventTimelineJumpStart _ = do+ timelineScrollToBeginning timelineWin+ eventsViewScrollToLine eventsView 0+ continue++ dispatch EventTimelineJumpEnd EventlogLoaded{hecs} = do+ timelineScrollToEnd timelineWin+ let (_,end) = bounds (hecEventArray hecs)+ eventsViewScrollToLine eventsView end+ continue++ dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do+ timelineCentreOnCursor timelineWin --TODO: pass cursorTs here+ eventsViewScrollToLine eventsView cursorPos+ continue++ dispatch EventTimelineScrollLeft _ = do+ timelineScrollLeft timelineWin+ continue++ dispatch EventTimelineScrollRight _ = do+ timelineScrollRight timelineWin+ continue+ dispatch EventTimelineZoomIn _ = do+ timelineZoomIn timelineWin+ continue+ dispatch EventTimelineZoomOut _ = do+ timelineZoomOut timelineWin+ continue+ dispatch EventTimelineZoomToFit _ = do+ timelineZoomToFit timelineWin+ continue++ dispatch (EventTimelineShowLabels showLabels) _ = do+ timelineSetShowLabels timelineWin showLabels+ continue++ dispatch (EventTimelineShowBW showBW) _ = do+ timelineSetBWMode timelineWin showBW+ continue++ dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do+ let cursorTs' = eventIndexToTimestamp hecs cursorPos'+ timelineSetCursor timelineWin cursorTs'+ eventsViewSetCursor eventsView cursorPos'+ continueWith eventlogState {+ cursorTs = cursorTs',+ cursorPos = cursorPos'+ }++ dispatch (EventCursorChangedTimestamp cursorTs') EventlogLoaded{hecs} = do+ let cursorPos' = timestampToEventIndex hecs cursorTs'+ timelineSetCursor timelineWin cursorTs'+ eventsViewSetCursor eventsView cursorPos'+ continueWith eventlogState {+ cursorTs = cursorTs',+ cursorPos = cursorPos'+ }++ dispatch (EventTracesChanged traces) _ = do+ timelineWindowSetTraces timelineWin traces+ continue++ dispatch EventBookmarkAdd EventlogLoaded{cursorTs} = do+ bookmarkViewAdd bookmarkView cursorTs ""+ --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+ timelineWindowSetBookmarks timelineWin (map fst ts)+ continue++ dispatch (EventBookmarkRemove n) _ = do+ bookmarkViewRemove bookmarkView n+ --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+ timelineWindowSetBookmarks timelineWin (map fst ts)+ continue++ dispatch (EventBookmarkEdit n v) _ = do+ bookmarkViewSetLabel bookmarkView n v+ continue++ dispatch (EventUserError doing exception) _ = do+ let headline = "There was a problem " ++ doing ++ "."+ explanation = show exception+ errorMessageDialog mainWin headline explanation+ continue++ dispatch _ NoEventlogLoaded = continue++ loadEvents mfilename registerEvents = do+ ConcurrencyControl.fullSpeed concCtl $+ ProgressView.withProgress mainWin $ \progress -> do+ (hecs, name, nevents, timespan) <- registerEvents progress+ post (EventSetState hecs mfilename name nevents timespan)+ return ()++ async doing action =+ forkIO (action `catch` \e -> post (EventUserError doing e))++ post = postEvent eventQueue+ continue = continueWith eventlogState+ continueWith = return . Right++-------------------------------------------------------------------------------++runGUI :: Maybe (Either FilePath String) -> IO ()+runGUI initialTrace = do+ Gtk.initGUI++ uiEnv <- constructUI++ let post = postEvent (eventQueue uiEnv)++ case initialTrace of+ Nothing -> return ()+ Just (Left filename) -> post (EventFileLoad filename)+ Just (Right traceName) -> post (EventTestLoad traceName)++ doneVar <- newEmptyMVar++ forkIO $ do+ res <- try $ eventLoop uiEnv NoEventlogLoaded+ Gtk.mainQuit+ putMVar doneVar (res :: Either SomeException ())++#ifndef mingw32_HOST_OS+ installHandler sigINT (Catch $ post EventQuit) Nothing+#endif++ -- Enter Gtk+ main event loop.+ Gtk.mainGUI++ -- Wait for child event loop to terminate+ -- This lets us wait for any exceptions.+ either throwIO return =<< takeMVar doneVar+
+ GUI/MainWindow.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE CPP #-}+-- ThreadScope: a graphical viewer for Haskell event log information.+-- Maintainer: satnams@microsoft.com, s.singh@ieee.org++module GUI.MainWindow (+ MainWindow,+ mainWindowNew,+ MainWindowActions(..),++ setFileLoaded,+ setStatusMessage,+ sidebarSetVisibility,+ eventsSetVisibility,++ ) where++import Paths_threadscope++-- 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+++-------------------------------------------------------------------------------++data MainWindow = MainWindow {+ mainWindow :: Window,++ sidebarBox,+ eventsBox :: Widget,++ statusBar :: Statusbar,+ statusBarCxt :: ContextId+ }++instance Glib.GObjectClass MainWindow where+ toGObject = toGObject . mainWindow+ unsafeCastGObject = error "cannot downcast to MainView type"++instance Gtk.ObjectClass MainWindow+instance Gtk.WidgetClass MainWindow+instance Gtk.ContainerClass MainWindow+instance Gtk.BinClass MainWindow+instance Gtk.WindowClass MainWindow++data MainWindowActions = MainWindowActions {++ -- Menu actions+ mainWinOpen :: IO (),+ mainWinExport :: IO (),+ mainWinQuit :: IO (),+ mainWinViewSidebar :: Bool -> IO (),+ mainWinViewEvents :: Bool -> IO (),+ mainWinViewBW :: Bool -> IO (),+ mainWinViewReload :: IO (),+ mainWinAbout :: IO (),++ -- Toolbar actions+ --TODO: all toolbar actions should also be available from the menu+ mainWinJumpStart :: IO (),+ mainWinJumpEnd :: IO (),+ mainWinJumpCursor :: IO (),+ mainWinJumpZoomIn :: IO (),+ mainWinJumpZoomOut :: IO (),+ mainWinJumpZoomFit :: IO (),+ mainWinScrollLeft :: IO (),+ mainWinScrollRight :: IO (),+ mainWinDisplayLabels :: Bool -> IO ()+ }++-------------------------------------------------------------------------------++setFileLoaded :: MainWindow -> Maybe FilePath -> IO ()+setFileLoaded mainWin Nothing =+ set (mainWindow mainWin) [+ windowTitle := "ThreadScope"+ ]+setFileLoaded mainWin (Just file) =+ set (mainWindow mainWin) [+ windowTitle := file ++ " - ThreadScope"+ ]++setStatusMessage :: MainWindow -> String -> IO ()+setStatusMessage mainWin msg = do+ statusbarPop (statusBar mainWin) (statusBarCxt mainWin)+ statusbarPush (statusBar mainWin) (statusBarCxt mainWin) (' ':msg)+ return ()++sidebarSetVisibility :: MainWindow -> Bool -> IO ()+sidebarSetVisibility mainWin visible =+ set (sidebarBox mainWin) [ widgetVisible := visible ]++eventsSetVisibility :: MainWindow -> Bool -> IO ()+eventsSetVisibility mainWin visible =+ set (eventsBox mainWin) [ widgetVisible := visible ]++-------------------------------------------------------------------------------++mainWindowNew :: Builder -> MainWindowActions -> IO MainWindow+mainWindowNew builder actions = do++ let getWidget cast name = builderGetObject builder cast name+++ mainWindow <- getWidget castToWindow "main_window"+ statusBar <- getWidget castToStatusbar "statusbar"++ sidebarBox <- getWidget castToWidget "sidebar"+ eventsBox <- getWidget castToWidget "eventsbox"++ bwToggle <- getWidget castToCheckMenuItem "black_and_white"+ 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"+ 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++ zoomInButton <- getWidget castToToolButton "cpus_zoomin"+ zoomOutButton <- getWidget castToToolButton "cpus_zoomout"+ zoomFitButton <- getWidget castToToolButton "cpus_zoomfit"++ showLabelsToggle <- getWidget castToToggleToolButton "cpus_showlabels"+ firstButton <- getWidget castToToolButton "cpus_first"+ lastButton <- getWidget castToToolButton "cpus_last"+ centreButton <- getWidget castToToolButton "cpus_centre"++ --TODO: these two are currently unbound, but they should be!+ -- eventsTextEntry <- getWidget castToEntry "events_entry"+ -- eventsFindButton <- getWidget castToToolButton "events_find"++ ------------------------------------------------------------------------++ widgetSetAppPaintable mainWindow True --TODO: Really?++ logoPath <- getDataFileName "threadscope.png"+ windowSetIconFromFile mainWindow logoPath++ ------------------------------------------------------------------------+ -- Status bar functionality++ statusBarCxt <- statusbarGetContextId statusBar "file"+ statusbarPush statusBar statusBarCxt "No eventlog loaded."++ ------------------------------------------------------------------------+ -- Bind all the events+ + -- Menus+ on openMenuItem menuItemActivate $ mainWinOpen actions+ on exportMenuItem menuItemActivate $ mainWinExport actions++ on quitMenuItem menuItemActivate $ mainWinQuit actions+ on mainWindow objectDestroy $ mainWinQuit actions++ on sidebarToggle checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle+ >>= mainWinViewSidebar actions+ on eventsToggle checkMenuItemToggled $ checkMenuItemGetActive eventsToggle+ >>= mainWinViewEvents actions+ on bwToggle checkMenuItemToggled $ checkMenuItemGetActive bwToggle+ >>= mainWinViewBW actions+ on reloadMenuItem menuItemActivate $ mainWinViewReload actions++ on aboutMenuItem menuItemActivate $ mainWinAbout actions++ -- Toolbar + onToolButtonClicked firstButton $ mainWinJumpStart actions+ onToolButtonClicked lastButton $ mainWinJumpEnd actions+ onToolButtonClicked centreButton $ mainWinJumpCursor 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
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveDataTypeable #-}++module GUI.ProgressView (+ ProgressView,+ withProgress,+ setText,+ setTitle,+ setProgress,+ startPulse,+ ) where++import Graphics.UI.Gtk as Gtk hiding (eventKeyName)+import Graphics.UI.Gtk.Gdk.Events+import GUI.GtkExtras++import qualified Control.Concurrent as Concurrent+import Control.Exception+import Data.Typeable++import Prelude hiding (catch)+++data ProgressView = ProgressView {+ progressWindow :: Gtk.Window,+ progressLabel :: Gtk.Label,+ progressBar :: Gtk.ProgressBar+ }++-- | Perform a long-running operation and display a progress window. The+-- operation has access to the progress window and it is expected to update it+-- using 'setText' and 'setProgress'+--+-- The user may cancel the operation at any time.+--+withProgress :: WindowClass win => win -> (ProgressView -> IO a) -> IO (Maybe a)+withProgress parent action = do+ self <- Concurrent.myThreadId+ let cancel = throwTo self OperationInterrupted+ bracket (new parent cancel) close $ \progress ->+ fmap Just (action progress)+ `catch` \OperationInterrupted -> return Nothing++data OperationInterrupted = OperationInterrupted+ deriving (Typeable, Show)+instance Exception OperationInterrupted++setText :: ProgressView -> String -> IO ()+setText view msg =+ set (progressBar view) [+ progressBarText := msg+ ]++setTitle :: ProgressView -> String -> IO ()+setTitle view msg = do+ set (progressWindow view) [ windowTitle := msg ]+ set (progressLabel view) [ labelLabel := "<b>" ++ msg ++ "</b>" ]++startPulse :: ProgressView -> IO (IO ())+startPulse view = do+ let pulse = do+ progressBarPulse (progressBar view)+ Concurrent.threadDelay 200000+ pulse+ thread <- Concurrent.forkIO $+ pulse `catch` \OperationInterrupted -> return ()+ let stop = throwTo thread OperationInterrupted+ waitGUI+ return stop++setProgress :: ProgressView -> Int -> Int -> IO ()+setProgress view total current = do+ let frac = fromIntegral current / fromIntegral total+ set (progressBar view) [ progressBarFraction := frac ]+ waitGUI++close :: ProgressView -> IO ()+close view = widgetDestroy (progressWindow view)++new :: WindowClass win => win -> IO () -> IO ProgressView+new parent cancelAction = do+ win <- windowNew+ set win [+ containerBorderWidth := 10,+ windowTitle := "",+ windowTransientFor := toWindow parent,+ windowModal := True,+ windowWindowPosition := WinPosCenterOnParent,+ windowDefaultWidth := 400,+ windowSkipTaskbarHint := True+ ]++ progText <- labelNew Nothing+ set progText [+ miscXalign := 0,+ labelUseMarkup := True+ ]++ progress <- progressBarNew++ 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++ vbox <- vBoxNew False 20+ hbox <- hBoxNew False 0+ boxPackStart vbox progText PackRepel 10+ boxPackStart vbox progress PackGrow 5+ boxPackStart vbox hbox PackNatural 5+ boxPackEnd hbox cancel PackNatural 0+ containerAdd win vbox++ widgetShowAll win++ return ProgressView {+ progressWindow = win,+ progressLabel = progText,+ progressBar = progress+ }
+ GUI/SaveAs.hs view
@@ -0,0 +1,39 @@+module GUI.SaveAs (saveAsPDF, saveAsPNG) where++-- Imports for ThreadScope+import GUI.Timeline.Render (renderTraces)+import GUI.Types+import Events.HECs++-- Imports for GTK+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++ where+ w = width viewParams; w' = fromIntegral w+ h = height viewParams; h' = fromIntegral h++-------------------------------------------------------------------------------
+ GUI/Timeline.hs view
@@ -0,0 +1,317 @@+module GUI.Timeline (+ TimelineView,+ timelineViewNew,+ TimelineViewActions(..),++ timelineSetBWMode,+ timelineSetShowLabels,+ timelineGetViewParameters,+ timelineWindowSetHECs,+ timelineWindowSetTraces,+ timelineWindowSetBookmarks,+ timelineSetCursor,++ timelineZoomIn,+ timelineZoomOut,+ timelineZoomToFit,+ timelineScrollLeft,+ timelineScrollRight,+ timelineScrollToBeginning,+ timelineScrollToEnd,+ timelineCentreOnCursor,+ ) where++import GUI.Timeline.Types (TimelineState(..))+import GUI.Timeline.Motion+import GUI.Timeline.Render++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 Data.IORef+import Control.Monad++-----------------------------------------------------------------------------+-- The CPUs view++data TimelineView = TimelineView {++ timelineState :: TimelineState,++ hecsIORef :: IORef (Maybe HECs),+ tracesIORef :: IORef [Trace],+ bookmarkIORef :: IORef [Timestamp],++ cursorIORef :: IORef Timestamp,+ showLabelsIORef :: IORef Bool,+ bwmodeIORef :: IORef Bool+ }++data TimelineViewActions = TimelineViewActions {+ timelineViewCursorChanged :: Timestamp -> 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+ widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))++timelineGetViewParameters :: TimelineView -> IO ViewParameters+timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, showLabelsIORef, timelineState=TimelineState{..}} = do++ (dAreaWidth,_) <- widgetGetSize timelineDrawingArea+ scaleValue <- readIORef scaleIORef++ -- snap the view to whole pixels, to avoid blurring+ hadj_value0 <- adjustmentGetValue timelineAdj+ let hadj_value = toWholePixels scaleValue hadj_value0++ traces <- readIORef tracesIORef+ bwmode <- readIORef bwmodeIORef+ showLabels <- readIORef showLabelsIORef++ let timelineHeight = calculateTotalTimelineHeight showLabels traces++ return ViewParameters {+ width = dAreaWidth,+ height = timelineHeight,+ viewTraces = traces,+ hadjValue = hadj_value,+ scaleValue = scaleValue,+ detail = 3, --for now+ bwMode = bwmode,+ labelsMode = showLabels+ }+++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++timelineWindowSetTraces :: TimelineView -> [Trace] -> IO ()+timelineWindowSetTraces timelineWin@TimelineView{tracesIORef} traces = do+ writeIORef tracesIORef traces+ timelineParamsChanged timelineWin++timelineWindowSetBookmarks :: TimelineView -> [Timestamp] -> IO ()+timelineWindowSetBookmarks timelineWin@TimelineView{bookmarkIORef} bookmarks = do+ writeIORef bookmarkIORef bookmarks+ timelineParamsChanged timelineWin++-----------------------------------------------------------------------------++timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView+timelineViewNew builder 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++ hecsIORef <- newIORef Nothing+ tracesIORef <- newIORef []+ bookmarkIORef <- newIORef []+ scaleIORef <- newIORef defaultScaleValue+ cursorIORef <- newIORef 0+ bwmodeIORef <- newIORef False+ showLabelsIORef <- 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++ ------------------------------------------------------------------------+ -- Allow mouse wheel to be used for zoom in/out+ on timelineDrawingArea 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+ (ScrollUp, []) -> vscrollUp timelineState+ (ScrollDown, []) -> vscrollDown timelineState+ _ -> return ()++ ------------------------------------------------------------------------+ -- Mouse button++ 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++ return True+ _other -> do+ return False++ onValueChanged timelineAdj $ queueRedrawTimelines timelineState+ onValueChanged timelineVAdj $ queueRedrawTimelines timelineState+ onAdjChanged timelineAdj $ queueRedrawTimelines timelineState+ onAdjChanged timelineVAdj $ queueRedrawTimelines timelineState++ on timelineDrawingArea exposeEvent $ do+ exposeRegion <- New.eventRegion+ liftIO $ do+ maybeEventArray <- readIORef hecsIORef++ -- Check to see if an event trace has been loaded+ case maybeEventArray of+ Nothing -> return ()+ Just hecs -> do+ params <- timelineGetViewParameters timelineWin+ -- 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+ bookmarks <- readIORef bookmarkIORef++ renderView timelineState params' hecs cursor bookmarks exposeRegion++ return True++ on timelineDrawingArea configureEvent $ do+ liftIO $ configureTimelineDrawingArea timelineWin+ return True++ return timelineWin++-------------------------------------------------------------------------------+-- 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++--FIXME: we are still unclear about which state changes involve which updates+timelineParamsChanged :: TimelineView -> IO ()+timelineParamsChanged timelineWin@TimelineView{timelineState} = do+ queueRedrawTimelines timelineState+ updateTimelineVScroll timelineWin++configureTimelineDrawingArea :: TimelineView -> IO ()+configureTimelineDrawingArea timelineWin@TimelineView{timelineState} = do+ updateTimelineVScroll timelineWin+ updateTimelineHPageSize timelineState++updateTimelineVScroll :: TimelineView -> IO ()+updateTimelineVScroll TimelineView{tracesIORef, showLabelsIORef, timelineState=TimelineState{..}} = do+ traces <- readIORef tracesIORef+ showLabels <- readIORef showLabelsIORef+ let h = calculateTotalTimelineHeight showLabels traces+ (_,winh) <- widgetGetSize timelineDrawingArea+ let winh' = fromIntegral winh; h' = fromIntegral h+ adjustmentSetLower timelineVAdj 0+ adjustmentSetUpper timelineVAdj h'++ val <- adjustmentGetValue timelineVAdj+ when (val > h') $ adjustmentSetValue timelineVAdj h'++ set timelineVAdj [+ adjustmentPageSize := winh',+ adjustmentStepIncrement := winh' * 0.1,+ adjustmentPageIncrement := winh' * 0.9+ ]++-- when the drawing area is resized, we update the page size of the+-- adjustment. Everything else stays the same: we don't scale or move+-- the view at all.+updateTimelineHPageSize :: TimelineState -> IO ()+updateTimelineHPageSize TimelineState{..} = do+ (winw,_) <- widgetGetSize timelineDrawingArea+ scaleValue <- readIORef scaleIORef+ adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue)++-------------------------------------------------------------------------------+-- Set the cursor to a new position++timelineSetCursor :: TimelineView -> Timestamp -> IO ()+timelineSetCursor TimelineView{..} ts = do+ writeIORef cursorIORef ts+ queueRedrawTimelines timelineState++-------------------------------------------------------------------------------++timelineZoomIn :: TimelineView -> IO ()+timelineZoomIn TimelineView{..} = do+ cursor <- readIORef cursorIORef+ zoomIn timelineState cursor++timelineZoomOut :: TimelineView -> IO ()+timelineZoomOut TimelineView{..} = do+ cursor <- readIORef cursorIORef+ zoomOut timelineState cursor++timelineZoomToFit :: TimelineView -> IO ()+timelineZoomToFit TimelineView{..} = do+ mhecs <- readIORef hecsIORef+ zoomToFit timelineState mhecs++timelineScrollLeft :: TimelineView -> IO ()+timelineScrollLeft TimelineView{timelineState} = scrollLeft timelineState++timelineScrollRight :: TimelineView -> IO ()+timelineScrollRight TimelineView{timelineState} = scrollRight timelineState++timelineScrollToBeginning :: TimelineView -> IO ()+timelineScrollToBeginning TimelineView{timelineState} =+ scrollToBeginning timelineState++timelineScrollToEnd :: TimelineView -> IO ()+timelineScrollToEnd TimelineView{timelineState} =+ scrollToEnd timelineState++-- 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.++defaultScaleValue :: Double+defaultScaleValue = -1.0
+ GUI/Timeline/Activity.hs view
@@ -0,0 +1,173 @@+module GUI.Timeline.Activity (+ renderActivity+ ) where++import GUI.Timeline.Render.Constants++import Events.HECs+import Events.EventTree+import Events.EventDuration+import GUI.Types+import GUI.ViewerColours++import Graphics.Rendering.Cairo++import Control.Monad+import Data.List++-- ToDo:+-- - we average over the slice, but the point is drawn at the beginning+-- of the slice rather than in the middle.++-----------------------------------------------------------------------------++renderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp+ -> Render ()++renderActivity ViewParameters{..} hecs start0 end0 = do+ let+ slice = round (fromIntegral activity_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++ 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++activity_detail :: Int+activity_detail = 4 -- in pixels++-- for each timeslice, the amount of time spent in the mutator+-- during that period.+actProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp]+actProfile slice start0 end0 t+ = {- trace (show flat) $ -} chopped++ where+ -- do an extra slice at both ends+ start = if start0 < slice then start0 else start0 - slice+ end = end0 + slice++ flat = flatten start t []+ chopped0 = chop 0 start flat++ chopped | start0 < slice = 0 : chopped0+ | otherwise = chopped0++ flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree]+ flatten _start DurationTreeEmpty rest = rest+ flatten start t@(DurationSplit s split e l r _run _) rest+ | e <= start = rest+ | end <= s = rest+ | start >= split = flatten start r rest+ | end <= split = flatten start l rest+ | e - s > slice = flatten start l $ flatten start r rest+ | otherwise = t : rest+ flatten _start t@(DurationTreeLeaf _) rest+ = t : rest++ chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp]+ chop sofar start _ts+ | start >= end = if sofar > 0 then [sofar] else []+ chop sofar start []+ = sofar : chop 0 (start+slice) []+ chop sofar start (t : ts)+ | e <= start+ = if sofar /= 0+ then error "chop"+ else chop sofar start ts+ | s >= start + slice+ = sofar : chop 0 (start + slice) (t : ts)+ | e > start + slice+ = (sofar + time_in_this_slice t) : chop 0 (start + slice) (t : ts)+ | otherwise+ = chop (sofar + time_in_this_slice t) start ts+ where+ (s, e)+ | DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev)+ | DurationSplit s _ e _ _ _run _ <- t = (s, e)++ duration = min (start+slice) e - max start s++ time_in_this_slice t = case t of+ DurationTreeLeaf ThreadRun{} -> duration+ DurationTreeLeaf _ -> 0+ DurationSplit _ _ _ _ _ run _ ->+ round (fromIntegral (run * duration) / fromIntegral (e-s))+ DurationTreeEmpty -> error "time_in_this_slice"++drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp]+ -> Render ()+drawActivity hecs start end slice ts = do+ case ts of+ [] -> return ()+ t:ts -> do+-- liftIO $ printf "ts: %s\n" (show (t:ts))+-- liftIO $ printf "off: %s\n" (show (map off (t:ts) :: [Double]))+ let dstart = fromIntegral start+ dend = fromIntegral end+ dslice = fromIntegral slice+ dheight = fromIntegral activityGraphHeight++-- funky gradients don't seem to work:+-- withLinearPattern 0 0 0 dheight $ \pattern -> do+-- patternAddColorStopRGB pattern 0 0.8 0.8 0.8+-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0+-- rectangle dstart 0 dend dheight+-- setSource pattern+-- fill++ newPath+ 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+ fill++-- funky gradients don't seem to work:+-- save+-- withLinearPattern 0 0 0 dheight $ \pattern -> do+-- patternAddColorStopRGB pattern 0 0 1.0 0+-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0+-- setSource pattern+-- -- identityMatrix+-- -- setFillRule FillRuleEvenOdd+-- fillPreserve+-- restore++ save+ forM_ [0 .. hecCount hecs - 1] $ \h -> do+ let y = fromIntegral (floor (fromIntegral h * dheight / fromIntegral (hecCount hecs))) - 0.5+ setSourceRGBAhex black 0.3+ moveTo dstart y+ lineTo dend y+ dashedLine1+ restore++ where+ off t = fromIntegral activityGraphHeight -+ fromIntegral (t * fromIntegral activityGraphHeight) /+ fromIntegral (fromIntegral (hecCount hecs) * slice)++dashedLine1 :: Render ()+dashedLine1 = do+ save+ identityMatrix+ setDash [10,10] 0.0+ setLineWidth 1+ stroke+ restore
+ GUI/Timeline/CairoDrawing.hs view
@@ -0,0 +1,96 @@+-------------------------------------------------------------------------------+--- $Id: CairoDrawing.hs#3 2009/07/18 22:48:30 REDMOND\\satnams $+--- $Source: //depot/satnams/haskell/ThreadScope/CairoDrawing.hs $+-------------------------------------------------------------------------------++module GUI.Timeline.CairoDrawing+where++import Graphics.Rendering.Cairo+import qualified Graphics.Rendering.Cairo as C+import Control.Monad++-------------------------------------------------------------------------------++{-# INLINE draw_line #-}+draw_line :: (Integral a, Integral b, Integral c, Integral d) =>+ (a, b) -> (c, d) -> Render ()+draw_line (x0, y0) (x1, y1)+ = do move_to (x0, y0)+ lineTo (fromIntegral x1) (fromIntegral y1)+ stroke++{-# INLINE move_to #-}+move_to :: (Integral a, Integral b) => (a, b) -> Render ()+move_to (x, y)+ = moveTo (fromIntegral x) (fromIntegral y)++{-# INLINE rel_line_to #-}+rel_line_to :: (Integral a, Integral b) => (a, b) -> Render ()+rel_line_to (x, y)+ = relLineTo (fromIntegral x) (fromIntegral y)++-------------------------------------------------------------------------------++{-# INLINE draw_rectangle #-}+draw_rectangle :: (Integral x, Integral y, Integral w, Integral h)+ => x -> y -> w -> h+ -> Render ()+draw_rectangle x y w h = do+ rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+ C.fill++-------------------------------------------------------------------------------++{-# INLINE draw_outlined_rectangle #-}+draw_outlined_rectangle :: (Integral x, Integral y, Integral w, Integral h)+ => x -> y -> w -> h+ -> Render ()+draw_outlined_rectangle x y w h = do+ rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+ fillPreserve+ setLineWidth 1+ setSourceRGBA 0 0 0 0.7+ stroke++-------------------------------------------------------------------------------++{-# INLINE draw_rectangle_opt #-}+draw_rectangle_opt :: (Integral x, Integral y, Integral w, Integral h)+ => Bool -> x -> y -> w -> h+ -> Render ()+draw_rectangle_opt opt x y w h+ = draw_rectangle_opt' opt (fromIntegral x) (fromIntegral y)+ (fromIntegral w) (fromIntegral h)++draw_rectangle_opt' :: Bool -> Double -> Double -> Double -> Double+ -> Render ()+draw_rectangle_opt' opt x y w h+ = do rectangle x y (1.0 `max` w) h+ C.fill+ when opt $ do+ setLineWidth 1+ setSourceRGBA 0 0 0 0.7+ rectangle x y w h+ stroke++-------------------------------------------------------------------------------++{-# INLINE draw_rectangle_outline #-}+draw_rectangle_outline :: (Integral x, Integral y, Integral w, Integral h)+ => x -> y -> w -> h+ -> Render ()+draw_rectangle_outline x y w h = do+ setLineWidth 2+ rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+ stroke++-------------------------------------------------------------------------------++clearWhite :: Render ()+clearWhite = do+ save+ setOperator OperatorSource+ setSourceRGBA 0xffff 0xffff 0xffff 0xffff+ paint+ restore
+ GUI/Timeline/HEC.hs view
@@ -0,0 +1,259 @@+module GUI.Timeline.HEC (+ renderHEC+ ) where++import GUI.Timeline.Render.Constants++import Events.EventTree+import Events.EventDuration+import GUI.Types+import GUI.Timeline.CairoDrawing+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)++import Control.Monad++renderHEC :: ViewParameters+ -> Timestamp -> Timestamp -> (DurationTree,EventTree)+ -> Render ()+renderHEC params@ViewParameters{..} start end (dtree,etree) = do+ renderDurations params start end dtree+ when (scaleValue < detailThreshold) $+ case etree of+ EventTree ltime etime tree ->+ renderEvents params ltime etime start end tree++detailThreshold :: Double+detailThreshold = 3000++-------------------------------------------------------------------------------+-- hecView draws the trace for a single HEC++renderDurations :: ViewParameters+ -> Timestamp -> Timestamp -> DurationTree+ -> Render ()++renderDurations _ _ _ DurationTreeEmpty = return ()++renderDurations params@ViewParameters{..} startPos endPos (DurationTreeLeaf e)+ | inView startPos endPos e = drawDuration params e+ | otherwise = return ()++renderDurations params@ViewParameters{..} !startPos !endPos+ (DurationSplit s splitTime e lhs rhs runAv gcAv)+ | startPos < splitTime && endPos >= splitTime &&+ (fromIntegral (e - s) / scaleValue) <= fromIntegral detail+ = -- View spans both left and right sub-tree.+ -- trace (printf "hecView (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $+ drawAverageDuration params s e runAv gcAv++ | otherwise+ = -- trace (printf "hecView: start:%d end:%d s:%d e:%d" startPos endPos s e) $+ do when (startPos < splitTime) $+ renderDurations params startPos endPos lhs+ when (endPos >= splitTime) $+ renderDurations params startPos endPos rhs++-------------------------------------------------------------------------------++renderEvents :: ViewParameters+ -> Timestamp -- start time of this tree node+ -> Timestamp -- end time of this tree node+ -> Timestamp -> Timestamp -> EventNode+ -> Render ()++renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos+ (EventTreeLeaf es)+ = sequence_ [ drawEvent params e+ | e <- es, let t = time e, t >= startPos && t < endPos ]+renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos+ (EventTreeOne ev)+ | t >= startPos && t < endPos = drawEvent params ev+ | otherwise = return ()+ where t = time ev++renderEvents params@ViewParameters{..} !s !e !startPos !endPos+ (EventSplit splitTime lhs rhs)+ | startPos < splitTime && endPos >= splitTime &&+ (fromIntegral (e - s) / scaleValue) <= fromIntegral detail+ = drawTooManyEvents params s e++ | otherwise+ = do when (startPos < splitTime) $+ renderEvents params s splitTime startPos endPos lhs+ when (endPos >= splitTime) $+ renderEvents params splitTime e startPos endPos rhs++-------------------------------------------------------------------------------+-- 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++-------------------------------------------------------------------------------++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++ where+ duration = endTime - startTime+-- runRatio :: Double+-- runRatio = (fromIntegral runAv) / (fromIntegral duration)+ gcRatio :: Double+ gcRatio = (fromIntegral gcAv) / (fromIntegral duration)++-------------------------------------------------------------------------------++unscaledText :: String -> Render ()+unscaledText text+ = do m <- getMatrix+ identityMatrix+ textPath text+ C.fill+ setMatrix m++-------------------------------------------------------------------------------++textWidth :: Double -> String -> Render TextExtents+textWidth _scaleValue text+ = do m <- getMatrix+ identityMatrix+ tExtent <- textExtents text+ setMatrix m+ return tExtent++-------------------------------------------------------------------------------++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++ -- 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++drawDuration ViewParameters{..} (GCWork startTime endTime)+ = gcBar (if bwMode then black else gcWorkColour) startTime endTime++drawDuration ViewParameters{..} (GCIdle startTime endTime)+ = gcBar (if bwMode then black else gcIdleColour) startTime endTime++drawDuration ViewParameters{..} (GCEnd startTime endTime)+ = 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++labelAt :: Bool -> Timestamp -> String -> Render ()+labelAt labelsMode t str+ | not labelsMode = return ()+ | otherwise = do+ setSourceRGB 0.0 0.0 0.0+ move_to (t, hecBarOff+hecBarHeight+12)+ save+ identityMatrix+ rotate (pi/4)+ textPath str+ C.fill+ 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+ Shutdown{} -> renderInstantEvent params event shutdownColour++ SparkCreate{} -> renderInstantEvent params event createdConvertedColour+ SparkDud{} -> renderInstantEvent params event fizzledDudsColour+ SparkOverflow{} -> renderInstantEvent params event overflowedColour+ SparkRun{} -> renderInstantEvent params event createdConvertedColour+ SparkSteal{} -> renderInstantEvent params event createdConvertedColour+ SparkFizzle{} -> renderInstantEvent params event fizzledDudsColour+ SparkGC{} -> renderInstantEvent params event fizzledDudsColour++ RunThread{} -> return ()+ StopThread{} -> return ()+ StartGC{} -> return ()++ _ -> return ()++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)+++drawTooManyEvents :: ViewParameters -> Timestamp -> Timestamp+ -> Render ()+drawTooManyEvents _params@ViewParameters{..} _start _end = do+ return ()+-- setSourceRGBAhex grey 1.0+-- setLineWidth (3 * scaleValue)+-- draw_rectangle start (hecBarOff-4) (end - start) 4+-- draw_rectangle start (hecBarOff+hecBarHeight) (end - start) 4++-------------------------------------------------------------------------------
+ GUI/Timeline/Motion.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE NamedFieldPuns #-}+module GUI.Timeline.Motion (+ zoomIn, zoomOut, zoomToFit,+ scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, centreOnCursor,+ vscrollDown, vscrollUp,+ ) where++import GUI.Timeline.Types+import GUI.Timeline.Render.Constants+import Events.HECs++import Graphics.UI.Gtk++import Data.IORef+import Control.Monad+-- import Text.Printf+-- import Debug.Trace++-------------------------------------------------------------------------------+-- Zoom in works by expanding the current view such that the+-- left hand edge of the original view remains at the same+-- position and the zoom in factor is 2.+-- For example, zoom into the time range 1.0 3.0+-- produces a new view with the time range 1.0 2.0++zoomIn :: TimelineState -> Timestamp -> IO ()+zoomIn = zoom (/2)++zoomOut :: TimelineState -> Timestamp -> IO ()+zoomOut = zoom (*2)++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++ hadj_value <- adjustmentGetValue timelineAdj+ hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar++ 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 pageshift = 0.9 * newPageSize+ let nudge = 0.1 * newPageSize++ adjustmentSetStepIncrement timelineAdj nudge+ adjustmentSetPageIncrement timelineAdj pageshift++-------------------------------------------------------------------------------++zoomToFit :: TimelineState -> Maybe HECs -> IO ()+zoomToFit TimelineState{scaleIORef, timelineAdj, timelineDrawingArea} mb_hecs = do+ case mb_hecs of+ Nothing -> writeIORef scaleIORef (-1.0) --FIXME: ug!+ 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++ -- 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++ adjustmentSetLower timelineAdj lower+ adjustmentSetValue timelineAdj lower+ adjustmentSetUpper timelineAdj upper+ adjustmentSetPageSize timelineAdj page+ -- TODO: this seems suspicious:+ adjustmentSetStepIncrement timelineAdj 0+ adjustmentSetPageIncrement timelineAdj 0++-------------------------------------------------------------------------------++scrollLeft, scrollRight, scrollToBeginning, scrollToEnd :: TimelineState -> IO ()++scrollLeft = scroll (\val page l _ -> l `max` (val - page/2))+scrollRight = scroll (\val page _ u -> (u - page) `min` (val + page/2))+scrollToBeginning = scroll (\_ _ l _ -> l)+scrollToEnd = scroll (\_ _ _ u -> u)++centreOnCursor :: TimelineState -> Timestamp -> IO ()++centreOnCursor state cursor =+ scroll (\_ page l _u -> max l (fromIntegral cursor - page/2)) state++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++vscrollDown, vscrollUp :: TimelineState -> IO ()+vscrollDown = vscroll (\val page _l u -> (u - page) `min` (val + page/8))+vscrollUp = vscroll (\val page l _u -> l `max` (val - page/8))++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++-- -----------------------------------------------------------------------------
+ GUI/Timeline/Render.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE NamedFieldPuns #-}+module GUI.Timeline.Render (+ renderView,+ renderTraces,+ updateLabelDrawingArea,+ calculateTotalTimelineHeight,+ toWholePixels+ ) where++import GUI.Timeline.Types+import GUI.Timeline.Render.Constants+import GUI.Timeline.Ticks+import GUI.Timeline.HEC+import GUI.Timeline.Sparks+import GUI.Timeline.Activity++import Events.HECs+import GUI.Types+import GUI.ViewerColours+import GUI.Timeline.CairoDrawing++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++-------------------------------------------------------------------------------++-- | This function redraws the currently visible part of the+-- main trace canvas plus related canvases.+--+renderView :: TimelineState+ -> ViewParameters+ -> HECs -> Timestamp -> [Timestamp]+ -> Region -> IO ()+renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView}+ params hecs cursor_t bookmarks exposeRegion = do++ -- Get state information from user-interface components+ (dAreaWidth, _) <- widgetGetSize timelineDrawingArea+ vadj_value <- adjustmentGetValue timelineVAdj++ prev_view <- readIORef timelinePrevView++ rect <- regionGetClipbox exposeRegion++ win <- widgetGetDrawWindow timelineDrawingArea+ renderWithDrawable win $ do++ let renderToNewSurface = do+ new_surface <- withTargetSurface $ \surface ->+ liftIO $ createSimilarSurface surface ContentColor+ dAreaWidth (height params)+ renderWith new_surface $ do+ clearWhite+ renderTraces params hecs rect+ return new_surface++ surface <-+ case prev_view of+ 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++ else do+ renderWith surface $ do+ clearWhite; renderTraces params hecs rect+ return surface++ | otherwise+ -> do surfaceFinish surface+ renderToNewSurface++ liftIO $ writeIORef timelinePrevView (Just (params, surface))++ region exposeRegion+ clip+ setSourceSurface surface 0 (-vadj_value)+ -- ^^ this is where we adjust for the vertical scrollbar+ setOperator OperatorSource+ paint+ when (scaleValue params > 0) $ do+ renderBookmarks bookmarks params+ drawCursor cursor_t params++-------------------------------------------------------------------------------++-- 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 ]++-------------------------------------------------------------------------------++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++-------------------------------------------------------------------------------++-- 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 +-- * the second is to do the conversion ourself+--+-- While in principle the first is superior due to the simplicity: cairo+-- lets us use Double as the logical unit and scaling factor. In practice+-- however cairo does not support the full Double range because internally+-- it makes use of a 32bit fixed point float format. With very large scaling+-- factors we end up with artifacts like lines disappearing.+--+-- So sadly we will probably have to convert to using the second method.++-- | Use cairo to convert from logical units (timestamps) to device units+--+withViewScale :: ViewParameters -> Render () -> Render ()+withViewScale ViewParameters{scaleValue, hadjValue} inner = do+ save+ scale (1/scaleValue) 1.0+ translate (-hadjValue) 0+ inner+ restore++-- | Manually convert from logical units (timestamps) to device units.+--+timestampToView :: ViewParameters -> Timestamp -> Double+timestampToView ViewParameters{scaleValue, hadjValue} ts =+ (fromIntegral ts - hadjValue) / scaleValue++-------------------------------------------------------------------------------+-- This function draws the current view of all the HECs with Cario++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++ 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 (max 0 (hadjValue + scale_width)),+ ceiling (max 0 (hadjValue + scale_rx + scale_rw)),+ hecLastEventTime 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++ -- 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)++-------------------------------------------------------------------------------++-- parameters differ only in the hadjValue, we can scroll ...+scrollView :: Surface+ -> 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++ 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)++ case rect of+ Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y)+ (fromIntegral w) (fromIntegral h)+ setSourceRGBA 0xffff 0xffff 0xffff 0xffff+ fill++ 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++-------------------------------------------------------------------------------++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++--------------------------------------------------------------------------------++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++ traceHeight (TraceHEC _) = hecTraceHeight+ traceHeight (SparkCreationHEC _) = hecSparksHeight+ traceHeight (SparkConversionHEC _) = hecSparksHeight+ traceHeight (SparkPoolHEC _) = hecSparksHeight+ traceHeight TraceActivity = activityGraphHeight+ traceHeight _ = 0++--------------------------------------------------------------------------------++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 _ = "?"++--------------------------------------------------------------------------------++calculateTotalTimelineHeight :: Bool -> [Trace] -> Int+calculateTotalTimelineHeight showLabels traces =+ last (traceYPositions showLabels traces)++--------------------------------------------------------------------------------
+ GUI/Timeline/Render/Constants.hs view
@@ -0,0 +1,52 @@+module GUI.Timeline.Render.Constants (+ ox, oy, firstTraceY, tracePad,+ hecTraceHeight, hecSparksHeight, hecBarOff, hecBarHeight, hecLabelExtra,+ activityGraphHeight,+ ticksHeight, ticksPad+ ) where++-------------------------------------------------------------------------------++-- Origin for graph++ox :: Int+ox = 10++oy :: Int+oy = 30++-- Origin for capability bars++firstTraceY :: Int+firstTraceY = 60++-- Gap betweem traces in the timeline view++tracePad :: Int+tracePad = 20++-- HEC bar height++hecTraceHeight, hecSparksHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int++hecTraceHeight = 40+hecSparksHeight = activityGraphHeight+hecBarHeight = 20+hecBarOff = 10++-- extra space to allow between HECs when labels are on.+-- ToDo: should be calculated somehow+hecLabelExtra = 80++-- Activity graph++activityGraphHeight :: Int+activityGraphHeight = 100++-- Ticks++ticksHeight :: Int+ticksHeight = 20++ticksPad :: Int+ticksPad = 20
+ GUI/Timeline/Sparks.hs view
@@ -0,0 +1,264 @@+module GUI.Timeline.Sparks (+ renderSparkCreation,+ renderSparkConversion,+ renderSparkPool,+ ) where++import GUI.Timeline.Render.Constants++import Events.SparkTree+import qualified Events.SparkStats as SparkStats+import GUI.Types+import GUI.Timeline.CairoDrawing+import GUI.ViewerColours++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.++-- 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.++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+ f3 c = f2 c + SparkStats.rateOverflowed c+ renderSpark params start0 end0 t+ f1 fizzledDudsColour f2 createdConvertedColour f3 overflowedColour+ maxSparkValue++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++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+ 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++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+ 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++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++outlineSparks :: Double+ -> (SparkStats.SparkStats -> Double)+ -> Timestamp -> Timestamp+ -> [SparkStats.SparkStats]+ -> Render ()+outlineSparks maxSliceSpark f start slice ts = do+ case ts of+ [] -> return ()+ ts -> do+ let dstart = fromIntegral start+ dslice = fromIntegral slice+ points = [dstart-dslice/2, dstart+dslice/2 ..]+ t = zip points (map (off maxSliceSpark f) ts)+ newPath+ 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 ()+addSparks colour maxSliceSpark f0 f1 start slice ts = do+ case ts of+ [] -> return ()+ ts -> do+ -- liftIO $ printf "ts: %s\n" (show (map f1 (ts)))+ -- liftIO $ printf "off: %s\n"+ -- (show (map (off maxSliceSpark f1) (ts) :: [Double]))+ let dstart = fromIntegral start+ dslice = fromIntegral slice+ points = [dstart-dslice/2, dstart+dslice/2 ..]+ t0 = zip points (map (off maxSliceSpark f0) ts)+ t1 = zip points (map (off maxSliceSpark f1) ts)+ newPath+ moveTo (dstart-dslice/2) (snd $ head t1)+ mapM_ (uncurry lineTo) t1+ mapM_ (uncurry lineTo) (reverse t0)+ 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++ selectFontFace "sans serif" FontSlantNormal FontWeightNormal+ setFontSize 12+ setSourceRGBAhex blue 1.0+ save+ scale scaleValue 1.0+ setLineWidth 0.5+ drawTicks maxS start scaleValue 0 incr majorTick hecSparksHeight+ 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
@@ -0,0 +1,149 @@+module GUI.Timeline.Ticks (+ renderTicks+ ) where++import GUI.Timeline.Render.Constants+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++-------------------------------------------------------------------------------+-- Minor, semi-major and major ticks are drawn and the absolute periods 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).++-- 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.++-------------------------------------------------------------------------------++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+++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++ 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+-- 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+ 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 :: Num a => a -> String+reformatMS pos+ = deZero (show pos)++-------------------------------------------------------------------------------++deZero :: String -> String+deZero str+ = if length str >= 3 && take 2 revstr == "0." then+ reverse (drop 2 revstr)+ else+ str+ where+ revstr = reverse str++-------------------------------------------------------------------------------+
+ GUI/Timeline/Types.hs view
@@ -0,0 +1,25 @@+module GUI.Timeline.Types (+ TimelineState(..),+ ) where+++import GUI.Types++import Graphics.UI.Gtk+import Graphics.Rendering.Cairo+import Data.IORef++-----------------------------------------------------------------------------++data TimelineState = TimelineState {+ timelineDrawingArea :: DrawingArea,+ timelineLabelDrawingArea :: DrawingArea,+ timelineAdj :: Adjustment,+ timelineVAdj :: Adjustment,++ timelinePrevView :: IORef (Maybe (ViewParameters, Surface)),++ scaleIORef :: IORef Double -- in ns/pixel+ }++-----------------------------------------------------------------------------
+ GUI/TraceView.hs view
@@ -0,0 +1,170 @@+module GUI.TraceView (+ TraceView,+ traceViewNew,+ TraceViewActions(..),+ traceViewSetHECs,+ traceViewGetTraces,+ ) where++import Events.HECs+import GUI.Types++import Graphics.UI.Gtk+import Data.Tree+++-- | Abstract trace view object.+--+data TraceView = TraceView {+ tracesStore :: TreeStore (Trace, Visibility)+ }++data Visibility = Visible | Hidden | MixedVisibility+ deriving Eq++-- | The actions to take in response to TraceView events.+--+data TraceViewActions = TraceViewActions {+ traceViewTracesChanged :: [Trace] -> IO ()+ }++traceViewNew :: Builder -> TraceViewActions -> IO TraceView+traceViewNew builder actions = do++ tracesTreeView <- builderGetObject builder castToTreeView "traces_tree"++ tracesStore <- treeStoreNew []+ traceColumn <- treeViewColumnNew+ textcell <- cellRendererTextNew+ togglecell <- cellRendererToggleNew++ let traceview = TraceView {..}++ treeViewColumnPackStart traceColumn textcell True+ treeViewColumnPackStart traceColumn togglecell False+ treeViewAppendColumn tracesTreeView traceColumn++ treeViewSetModel tracesTreeView tracesStore++ cellLayoutSetAttributes traceColumn textcell tracesStore $ \(tr, _) ->+ [ cellText := renderTrace tr ]++ cellLayoutSetAttributes traceColumn togglecell tracesStore $ \(_, vis) ->+ [ cellToggleActive := vis == Visible+ , cellToggleInconsistent := vis == MixedVisibility ]++ on togglecell cellToggled $ \str -> do+ let path = stringToTreePath str+ Node (trace, visibility) subtrees <- treeStoreGetTree tracesStore path+ let visibility' = invertVisibility visibility+ treeStoreSetValue tracesStore path (trace, visibility')+ updateChildren tracesStore path subtrees visibility'+ updateParents tracesStore (init path)++ traceViewTracesChanged actions =<< traceViewGetTraces traceview++ return traceview++ 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 (TraceGroup label) = label+ renderTrace (TraceActivity) = "Activity Profile"++ updateChildren tracesStore path subtrees visibility' =+ sequence_+ [ do treeStoreSetValue tracesStore path' (trace, visibility')+ updateChildren tracesStore path' subtrees' visibility'+ | (Node (trace, _) subtrees', n) <- zip subtrees [0..]+ , let path' = path ++ [n] ]++ updateParents :: TreeStore (Trace, Visibility) -> TreePath -> IO ()+ updateParents _ [] = return ()+ updateParents tracesStore path = do+ Node (trace, _) subtrees <- treeStoreGetTree tracesStore path+ let visibility = accumVisibility [ vis | subtree <- subtrees+ , (_, vis) <- flatten subtree ]+ treeStoreSetValue tracesStore path (trace, visibility)+ updateParents tracesStore (init path)++ invertVisibility Hidden = Visible+ invertVisibility _ = Hidden++ accumVisibility = foldr1 (\a b -> if a == b then a else MixedVisibility)++-- Find the HEC traces in the treeStore and replace them+traceViewSetHECs :: TraceView -> HECs -> IO ()+traceViewSetHECs TraceView{tracesStore} hecs = do+ treeStoreClear tracesStore+ go 0+ treeStoreInsert tracesStore [] 0 (TraceActivity, Visible)+ where+ newt = Node { rootLabel = (TraceGroup "HEC Traces", Visible),+ subForest = [ Node { rootLabel = (TraceHEC k, Visible),+ subForest = [] }+ | k <- [ 0 .. hecCount hecs - 1 ] ] }+ nCre = Node { rootLabel = (TraceGroup "Spark Creation", Hidden),+ subForest = [ Node { rootLabel = (SparkCreationHEC k, Hidden),+ subForest = [] }+ | k <- [ 0 .. hecCount hecs - 1 ] ] }+ nCon = Node { rootLabel = (TraceGroup "Spark Conversion", Hidden),+ subForest = [ Node { rootLabel = (SparkConversionHEC k, Hidden),+ subForest = [] }+ | k <- [ 0 .. hecCount hecs - 1 ] ] }+ nPoo = Node { rootLabel = (TraceGroup "Spark Pool", Hidden),+ subForest = [ Node { rootLabel = (SparkPoolHEC k, Hidden),+ subForest = [] }+ | k <- [ 0 .. hecCount hecs - 1 ] ] }+ go n = do+ m <- treeStoreLookup tracesStore [n]+ case m of+ Nothing -> do+ treeStoreInsertTree tracesStore [] 0 nPoo+ treeStoreInsertTree tracesStore [] 0 nCon+ treeStoreInsertTree tracesStore [] 0 nCre+ treeStoreInsertTree tracesStore [] 0 newt+ Just t ->+ case t of+ Node { rootLabel = (TraceGroup "HEC Traces", _) } -> do+ treeStoreRemove tracesStore [n]+ treeStoreInsertTree tracesStore [] n newt+ go (n+1)+ Node { rootLabel = (TraceGroup "Spark Creation", _) } -> do+ treeStoreRemove tracesStore [n]+ treeStoreInsertTree tracesStore [] n nCre+ go (n+1)+ Node { rootLabel = (TraceGroup "Spark Conversion", _) } -> do+ treeStoreRemove tracesStore [n]+ treeStoreInsertTree tracesStore [] n nCon+ go (n+1)+ Node { rootLabel = (TraceGroup "Spark Pool", _) } -> do+ treeStoreRemove tracesStore [n]+ treeStoreInsertTree tracesStore [] n nPoo+ go (n+1)+ Node { rootLabel = (TraceActivity, _) } -> do+ treeStoreRemove tracesStore [n]+ go (n+1)+ _ ->+ go (n+1)++traceViewGetTraces :: TraceView -> IO [Trace]+traceViewGetTraces TraceView{tracesStore} = do+ f <- getTracesStoreContents tracesStore+ return [ t | (t, Visible) <- concatMap flatten f, notGroup t ]+ where+ notGroup (TraceGroup _) = False+ notGroup _ = True++getTracesStoreContents :: TreeStore a -> IO (Forest a)+getTracesStoreContents tracesStore = go 0+ where+ go !n = do+ m <- treeStoreLookup tracesStore [n]+ case m of+ Nothing -> return []+ Just t -> do+ ts <- go (n+1)+ return (t:ts)
+ GUI/Types.hs view
@@ -0,0 +1,31 @@+module GUI.Types (+ ViewParameters(..),+ Trace(..),+ ) where++import GHC.RTS.Events++-----------------------------------------------------------------------------++data Trace+ = TraceHEC Int+ | SparkCreationHEC Int+ | SparkConversionHEC Int+ | SparkPoolHEC Int+ | TraceThread ThreadId+ | TraceGroup String+ | TraceActivity+ -- more later ...+ deriving Eq++-- the parameters for a timeline render; used to figure out whether+-- we're drawing the same thing twice.+data ViewParameters = ViewParameters {+ width, height :: Int,+ viewTraces :: [Trace],+ hadjValue :: Double,+ scaleValue :: Double,+ detail :: Int,+ bwMode, labelsMode :: Bool+ }+ deriving Eq
+ GUI/ViewerColours.hs view
@@ -0,0 +1,130 @@+-------------------------------------------------------------------------------+--- $Id: ViewerColours.hs#2 2009/07/18 22:48:30 REDMOND\\satnams $+--- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $+-------------------------------------------------------------------------------++module GUI.ViewerColours where++import Graphics.UI.Gtk+import Graphics.Rendering.Cairo++-------------------------------------------------------------------------------++-- Colours++runningColour :: Color+runningColour = green++gcColour :: Color+gcColour = orange++gcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color+gcStartColour = orange+gcWorkColour = green+gcIdleColour = white+gcEndColour = orange++createThreadColour :: Color+createThreadColour = lightBlue++threadRunnableColour :: Color+threadRunnableColour = darkGreen++seqGCReqColour :: Color+seqGCReqColour = cyan++parGCReqColour :: Color+parGCReqColour = darkBlue++migrateThreadColour :: Color+migrateThreadColour = darkRed++threadWakeupColour :: Color+threadWakeupColour = purple++shutdownColour :: Color+shutdownColour = darkBrown++labelTextColour :: Color+labelTextColour = black++bookmarkColour :: Color+bookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish++fizzledDudsColour, createdConvertedColour, overflowedColour :: Color+fizzledDudsColour = grey+createdConvertedColour = green+overflowedColour = red++outerPercentilesColour :: Color+outerPercentilesColour = lightGrey++-------------------------------------------------------------------------------++black :: Color+black = Color 0 0 0++grey :: Color+grey = Color 0x8000 0x8000 0x8000++lightGrey :: Color+lightGrey = Color 0xD000 0xD000 0xD000++red :: Color+red = Color 0xFFFF 0 0++green :: Color+green = Color 0 0xFFFF 0++darkGreen :: Color+darkGreen = Color 0x0000 0x6600 0x0000++blue :: Color+blue = Color 0 0 0xFFFF++cyan :: Color+cyan = Color 0 0xFFFF 0xFFFF++magenta :: Color+magenta = Color 0xFFFF 0 0xFFFF++lightBlue :: Color+lightBlue = Color 0x6600 0x9900 0xFF00++darkBlue :: Color+darkBlue = Color 0 0 0xBB00++purple :: Color+purple = Color 0x9900 0x0000 0xcc00++darkPurple :: Color+darkPurple = Color 0x6600 0 0x6600++darkRed :: Color+darkRed = Color 0xcc00 0x0000 0x0000++orange :: Color+orange = Color 0xFFFF 0x9900 0x0000 -- orange++profileBackground :: Color+profileBackground = Color 0xFFFF 0xFFFF 0xFFFF++tickColour :: Color+tickColour = Color 0x3333 0x3333 0xFFFF++darkBrown :: Color+darkBrown = Color 0x6600 0 0++yellow :: Color+yellow = Color 0xff00 0xff00 0x3300++white :: Color+white = Color 0xffff 0xffff 0xffff++-------------------------------------------------------------------------------+setSourceRGBAhex :: Color -> Double -> Render ()+setSourceRGBAhex (Color r g b) t+ = setSourceRGBA (fromIntegral r/0xFFFF) (fromIntegral g/0xFFFF)+ (fromIntegral b/0xFFFF) t++-------------------------------------------------------------------------------
+ Main.hs view
@@ -0,0 +1,82 @@+-- ThreadScope: a graphical viewer for Haskell event log information.+-- Maintainer: satnams@microsoft.com, s.singh@ieee.org++module Main where++import GUI.Main (runGUI)++import System.Environment+import System.Exit+import System.Console.GetOpt+import Data.Version (showVersion)+import Paths_threadscope (version)++-------------------------------------------------------------------------------++main :: IO ()+main = do+ args <- getArgs+ (flags, args') <- parseArgs args+ handleArgs flags args'++handleArgs :: Flags -> [String] -> IO ()+handleArgs flags args+ | flagHelp flags = printHelp+ | flagVersion flags = printVersion+ | otherwise = do++ initialTrace <- case (args, flagTest flags) of+ ([filename], Nothing) -> return (Just (Left filename))+ ([], Just tracename) -> return (Just (Right tracename))+ ([], Nothing) -> return Nothing+ _ -> printUsage >> exitFailure++ runGUI initialTrace++ where+ printVersion = putStrLn ("ThreadScope version " ++ showVersion version)+ printUsage = putStrLn usageHeader+ usageHeader = "Usage: threadscope [eventlog]\n" +++ " or: threadscope [FLAGS]"+ helpHeader = usageHeader ++ "\n\nFlags: "+ printHelp = putStrLn (usageInfo helpHeader flagDescrs)++-------------------------------------------------------------------------------++data Flags = Flags {+ flagTest :: Maybe FilePath,+ flagVersion :: Bool,+ flagHelp :: Bool+ }++defaultFlags :: Flags+defaultFlags = Flags Nothing False False++flagDescrs :: [OptDescr (Flags -> Flags)]+flagDescrs =+ [ Option ['h'] ["help"]+ (NoArg (\flags -> flags { flagHelp = True }))+ "Show this help text"++ , Option ['v'] ["version"]+ (NoArg (\flags -> flags { flagVersion = True }))+ "Program version"++ , Option ['t'] ["test"]+ (ReqArg (\name flags -> flags { flagTest = Just name }) "NAME")+ "Load a named internal test (see Events/TestEvents.hs)"+ ]++parseArgs :: [String] -> IO (Flags, [String])+parseArgs args+ | flagHelp flags = return (flags, args')+ | not (null errs) = printErrors errs+ | otherwise = return (flags, args')++ where+ (flags0, args', errs) = getOpt Permute flagDescrs args+ flags = foldr (flip (.)) id flags0 defaultFlags++ printErrors errs = do+ putStrLn $ concat errs ++ "Try --help."+ exitFailure
− Options.hs
@@ -1,26 +0,0 @@-module Options -where - -------------------------------------------------------------------------------- - -data Option - = Debug - | Filename String - | TestTrace String - deriving Eq - -------------------------------------------------------------------------------- - -parseOptions :: [String] -> [Option] -parseOptions [] = [] -parseOptions ("--debug":rest) - = Debug : parseOptions rest -parseOptions ("--test":rest) - = if rest == [] then - error ("--test needs an argument") - else - TestTrace (head rest) : parseOptions (tail rest) -parseOptions (filename:rest) - = Filename filename : parseOptions rest - ------------------------------------------------------------------------------
− ReadEvents.hs
@@ -1,190 +0,0 @@-module ReadEvents ( - registerEventsFromFile, registerEventsFromTrace - ) where - -import EventTree -import State -import TestEvents -import EventDuration -import Timeline -import Traces -import Utils - -import Graphics.UI.Gtk hiding (on) - -import qualified GHC.RTS.Events as GHCEvents -import GHC.RTS.Events hiding (Event) - -import System.IO -import Data.Array -import qualified Data.Function -import Data.IORef -import Data.List -import Text.Printf -import System.FilePath -import Control.Monad -import Data.Function -import Control.Concurrent -import Control.Exception - -------------------------------------------------------------------------------- --- The GHC.RTS.Events library returns the profile information --- in a data-streucture which contains a list data structure --- representing the events i.e. [GHCEvents.Event] --- ThreadScope transforms this list into an alternative representation --- which (for each HEC) records event *durations* which are ordered in time. --- The durations represent the run-lengths for thread execution and --- run-lengths for garbage colleciton. This data-structure is called --- EventDuration. --- ThreadScope then transformations this data-structure into another --- data-structure which gives a binary-tree view of the event information --- by performing a binary split on the time domain i.e. the EventTree --- data structure. - --- GHCEvents.Event => [EventDuration] => EventTree - -------------------------------------------------------------------------------- - -rawEventsToHECs :: [(Maybe Int, [GHCEvents.Event])] -> Timestamp - -> [(DurationTree,EventTree)] -rawEventsToHECs eventList endTime - = map (toTree . flip lookup heclists) [0 .. maximum0 (map fst heclists)] - where - heclists = [ (h,events) | (Just h,events) <- eventList ] - - toTree Nothing = (DurationTreeEmpty, EventTree 0 0 (EventTreeLeaf [])) - toTree (Just evs) = - ( mkDurationTree (eventsToDurations nondiscrete) endTime, - mkEventTree discrete endTime ) - where (discrete,nondiscrete) = partition isDiscreteEvent evs - -------------------------------------------------------------------------------- - --- XXX: what's this for? -maximum0 :: (Num a, Ord a) => [a] -> a -maximum0 [] = -1 -maximum0 x = maximum x - -------------------------------------------------------------------------------- - -registerEventsFromFile :: String -> ViewerState -> IO () -registerEventsFromFile filename state = registerEvents (Left filename) state - -registerEventsFromTrace :: String -> ViewerState -> IO () -registerEventsFromTrace traceName state = registerEvents (Right traceName) state - -registerEvents :: Either FilePath String - -> ViewerState - -> IO () - -registerEvents from state@ViewerState{..} = do - - let msg = case from of - Left filename -> filename - Right test -> test - --- dialog <- messageDialogNew Nothing [DialogModal] MessageInfo ButtonsCancel msg - - dialog <- dialogNew - dialogAddButton dialog "gtk-cancel" ResponseCancel - widgetSetSizeRequest dialog 400 (-1) - upper <- dialogGetUpper dialog - hbox <- hBoxNew True 0 - label <- labelNew Nothing - miscSetAlignment label 0 0.5 - miscSetPadding label 20 0 - labelSetMarkup label $ - printf "<big><b>Loading %s</b></big>" (takeFileName msg) - boxPackStart upper label PackGrow 10 - boxPackStart upper hbox PackNatural 10 - progress <- progressBarNew - boxPackStart hbox progress PackGrow 20 - widgetShowAll upper - progressBarSetText progress msg - set dialog [ dialogHasSeparator := False ] - timeout <- timeoutAdd (do progressBarPulse progress; return True) 50 - - windowSetTitle dialog "ThreadScope" - - withBackgroundProcessing $ do - - t <- forkIO $ buildEventLog from dialog progress state - `onException` dialogResponse dialog (ResponseUser 1) - - r <- dialogRun dialog - case r of - ResponseUser 1 -> return () - _ -> killThread t - widgetDestroy dialog - timeoutRemove timeout - -------------------------------------------------------------------------------- - --- NB. Runs in a background thread, can call GUI functions only with --- postGUI. --- -buildEventLog :: DialogClass dialog => Either FilePath String - -> dialog - -> ProgressBar -> ViewerState -> IO () -buildEventLog from dialog progress state@ViewerState{..} = - case from of - Right test -> build test (testTrace test) - Left filename -> do - postGUISync $ progressBarSetText progress $ "Reading " ++ filename - fmt <- readEventLogFromFile filename - case fmt of - Left err -> hPutStr stderr err - Right evs -> build filename evs - - where - build name evs = do - let - eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t - eventBlockEnd e = time e - - lastTx = maximum (0 : map eventBlockEnd (events (dat evs))) - - groups = groupEvents (events (dat evs)) - trees = rawEventsToHECs groups lastTx - - -- 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 - } - - treeProgress :: ProgressBar -> Int -> (DurationTree,EventTree) -> IO () - treeProgress progress hec (tree1,tree2) = do - postGUISync $ progressBarSetText progress $ - printf "Building HEC %d/%d" (hec+1) hec_count - progressBarSetFraction progress $ - fromIntegral hec / fromIntegral hec_count - evaluate tree1 - evaluate (eventTreeMaxDepth tree2) - return () - - zipWithM_ (treeProgress progress) [0..] trees - - postGUISync $ do - windowSetTitle mainWindow ("ThreadScope - " ++ takeFileName name) - ctx <- statusbarGetContextId statusBar "file" - statusbarPush statusBar ctx $ - printf "%s (%d events, %.3fs)" name n_events - ((fromIntegral lastTx :: Double) * 1.0e-9) - newHECs state hecs - timelineParamsChanged state - when debug $ zipWithM_ reportDurationTree [0..] (map fst trees) - when debug $ zipWithM_ reportEventTree [0..] (map snd trees) - writeIORef hecsIORef (Just hecs) - writeIORef scaleIORef defaultScaleValue - dialogResponse dialog (ResponseUser 1) - -------------------------------------------------------------------------------- -
− SaveAsPDF.hs
@@ -1,42 +0,0 @@-module SaveAsPDF -where - --- Imports from Haskell library -import Control.Monad -import Data.IORef - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - --- Imports for ThreadScope -import EventsWindow -import Timeline.Render -import State -import Timeline -import Traces - -------------------------------------------------------------------------------- - -saveAsPDF :: ViewerState -> IO () -saveAsPDF state@ViewerState{..} - = liftIO $ do - scaleValue <- readIORef scaleIORef - hadj_value0 <- adjustmentGetValue timelineAdj - let hadj_value = toWholePixels scaleValue hadj_value0 - mb_hecs <- readIORef hecsIORef - Just fn <- readIORef filenameIORef - case mb_hecs of - Nothing -> return () - Just hecs -> do - (w, h) <- widgetGetSize timelineDrawingArea - traces <- getViewTraces state - cursorpos <- getCursorLine state - let params = ViewParameters w h traces hadj_value scaleValue 1 False - False - let r = renderTraces state params traces hecs (Rectangle 0 0 w h) - withPDFSurface (fn++".pdf") (fromIntegral w) (fromIntegral h) (flip renderWith $ r) - return () - --------------------------------------------------------------------------------
− SaveAsPNG.hs
@@ -1,45 +0,0 @@-module SaveAsPNG -where - --- Imports from Haskell library -import Control.Monad -import Data.IORef - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - --- Imports for ThreadScope -import EventsWindow -import Timeline.Render -import State -import Timeline -import Traces - -------------------------------------------------------------------------------- - -saveAsPNG :: ViewerState -> IO () -saveAsPNG state@ViewerState{..} - = liftIO $ do - scaleValue <- readIORef scaleIORef - hadj_value0 <- adjustmentGetValue timelineAdj - let hadj_value = toWholePixels scaleValue hadj_value0 - mb_hecs <- readIORef hecsIORef - Just fn <- readIORef filenameIORef - case mb_hecs of - Nothing -> return () - Just hecs -> do - (w, h) <- widgetGetSize timelineDrawingArea - traces <- getViewTraces state - cursorpos <- getCursorLine state - let params = ViewParameters w h traces hadj_value scaleValue 1 False - False - let r = renderTraces state params traces hecs (Rectangle 0 0 w h) - withImageSurface C.FormatARGB32 (fromIntegral w) (fromIntegral h) - $ \ surface -> - do renderWith surface r - surfaceWriteToPNG surface (fn++".png") - return () - --------------------------------------------------------------------------------
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple +import Distribution.Simple main = defaultMain
− ShowEvents.hs
@@ -1,62 +0,0 @@-module Main where - -import GHC.RTS.Events -import System.Environment -import Text.Printf -import Data.List -import Data.Function - -main = do - [file] <- getArgs - - fmt <- buildFormat file - - printf "Event Types:\n" - case fmtHeader fmt of - Header (EventTypes ets) -> putStrLn (unlines (map ppEventType ets)) - - let pes = events (fmtData fmt) - sorted = sortBy (compare `on` ts) (reverse pes) - -- the events come out reversed, and we want a stable sort - - printf "Events:\n" - putStrLn $ unlines $ map ppEvent $ sorted - --- putStrLn (show $ getFirstPE dat) --- let len = length $ phaseEvents dat --- putStrLn (show $ phaseEvents dat !! (len - 3)) --- putStrLn (show $ phaseEvents dat !! (len - 2)) --- putStrLn (show $ phaseEvents dat !! (len - 1)) --- --- getFirstPE dat = head $ phaseEvents dat - -{- EOF. -} - -ppEventType :: EventType -> String -ppEventType et = printf "%4d: %s (size %d)" (etNum et) (etDesc et) (etSize et) - -ppEvent :: Event -> String -ppEvent Event{..} = - printf "%9d: cap %d: " ts (cap spec) ++ - case spec of - CreateThread{..} -> printf "creating thread %d" thread - RunThread{..} -> printf "running thread %d" thread - StopThread{..} -> printf "stopping thread %d (%s)" thread (showThreadStopStatus status) - ThreadRunnable{..} -> printf "thread %d is runnable" thread - MigrateThread{..} -> printf "migrating thread %d to cap %d" thread newCap - RunSpark{..} -> printf "running a local spark (thread %d)" thread - StealSpark{..} -> printf "thread %d stealing a spark from cap %d" thread origCap - Shutdown{..} -> printf "shutting down" - WakeupThread{..} -> printf "waking up thread %d on cap %d" thread otherCap - RequestSeqGC{..} -> printf "requesting sequential GC" - RequestParGC{..} -> printf "requesting parallel GC" - StartGC{..} -> printf "starting GC" - EndGC{..} -> printf "finished GC" - -showThreadStopStatus :: ThreadStopStatus -> String -showThreadStopStatus HeapOverflow = "heap overflow" -showThreadStopStatus StackOverflow = "stack overflow" -showThreadStopStatus ThreadYielding = "thread yielding" -showThreadStopStatus ThreadBlocked = "thread blocked" -showThreadStopStatus ThreadFinished = "thread finished" -showThreadStopStatus ForeignCall = "making a foreign call"
− Sidebar.hs
@@ -1,89 +0,0 @@-module Sidebar (- setupSideBar,- sidebarBookmarks,- sidebarTraces,- ) where--import State-import Timeline--import Graphics.UI.Gtk-import Graphics.UI.Gtk.Gdk.EventM--import Data.IORef-import Control.Monad-import Control.Monad.Trans---- XXX: we should be using a Model here, but not sure how to do that--- with Glade.-sidebarTraces, sidebarBookmarks :: Int-sidebarTraces = 0-sidebarBookmarks = 1--setupSideBar :: ViewerState -> IO ()-setupSideBar state@ViewerState{..} = do- on sidebarCloseButton buttonPressEvent $ tryEvent $ liftIO $ do- checkMenuItemSetActive sidebarToggle False- containerRemove hpaned sidebarVBox- - onToggle sidebarToggle $ do -- no new-style event for menu toggles?- b <- checkMenuItemGetActive sidebarToggle- if b - then panedAdd1 hpaned sidebarVBox- else containerRemove hpaned sidebarVBox-- on sidebarCombo changed $ do- sidebarChangeView state-- writeIORef sidebarComboState 1- comboBoxSetActive sidebarCombo 0- sidebarChangeView state-- traceColumn <- treeViewColumnNew--- treeViewColumnSetTitle traceColumn "Trace"-- textcell <- cellRendererTextNew- togglecell <- cellRendererToggleNew-- treeViewColumnPackStart traceColumn textcell True- treeViewColumnPackEnd traceColumn togglecell False-- cellLayoutSetAttributes traceColumn textcell tracesStore $- \(t,bool) -> case t of- TraceGroup str -> [cellText := str]- TraceHEC n -> [cellText := show n]- TraceThread n -> [cellText := show n]- TraceActivity -> [cellText := "Activity Profile"]-- cellLayoutSetAttributes traceColumn togglecell tracesStore $- \(str,bool) -> [cellToggleActive := bool]-- on togglecell cellToggled $ \str -> do- let p = stringToTreePath str- (str,bool) <- treeStoreGetValue tracesStore p- treeStoreSetValue tracesStore p (str, not bool)- timelineParamsChanged state-- treeViewAppendColumn tracesTreeView traceColumn-- return ()--sidebarChangeView :: ViewerState -> IO ()-sidebarChangeView state@ViewerState{..} = do- r <- readIORef sidebarComboState- v <- comboBoxGetActive sidebarCombo- when (v /= r) $ do- writeIORef sidebarComboState v- case v of- _ | v == sidebarTraces -> do- containerRemove sidebarVBox bookmarkVBox- boxPackEnd sidebarVBox tracesVBox PackGrow 0- widgetShowAll tracesVBox-- | v == sidebarBookmarks -> do- containerRemove sidebarVBox tracesVBox- boxPackEnd sidebarVBox bookmarkVBox PackGrow 0- widgetShowAll bookmarkVBox-- _ ->- return ()
− State.hs
@@ -1,125 +0,0 @@-module State ( - ViewerState(..), - ViewParameters(..),- Trace(..),- HECs(..)- ) where--import EventTree--import qualified GHC.RTS.Events as GHCEvents-import GHC.RTS.Events hiding (Event)--import Graphics.UI.Gtk-import Graphics.Rendering.Cairo --import Data.IORef-import Data.Array---------------------------------------------------------------------------------data ViewerState = ViewerState {- filenameIORef :: IORef (Maybe FilePath),- debug :: Bool,-- -- The loaded profile- hecsIORef :: IORef (Maybe HECs),- scaleIORef :: IORef Double, -- in ns/pixel- cursorIORef :: IORef Timestamp,-- -- WIDGETS- - -- main window- mainWindow :: Window,- statusBar :: Statusbar,- hpaned :: HPaned,-- -- menu items- bwToggle :: CheckMenuItem,- sidebarToggle :: CheckMenuItem,- openMenuItem :: MenuItem,- saveAsPDFMenuItem :: MenuItem,- saveAsPNGMenuItem :: MenuItem,- reloadMenuItem :: MenuItem,- quitMenuItem :: MenuItem,- aboutMenuItem :: MenuItem,-- -- Timeline view- timelineDrawingArea :: DrawingArea,- timelineLabelDrawingArea :: DrawingArea,- timelineKeyDrawingArea :: DrawingArea,- timelineHScrollbar :: HScrollbar,- timelineVScrollbar :: VScrollbar,- timelineAdj :: Adjustment,- timelineVAdj :: Adjustment,- zoomInButton :: ToolButton,- zoomOutButton :: ToolButton,- zoomFitButton :: ToolButton,- firstButton :: ToolButton,- lastButton :: ToolButton,- centreButton :: ToolButton,- showLabelsToggle :: ToggleToolButton,-- timelinePrevView :: IORef (Maybe (ViewParameters, Surface)),-- -- Events view- eventsFontExtents :: IORef FontExtents,- eventsCursorIORef :: IORef (Maybe (Timestamp, Int)),- eventsVScrollbar :: VScrollbar,- eventsAdj :: Adjustment,- eventsDrawingArea :: DrawingArea,- eventsTextEntry :: Entry,- eventsFindButton :: ToolButton,- eventsFirstButton :: ToolButton,- eventsHomeButton :: ToolButton,- eventsLastButton :: ToolButton,-- -- sidebar- sidebarVBox :: VBox,- sidebarHBox :: HBox,- sidebarCombo :: ComboBox,- sidebarComboState :: IORef Int,- sidebarCloseButton :: Button,-- -- Bookmarks- bookmarkVBox :: VBox,- addBookmarkButton :: ToolButton,- deleteBookmarkButton :: ToolButton,- gotoBookmarkButton :: ToolButton,- bookmarkTreeView :: TreeView,- bookmarkStore :: ListStore Timestamp,-- -- Traces- tracesVBox :: VBox,- tracesTreeView :: TreeView,- tracesStore :: TreeStore (Trace,Bool)- }---- all the data from a .eventlog file-data HECs = HECs {- hecCount :: Int,- hecTrees :: [(DurationTree,EventTree)],- hecEventArray :: Array Int GHCEvents.CapEvent,- hecLastEventTime :: Timestamp- }--data Trace- = TraceHEC Int- | TraceThread ThreadId- | TraceGroup String- | TraceActivity- -- more later ...- deriving Eq---- the parameters for a timeline render; used to figure out whether--- we're drawing the same thing twice.-data ViewParameters = ViewParameters {- width, height :: Int,- viewTraces :: [Trace],- hadjValue :: Double,- scaleValue :: Double,- detail :: Int,- bwMode, labelsMode :: Bool- }- deriving Eq-
− TestEvents.hs
@@ -1,332 +0,0 @@-module TestEvents (testTrace) -where - -import GHC.RTS.Events -import Data.Word - -------------------------------------------------------------------------------- - - -testTrace :: String -> EventLog -testTrace name = eventLog (test name) - -------------------------------------------------------------------------------- - -eventLog :: [Event] -> EventLog -eventLog events - = EventLog (Header testEventTypes) (Data events) - -------------------------------------------------------------------------------- - -create :: Word16 -create = 0 - -------------------------------------------------------------------------------- - -runThread :: Word16 -runThread = 1 - -------------------------------------------------------------------------------- - -stop :: Word16 -stop = 2 - -------------------------------------------------------------------------------- - -runnable :: Word16 -runnable = 3 - -------------------------------------------------------------------------------- - -migrate :: Word16 -migrate = 4 - -------------------------------------------------------------------------------- - -runSpark :: Word16 -runSpark = 5 - -------------------------------------------------------------------------------- - -stealSpark :: Word16 -stealSpark = 6 - -------------------------------------------------------------------------------- - -shutdown :: Word16 -shutdown = 7 - -------------------------------------------------------------------------------- - -wakeup :: Word16 -wakeup = 8 - -------------------------------------------------------------------------------- - -startGC :: Word16 -startGC = 9 - ------------------------------------------------------------------------------- - -finishGC :: Word16 -finishGC = 10 - ------------------------------------------------------------------------------- - -reqSeqGC :: Word16 -reqSeqGC = 11 - ------------------------------------------------------------------------------- - -reqParGC :: Word16 -reqParGC = 12 - ------------------------------------------------------------------------------- - -createSparkThread :: Word16 -createSparkThread = 15 - ------------------------------------------------------------------------------- - -logMessage :: Word16 -logMessage = 16 - ------------------------------------------------------------------------------- - -startup :: Word16 -startup = 17 - ------------------------------------------------------------------------------- - -blockMarker :: Word16 -blockMarker = 18 - ------------------------------------------------------------------------------- - -testEventTypes :: [EventType] -testEventTypes - = [EventType create "Create thread" (Just 8), - EventType runThread "Run thread" (Just 8), - EventType stop "Stop thread" (Just 10), - EventType runnable "Thread runnable" (Just 8), - EventType migrate "Migrate thread" (Just 10), - EventType runSpark "Run spark" (Just 8), - EventType stealSpark "Steal spark" (Just 10), - EventType shutdown "Shutdown" (Just 0), - EventType wakeup "Wakeup thread" (Just 10), - EventType startGC "Start GC" (Just 0), - EventType finishGC "Finish GC" (Just 0), - EventType reqSeqGC "Request sequetial GC" (Just 0), - EventType reqParGC "Reqpargc parallel GC" (Just 0), - EventType createSparkThread "Create spark thread" (Just 8), - EventType logMessage "Log message" Nothing, - EventType startup "Startup" (Just 0), - EventType blockMarker "Block marker" (Just 14) - ] - -------------------------------------------------------------------------------- -test :: String -> [Event] -------------------------------------------------------------------------------- - -test "empty0" - = [ - Event 0 (Startup 1) - ] - -------------------------------------------------------------------------------- - - -test "empty1" - = [ - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000 0 [] - ] - -------------------------------------------------------------------------------- - -test "test0" - = [ - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000 0 [ - Event 4000000 Shutdown - ] - ] -------------------------------------------------------------------------------- - -test "small" - = [ - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000 0 [ - Event 1000000 (CreateThread 1), - Event 2000000 (RunThread 1), - Event 3000000 (StopThread 1 ThreadFinished), - Event 4000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick" - = [-- A thread from 2s to 3s - Event 0 (Startup 3), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 2000000000 (RunThread 1), - Event 3000000000 (StopThread 1 ThreadFinished), - Event 4000000000 (Shutdown) - ], - -- A thread from 0.2ms to 0.3ms - Event 0 $ EventBlock 4000000000 1 [ - Event 1000000 (CreateThread 2), - Event 2000000 (RunThread 2), - Event 3000000 (StopThread 2 ThreadFinished), - Event 4000000 (Shutdown) - ], - -- A thread from 0.2us to 0.3us - Event 0 $ EventBlock 4000000000 2 [ - Event 1000 (CreateThread 3), - Event 2000 (RunThread 3), - Event 3000 (StopThread 3 ThreadFinished), - Event 4000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick2" - = [-- A thread create but no run - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 4000000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick3" - = [-- A thread from 2s to 3s - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 2000000000 (RunThread 1), - Event 3000000000 (StopThread 1 ThreadFinished), - Event 4000000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick4" - = [-- A test for scale values close to 1.0 - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 100 (CreateThread 1), - Event 200 (RunThread 1), - Event 300 (StopThread 1 ThreadFinished), - Event 400 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick5" - = [-- A thread from 2s to 3s - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 2000000000 (RunThread 1), - Event 3000000000 (StopThread 1 ThreadFinished), - Event 4000000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- --- A long tick run to check small and large tick labels - -test "tick6" = chequered 2 100 10000000 - -------------------------------------------------------------------------------- - -test "overlap" - = [-- A thread from 2s to 3s - Event 0 (Startup 1), - Event 0 $ EventBlock 3000 0 [ - Event 1000 (CreateThread 1), - Event 1100 (RunThread 1), - Event 1200 (CreateThread 2), - Event 1300 (StopThread 1 ThreadFinished), - - Event 1400 (RunThread 2), - Event 1500 (CreateThread 3), - Event 1500 (CreateThread 4), - Event 1500 (StopThread 2 ThreadFinished), - - Event 1600 (RunThread 3), - Event 1600 (CreateThread 5), - Event 1600 (StopThread 3 ThreadFinished), - - Event 1700 (RunThread 4), - Event 1700 (CreateThread 6), - Event 1800 (StopThread 4 ThreadFinished), - - Event 3000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- --- These tests are for chequered patterns to help check for rendering --- problems and also to help test the performance of scrolling etc. --- Each line has a fixed frequency of a thread running and then performing GC. --- Each successive HEC runs thread at half the frequency of the previous HEC. - -test "ch1" = chequered 1 100 100000 -test "ch2" = chequered 2 100 100000 -test "ch3" = chequered 3 100 100000 -test "ch4" = chequered 4 100 100000 -test "ch5" = chequered 5 100 100000 -test "ch6" = chequered 6 100 100000 -test "ch7" = chequered 7 100 100000 -test "ch8" = chequered 8 100 100000 - - -------------------------------------------------------------------------------- - -test _ = [] - -------------------------------------------------------------------------------- - -chequered :: ThreadId -> Timestamp -> Timestamp -> [Event] -chequered numThreads basicDuration runLength - = Event 0 (Startup (fromIntegral numThreads)) : - makeChequered 1 numThreads basicDuration runLength - -------------------------------------------------------------------------------- - -makeChequered :: ThreadId -> ThreadId -> Timestamp -> Timestamp -> [Event] -makeChequered currentThread numThreads basicDuration runLength - | currentThread > numThreads = [] -- All threads rendered -makeChequered currentThread numThreads basicDuration runLength - = Event 0 eventBlock : - makeChequered (currentThread+1) numThreads (2*basicDuration) runLength - where - eventBlock :: EventTypeSpecificInfo - eventBlock = EventBlock runLength (fromIntegral (currentThread-1)) - (Event 0 (CreateThread currentThread) - : chequeredPattern currentThread 0 basicDuration runLength) - -------------------------------------------------------------------------------- - -chequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event] -chequeredPattern currentThread currentPos basicDuration runLength - = if currentPos + 2*basicDuration > runLength then - [Event runLength (Shutdown)] - else - [Event currentPos (RunThread currentThread), - Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding), - Event (currentPos+basicDuration) StartGC, - Event (currentPos+2*basicDuration) EndGC - ] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength - -------------------------------------------------------------------------------- -
− ThreadScope.hs
@@ -1,271 +0,0 @@-{-# LANGUAGE CPP #-} --- ThreadScope: a graphical viewer for Haskell event log information. --- Maintainer: satnams@microsoft.com, s.singh@ieee.org - -module Main where - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Glade -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C -import Graphics.UI.Gtk.ModelView as New - --- Imports from Haskell library -import System.Environment -import Control.Monad -import Data.IORef -import Data.Maybe -import qualified Data.Function -import Data.List -#ifndef mingw32_HOST_OS -import System.Posix -#endif -import Control.Concurrent -import Control.Exception - -import Paths_threadscope - --- Imports for ThreadScope -import State -import About -import FileDialog -import Options -import ReadEvents -import EventsWindow -import Timeline -import SaveAsPDF -import SaveAsPNG -import Sidebar -import Traces - -------------------------------------------------------------------------------- - -main :: IO () -main - = do -- Deal with command line argument processing. - -- This application accepts one optional argument specifying - -- the event log. - args <- getArgs - let options = parseOptions args - - unsafeInitGUIForThreadedRTS - state <- buildInitialState options - - startup options state - -startup :: [Option] -> ViewerState -> IO () -startup options state@ViewerState{..} - = do - let - filenames = [filename | Filename filename <- options] - tracenames = [name | TestTrace name <- options] - when (length filenames > 1) - (putStrLn "usage: threadscope [eventlog_filename]") - let filename = if filenames == [] then - "" - else - head filenames - traceName = if tracenames == [] then - "" - else - head tracenames - - writeIORef filenameIORef (if filename == "" then - Nothing - else - Just filename) - - widgetSetAppPaintable mainWindow True - logoPath <- getDataFileName "threadscope.png" - windowSetIconFromFile mainWindow logoPath - - ------------------------------------------------------------------------ - -- Status bar functionality - ctx <- statusbarGetContextId statusBar "state" - statusbarPush statusBar ctx "No eventlog loaded." - - ------------------------------------------------------------------------ - --- Get the label for the name of the event log - - -- B&W toggle button - bwToggle `onToggle` timelineParamsChanged state - - -- No Labels toggle button - showLabelsToggle `onToolButtonToggled` timelineParamsChanged state - - -- When a filename for an event log is specified open and - -- parse the event log file and update the IORefs for - -- the capabilities and event array. - when (filename /= "") $ registerEventsFromFile filename state - - -- Likewise for test traces - when (traceName /= "") $ registerEventsFromTrace traceName state - - -- B&W toggle button - - -- The File:Open menu option can be used to specify an - -- eventlog file. - openMenuItem `onActivateLeaf` do - filename <- openFileDialog mainWindow - when (isJust filename) $ - registerEventsFromFile (fromJust filename) state - - ------------------------------------------------------------------------ - -- Save as PDF functionality - saveAsPDFMenuItem `onActivateLeaf` saveAsPDF state - - ------------------------------------------------------------------------ - -- Save as PNG functionality - saveAsPNGMenuItem `onActivateLeaf` saveAsPNG state - - ------------------------------------------------------------------------ - -- Reload functionality - onActivateLeaf reloadMenuItem $ - do mb_filename <- readIORef filenameIORef - case mb_filename of - Nothing -> return () - Just filename -> registerEventsFromFile filename state - - ------------------------------------------------------------------------ - -- CPUs view - - setupTimelineView state - - ------------------------------------------------------------------------ - -- Event view - - setupEventsWindow state - - ------------------------------------------------------------------------ - -- Sidebar - - setupSideBar state - - ------------------------------------------------------------------------ - -- Quit - quitMenuItem `onActivateLeaf` mainQuit - - ------------------------------------------------------------------------ - -- About dialog - aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow - - ------------------------------------------------------------------------ - -- Quit behaviour - onDestroy mainWindow mainQuit - - ------------------------------------------------------------------------ - -- Show all windows - widgetShowAll mainWindow - -#ifndef mingw32_HOST_OS - main <- myThreadId - installHandler sigINT (Catch (postGUIAsync (throw UserInterrupt))) Nothing -#endif - - ------------------------------------------------------------------------ - -- Enter main event loop for GUI. - mainGUI - -------------------------------------------------------------------------------- - -buildInitialState :: [Option] -> IO ViewerState -buildInitialState options = do - - gladePath <- getDataFileName "threadscope.glade" - Just xml <- xmlNew gladePath - - let debug = Debug `elem` options - - - filenameIORef <- newIORef Nothing - - -- IORefs are used to communicate informaiton about the eventlog - -- to the callback functions for windows, buttons etc. - capabilitiesIORef <- newIORef Nothing - hecsIORef <- newIORef Nothing - lastTxIORef <- newIORef 0 - eventArrayIORef <- newIORef (error "eventArrayIORef") - scaleIORef <- newIORef defaultScaleValue - cursorIORef <- newIORef 0 - - mainWindow <- xmlGetWidget xml castToWindow "main_window" - statusBar <- xmlGetWidget xml castToStatusbar "statusbar" - hpaned <- xmlGetWidget xml castToHPaned "hpaned" - - bwToggle <- xmlGetWidget xml castToCheckMenuItem "black_and_white" - sidebarToggle <- xmlGetWidget xml castToCheckMenuItem "view_sidebar" - openMenuItem <- xmlGetWidget xml castToMenuItem "openMenuItem" - saveAsPDFMenuItem <- xmlGetWidget xml castToMenuItem "saveAsPDFMenuItem" - saveAsPNGMenuItem <- xmlGetWidget xml castToMenuItem "saveAsPNGMenuItem" - reloadMenuItem <- xmlGetWidget xml castToMenuItem "view_reload" - quitMenuItem <- xmlGetWidget xml castToMenuItem "quitMenuItem" - aboutMenuItem <- xmlGetWidget xml castToMenuItem "aboutMenuItem" - - timelineDrawingArea <- xmlGetWidget xml castToDrawingArea - "timeline_drawingarea" - timelineLabelDrawingArea <- xmlGetWidget xml castToDrawingArea - "timeline_labels_drawingarea" - timelineKeyDrawingArea <- xmlGetWidget xml castToDrawingArea - "timeline_key_drawingarea" - timelineHScrollbar <- xmlGetWidget xml castToHScrollbar - "timeline_hscroll" - timelineVScrollbar <- xmlGetWidget xml castToVScrollbar - "timeline_vscroll" - timelineAdj <- rangeGetAdjustment timelineHScrollbar - timelineVAdj <- rangeGetAdjustment timelineVScrollbar - - timelineTraces <- newIORef [] - timelinePrevView <- newIORef Nothing - - zoomInButton <- xmlGetWidget xml castToToolButton "cpus_zoomin" - zoomOutButton <- xmlGetWidget xml castToToolButton "cpus_zoomout" - zoomFitButton <- xmlGetWidget xml castToToolButton "cpus_zoomfit" - - showLabelsToggle <- xmlGetWidget xml castToToggleToolButton "cpus_showlabels" - firstButton <- xmlGetWidget xml castToToolButton "cpus_first" - lastButton <- xmlGetWidget xml castToToolButton "cpus_last" - centreButton <- xmlGetWidget xml castToToolButton "cpus_centre" - - eventsFontExtents <- newIORef (error "eventsFontExtents") - eventsCursorIORef <- newIORef Nothing - eventsVScrollbar <- xmlGetWidget xml castToVScrollbar "eventsVScroll" - eventsAdj <- rangeGetAdjustment eventsVScrollbar - eventsDrawingArea <- xmlGetWidget xml castToDrawingArea "eventsDrawingArea" - eventsTextEntry <- xmlGetWidget xml castToEntry "events_entry" - eventsFindButton <- xmlGetWidget xml castToToolButton "events_find" - eventsFirstButton <- xmlGetWidget xml castToToolButton "events_first" - eventsHomeButton <- xmlGetWidget xml castToToolButton "events_home" - eventsLastButton <- xmlGetWidget xml castToToolButton "events_last" - - sidebarVBox <- xmlGetWidget xml castToVBox "sidebar_vbox" - sidebarHBox <- xmlGetWidget xml castToHBox "sidebar_hbox" - sidebarCombo <- xmlGetWidget xml castToComboBox "sidebar_combobox" - sidebarComboState <- newIORef sidebarBookmarks - sidebarCloseButton <- xmlGetWidget xml castToButton "sidebar_close_button" - bookmarkVBox <- xmlGetWidget xml castToVBox "bookmarks_vbox" - bookmarkTreeView <- xmlGetWidget xml castToTreeView "bookmark_list" - - -- Bookmarks - addBookmarkButton <- xmlGetWidget xml castToToolButton "add_bookmark_button" - deleteBookmarkButton <- xmlGetWidget xml castToToolButton "delete_bookmark" - gotoBookmarkButton <- xmlGetWidget xml castToToolButton "goto_bookmark_button" - bookmarkStore <- New.listStoreNew [] - New.treeViewSetModel bookmarkTreeView bookmarkStore - New.treeViewSetHeadersVisible bookmarkTreeView True - bookmarkColumn <- New.treeViewColumnNew - New.treeViewColumnSetTitle bookmarkColumn "Time" - cell <- New.cellRendererTextNew - New.treeViewColumnPackStart bookmarkColumn cell True - New.cellLayoutSetAttributes bookmarkColumn cell bookmarkStore - (\record -> [New.cellText := show record ++ " ns"]) - New.treeViewAppendColumn bookmarkTreeView bookmarkColumn - - -- Trace view - tracesVBox <- vBoxNew False 0 - tracesTreeView <- treeViewNew - tracesStore <- treeStoreNew [] - treeViewSetModel tracesTreeView tracesStore - boxPackEnd tracesVBox tracesTreeView PackGrow 0 - - return ViewerState { .. }
− Timeline.hs
@@ -1,182 +0,0 @@-module Timeline ( - setupTimelineView,- renderTraces,- timelineParamsChanged,- defaultScaleValue,- queueRedrawTimelines,- setCursorToTime- ) where--import Timeline.Motion-import Timeline.Render-import Timeline.Key--import State-import GHC.RTS.Events--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 Data.Maybe-import Data.IORef-import Control.Monad-import Text.Printf--- import Debug.Trace---------------------------------------------------------------------------------- The CPUs view--setupTimelineView :: ViewerState -> IO ()-setupTimelineView state@ViewerState{..} = do-- ------------------------------------------------------------------------- -- Key presses- onKeyPress mainWindow $ \Key { Old.eventKeyName = key, eventKeyChar = mch } -> do- -- when debug $ putStrLn ("key " ++ key)- case key of- "Escape" -> mainQuit >> return True- "Right" -> do scrollRight state; return True- "Left" -> do scrollLeft state; return True- _ -> if isJust mch then- case fromJust mch of - '+' -> do zoomIn state; return True- '-' -> do zoomOut state; return True- _ -> return True- else- return True-- ------------------------------------------------------------------------- -- Porgram the callback for the capability drawingArea- timelineLabelDrawingArea `onExpose` updateLabelDrawingArea state-- ------------------------------------------------------------------------- -- Set-up the key timelineDrawingArea.- timelineKeyDrawingArea `onExpose` updateKeyDrawingArea timelineKeyDrawingArea-- ------------------------------------------------------------------------- -- zoom buttons-- zoomInButton `onToolButtonClicked` zoomIn state- zoomOutButton `onToolButtonClicked` zoomOut state- zoomFitButton `onToolButtonClicked` zoomToFit state-- firstButton `onToolButtonClicked` scrollToBeginning state- lastButton `onToolButtonClicked` scrollToEnd state- centreButton `onToolButtonClicked` centreOnCursor state-- ------------------------------------------------------------------------- -- Allow mouse wheel to be used for zoom in/out- on timelineDrawingArea scrollEvent $ tryEvent $ do- dir <- eventScrollDirection- mods <- eventModifier- liftIO $ do- case (dir,mods) of- (ScrollUp, [Control]) -> zoomIn state- (ScrollDown, [Control]) -> zoomOut state- (ScrollUp, []) -> vscrollUp state- (ScrollDown, []) -> vscrollDown state- _ -> return ()- - ------------------------------------------------------------------------- -- Mouse button-- onButtonPress timelineDrawingArea $ \button -> do- when debug $ putStrLn ("button pressed: " ++ show button)- case button of- Button{ Old.eventButton = LeftButton, Old.eventClick = SingleClick,- -- eventModifier = [], -- contains [Alt2] for me- eventX = x } -> do- setCursor state x- return True- _other -> do- return False-- onValueChanged timelineAdj $ queueRedrawTimelines state- onValueChanged timelineVAdj $ queueRedrawTimelines state-- on timelineDrawingArea exposeEvent $ do- exposeRegion <- New.eventRegion- liftIO $ exposeTraceView state exposeRegion- return True-- on timelineDrawingArea configureEvent $ do- liftIO $ configureTimelineDrawingArea state- return True-- return ()------------------------------------------------------------------------------------ Update the internal state and the timemline view after changing which--- traces are displayed, or the order of traces.--timelineParamsChanged :: ViewerState -> IO ()-timelineParamsChanged state = do- queueRedrawTimelines state- updateTimelineVScroll state--configureTimelineDrawingArea :: ViewerState -> IO ()-configureTimelineDrawingArea state = do- updateTimelineVScroll state- updateTimelineHPageSize state--updateTimelineVScroll :: ViewerState -> IO ()-updateTimelineVScroll state@ViewerState{..} = do- h <- calculateTotalTimelineHeight state- (_,winh) <- widgetGetSize timelineDrawingArea- let winh' = fromIntegral winh; h' = fromIntegral h- adjustmentSetLower timelineVAdj 0- adjustmentSetUpper timelineVAdj h'-- val <- adjustmentGetValue timelineVAdj- when (val > h') $ adjustmentSetValue timelineVAdj h'-- adjustmentSetPageSize timelineVAdj winh'- rangeSetIncrements timelineVScrollbar (0.1 * winh') (0.9 * winh')---- when the drawing area is resized, we update the page size of the--- adjustment. Everything else stays the same: we don't scale or move--- the view at all.-updateTimelineHPageSize :: ViewerState -> IO ()-updateTimelineHPageSize state@ViewerState{..} = do- (winw,_) <- widgetGetSize timelineDrawingArea- scaleValue <- readIORef scaleIORef- adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue)------------------------------------------------------------------------------------ Set the cursor to a new position--setCursor :: ViewerState -> Double -> IO ()-setCursor state@ViewerState{..} x = do- hadjValue <- adjustmentGetValue timelineAdj- scaleValue <- readIORef scaleIORef- let cursor = round (hadjValue + x * scaleValue)- when debug $ printf "cursor set to: %d\n" cursor- writeIORef cursorIORef cursor- queueRedrawTimelines state-----------------------------------------------------------------------------------setCursorToTime :: ViewerState -> Timestamp -> IO ()-setCursorToTime state@ViewerState{..} x - = do hadjValue <- adjustmentGetValue timelineAdj- scaleValue <- readIORef scaleIORef- -- let cursor = round (hadjValue + x * scaleValue)- -- when debug $ printf "cursor set to: %d\n" cursor- writeIORef cursorIORef x- pageSize <- adjustmentGetPageSize timelineAdj - adjustmentSetValue timelineAdj ((fromIntegral x - pageSize/2) `max` 0)- queueRedrawTimelines state-------------------------------------------------------------------------------------- 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.--defaultScaleValue :: Double-defaultScaleValue = -1.0
− Timeline/Activity.hs
@@ -1,177 +0,0 @@-module Timeline.Activity (- renderActivity- ) where--import Timeline.Render.Constants--import State-import EventTree-import EventDuration-import ViewerColours-import CairoDrawing--import GHC.RTS.Events hiding (Event, GCWork, GCIdle)--import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C--import Control.Monad-import Data.List-import Text.Printf-import Debug.Trace---- ToDo:--- - we average over the slice, but the point is drawn at the beginning--- of the slice rather than in the middle.---------------------------------------------------------------------------------renderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp- -> Render ()--renderActivity param@ViewParameters{..} hecs start0 end0 = do- let - slice = round (fromIntegral activity_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-- hec_profs = map (actProfile slice start end) (map fst (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--activity_detail :: Int-activity_detail = 4 -- in pixels---- for each timeslice, the amount of time spent in the mutator--- during that period.-actProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp]-actProfile slice start0 end0 t- = {- trace (show flat) $ -} chopped-- where- -- do an extra slice at both ends- start = if start0 < slice then start0 else start0 - slice- end = end0 + slice-- flat = flatten start t []- chopped0 = chop 0 start flat-- chopped | start0 < slice = 0 : chopped0- | otherwise = chopped0-- flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree]- flatten start DurationTreeEmpty rest = rest- flatten start t@(DurationSplit s split e l r run _) rest- | e <= start = rest- | end <= s = rest- | start >= split = flatten start r rest- | end <= split = flatten start l rest- | e - s > slice = flatten start l $ flatten start r rest- | otherwise = t : rest- flatten start t@(DurationTreeLeaf d) rest- = t : rest- - chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp]- chop sofar start ts- | start >= end = if sofar > 0 then [sofar] else []- chop sofar start []- = sofar : chop 0 (start+slice) []- chop sofar start (t : ts)- | e <= start- = if sofar /= 0- then error "chop"- else chop sofar start ts- | s >= start + slice- = sofar : chop 0 (start + slice) (t : ts)- | e > start + slice- = (sofar + time_in_this_slice) : chop 0 (start + slice) (t : ts)- | otherwise- = chop (sofar + time_in_this_slice) start ts- where- (s, e)- | DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev)- | DurationSplit s _ e _ _ run _ <- t = (s, e)-- duration = min (start+slice) e - max start s-- time_in_this_slice- | DurationTreeLeaf ThreadRun{} <- t = duration- | DurationTreeLeaf _ <- t = 0- | DurationSplit _ _ _ _ _ run _ <- t =- round (fromIntegral (run * duration) / fromIntegral (e-s))---drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp]- -> Render ()-drawActivity hecs start end slice ts = do- case ts of- [] -> return ()- t:ts -> do--- liftIO $ printf "ts: %s\n" (show (t:ts))--- liftIO $ printf "off: %s\n" (show (map off (t:ts) :: [Double]))- let dstart = fromIntegral start- dend = fromIntegral end- dslice = fromIntegral slice- dheight = fromIntegral activityGraphHeight---- funky gradients don't seem to work:--- withLinearPattern 0 0 0 dheight $ \pattern -> do--- patternAddColorStopRGB pattern 0 0.8 0.8 0.8--- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0--- rectangle dstart 0 dend dheight--- setSource pattern--- fill-- newPath- 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- fill---- funky gradients don't seem to work:--- save--- withLinearPattern 0 0 0 dheight $ \pattern -> do--- patternAddColorStopRGB pattern 0 0 1.0 0--- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0--- setSource pattern--- -- identityMatrix--- -- setFillRule FillRuleEvenOdd--- fillPreserve--- restore-- save- forM_ [0 .. hecCount hecs - 1] $ \h -> do- let y = fromIntegral (floor (fromIntegral h * dheight / fromIntegral (hecCount hecs))) - 0.5- setSourceRGBAhex black 0.3- moveTo dstart y- lineTo dend y- dashedLine1- restore-- where- off t = fromIntegral activityGraphHeight -- fromIntegral (t * fromIntegral activityGraphHeight) /- fromIntegral (fromIntegral (hecCount hecs) * slice)--dashedLine1 = do- save- identityMatrix- setDash [10,10] 0.0- setLineWidth 1- stroke- restore-
− Timeline/HEC.hs
@@ -1,253 +0,0 @@-module Timeline.HEC ( - renderHEC - ) where - -import Timeline.Render.Constants - -import EventTree -import EventDuration -import State -import CairoDrawing -import 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) - -import Control.Monad - -renderHEC :: Int -> ViewParameters - -> Timestamp -> Timestamp -> (DurationTree,EventTree) - -> Render () -renderHEC cap params@ViewParameters{..} start end (dtree,etree) = do - renderDurations cap params start end dtree - when (scaleValue < detailThreshold) $ - case etree of - EventTree ltime etime tree -> - renderEvents cap params ltime etime start end tree - -detailThreshold :: Double -detailThreshold = 3000 - -------------------------------------------------------------------------------- --- hecView draws the trace for a single HEC - -renderDurations :: Int -> ViewParameters - -> Timestamp -> Timestamp -> DurationTree - -> Render () - -renderDurations _ _ _ _ DurationTreeEmpty = return () - -renderDurations c params@ViewParameters{..} startPos endPos (DurationTreeLeaf e) - | inView startPos endPos e = drawDuration c params e - | otherwise = return () - -renderDurations !c params@ViewParameters{..} !startPos !endPos - (DurationSplit s splitTime e lhs rhs runAv gcAv) - | startPos < splitTime && endPos >= splitTime && - (fromIntegral (e - s) / scaleValue) <= fromIntegral detail - = -- View spans both left and right sub-tree. - -- trace (printf "hecView (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $ - drawAverageDuration c params s e runAv gcAv - - | otherwise - = -- trace (printf "hecView: start:%d end:%d s:%d e:%d" startPos endPos s e) $ - do when (startPos < splitTime) $ - renderDurations c params startPos endPos lhs - when (endPos >= splitTime) $ - renderDurations c params startPos endPos rhs - -------------------------------------------------------------------------------- - -renderEvents :: Int -> ViewParameters - -> Timestamp -- start time of this tree node - -> Timestamp -- end time of this tree node - -> Timestamp -> Timestamp -> EventNode - -> Render () - -renderEvents !c params@ViewParameters{..} !s !e !startPos !endPos - (EventTreeLeaf es) - = sequence_ [ drawEvent c params e - | e <- es, let t = time e, t >= startPos && t < endPos ] -renderEvents !c params@ViewParameters{..} !s !e !startPos !endPos - (EventTreeOne ev) - | t >= startPos && t < endPos = drawEvent c params ev - | otherwise = return () - where t = time ev - -renderEvents !c params@ViewParameters{..} !s !e !startPos !endPos - (EventSplit splitTime lhs rhs) - | startPos < splitTime && endPos >= splitTime && - (fromIntegral (e - s) / scaleValue) <= fromIntegral detail - = drawTooManyEvents c params s e - - | otherwise - = do when (startPos < splitTime) $ - renderEvents c params s splitTime startPos endPos lhs - when (endPos >= splitTime) $ - renderEvents c params splitTime e startPos endPos rhs - -------------------------------------------------------------------------------- --- 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 - -------------------------------------------------------------------------------- - -drawAverageDuration :: Int -> ViewParameters - -> Timestamp -> Timestamp -> Timestamp -> Timestamp - -> Render () -drawAverageDuration c 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 --- runRatio :: Double --- runRatio = (fromIntegral runAv) / (fromIntegral duration) - gcRatio :: Double - gcRatio = (fromIntegral gcAv) / (fromIntegral duration) - -------------------------------------------------------------------------------- - -unscaledText :: String -> Render () -unscaledText text - = do m <- getMatrix - identityMatrix - textPath text - C.fill - setMatrix m - -------------------------------------------------------------------------------- - -textWidth :: Double -> String -> Render TextExtents -textWidth _scaleValue text - = do m <- getMatrix - identityMatrix - tExtent <- textExtents text - setMatrix m - return tExtent - -------------------------------------------------------------------------------- - -drawDuration :: Int -> ViewParameters -> EventDuration -> Render () - -drawDuration c 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 - -drawDuration c ViewParameters{..} (GCStart startTime endTime) - = gcBar (if bwMode then black else gcStartColour) startTime endTime - -drawDuration c ViewParameters{..} (GCWork startTime endTime) - = gcBar (if bwMode then black else gcWorkColour) startTime endTime - -drawDuration c ViewParameters{..} (GCIdle startTime endTime) - = gcBar (if bwMode then black else gcIdleColour) startTime endTime - -drawDuration c ViewParameters{..} (GCEnd startTime endTime) - = 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 - -labelAt :: Bool -> Timestamp -> String -> Render () -labelAt labelsMode t str - | not labelsMode = return () - | otherwise = do - setSourceRGB 0.0 0.0 0.0 - move_to (t, hecBarOff+hecBarHeight+12) - save - identityMatrix - rotate (pi/4) - textPath str - C.fill - restore - -drawEvent :: Int -> ViewParameters -> GHC.Event -> Render () -drawEvent c params@ViewParameters{..} event - = case spec event of - CreateThread{} -> renderInstantEvent params event createThreadColour - RunSpark{} -> renderInstantEvent params event runSparkColour - StealSpark{} -> renderInstantEvent params event stealSparkColour - 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 - Shutdown{} -> renderInstantEvent params event shutdownColour - - RunThread{} -> return () - StopThread{} -> return () - StartGC{} -> return () - - _ -> return () - -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 $ showEventTypeSpecificInfo (spec event) - - -drawTooManyEvents :: Int -> ViewParameters -> Timestamp -> Timestamp - -> Render () -drawTooManyEvents c params@ViewParameters{..} start end = do - return () --- setSourceRGBAhex grey 1.0 --- setLineWidth (3 * scaleValue) --- draw_rectangle start (hecBarOff-4) (end - start) 4 --- draw_rectangle start (hecBarOff+hecBarHeight) (end - start) 4 - --------------------------------------------------------------------------------
− Timeline/Key.hs
@@ -1,74 +0,0 @@-module Timeline.Key ( updateKeyDrawingArea ) where - -import Timeline.Render.Constants - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.Events -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - -import ViewerColours -import CairoDrawing - -------------------------------------------------------------------------------- - -updateKeyDrawingArea :: DrawingArea -> Event -> IO Bool -updateKeyDrawingArea canvas _ - = do win <- widgetGetDrawWindow canvas - renderWithDrawable win addKeyElements - return True - -------------------------------------------------------------------------------- - -data KeyStyle = Box | Vertical - -------------------------------------------------------------------------------- - -addKeyElements :: Render () -addKeyElements - = do clearWhite - selectFontFace "sans serif" FontSlantNormal FontWeightNormal - setFontSize 12 - addKeyElements' 10 [(Box, "running", runningColour), - (Box, "GC", gcColour), - (Vertical, "create thread", createThreadColour), - (Vertical, "run spark", runSparkColour), - (Vertical, "thread runnable", threadRunnableColour), - (Vertical, "seq GC req", seqGCReqColour), - (Vertical, "par GC req", parGCReqColour), - (Vertical, "migrate thread", migrateThreadColour), - (Vertical, "thread wakeup", threadWakeupColour), - (Vertical, "shutdown", shutdownColour)] - -------------------------------------------------------------------------------- - -addKeyElements' :: Double -> [(KeyStyle, String, Color)] -> Render () -addKeyElements' position [] = return () -addKeyElements' position ((Box, keyText, keyColour):rest) - = do setSourceRGBAhex keyColour 1.0 - rectangle position 0 50 (fromIntegral (hecBarHeight `div` 2)) - C.fill - setSourceRGBA 0.0 0.0 0.0 1.0 - moveTo (position+5) 22 - textPath keyText - C.fill - tExtent <- textExtents keyText - let textW = textExtentsWidth tExtent + 10 - addKeyElements' (position + (60 `max` textW)) rest -addKeyElements' position ((Vertical, keyText, keyColour):rest) - = do setSourceRGBAhex keyColour 1.0 - setLineWidth 3.0 - moveTo position 0 - relLineTo 0 25 - C.stroke - setSourceRGBA 0.0 0.0 0.0 1.0 - moveTo (position+5) 15 - textPath keyText - C.fill - tExtent <- textExtents keyText - addKeyElements' (position + 20 + textExtentsWidth tExtent) - rest - -------------------------------------------------------------------------------- -
− Timeline/Motion.hs
@@ -1,147 +0,0 @@-module Timeline.Motion (- zoomIn, zoomOut, zoomToFit,- scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, centreOnCursor,- vscrollDown, vscrollUp,- queueRedrawTimelines- ) where--import Timeline.Render.Constants-import State--import Graphics.UI.Gtk--import Data.Maybe-import Data.IORef-import Control.Monad--- import Text.Printf--- import Debug.Trace------------------------------------------------------------------------------------ Zoom in works by expanding the current view such that the --- left hand edge of the original view remains at the same--- position and the zoom in factor is 2.--- For example, zoom into the time range 1.0 3.0--- produces a new view with the time range 1.0 2.0--zoomIn :: ViewerState -> IO ()-zoomIn = zoom (/2)--zoomOut :: ViewerState -> IO ()-zoomOut = zoom (*2)--zoom :: (Double->Double) -> ViewerState -> IO ()-zoom factor state@ViewerState{..} = do- scaleValue <- readIORef scaleIORef- let clampedFactor = if factor scaleValue < 1 then- id- else- factor- let newScaleValue = clampedFactor scaleValue- writeIORef scaleIORef newScaleValue-- cursor <- readIORef cursorIORef- hadj_value <- adjustmentGetValue timelineAdj- hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar-- 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 pageshift = 0.9 * newPageSize- let nudge = 0.1 * newPageSize-- rangeSetIncrements timelineHScrollbar nudge pageshift-- scaleUpdateStatus state newScaleValue- queueRedrawTimelines state- ----------------------------------------------------------------------------------zoomToFit :: ViewerState -> IO ()-zoomToFit state@ViewerState{..} = do- mb_hecs <- readIORef hecsIORef- case mb_hecs of- Nothing -> writeIORef scaleIORef (-1.0)- 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-- -- 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- - adjustmentSetLower timelineAdj lower- adjustmentSetValue timelineAdj lower- adjustmentSetUpper timelineAdj upper- adjustmentSetPageSize timelineAdj page- rangeSetIncrements timelineHScrollbar 0 0-- scaleUpdateStatus state newScaleValue- queueRedrawTimelines state-----------------------------------------------------------------------------------scaleUpdateStatus :: ViewerState -> Double -> IO ()-scaleUpdateStatus state@ViewerState{..} newScaleValue = do- when debug $ do- ctx <- statusbarGetContextId statusBar "debug"- statusbarPush statusBar ctx ("Scale " ++ show newScaleValue)- return ()-----------------------------------------------------------------------------------scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, centreOnCursor- :: ViewerState -> IO ()--scrollLeft = scroll (\val page l u -> l `max` (val - page/2))-scrollRight = scroll (\val page l u -> (u - page) `min` (val + page/2))-scrollToBeginning = scroll (\_ _ l u -> l)-scrollToEnd = scroll (\_ _ l u -> u)--centreOnCursor state@ViewerState{..} = do- cursor <- readIORef cursorIORef- scroll (\_ page l u -> max l (fromIntegral cursor - page/2)) state--scroll :: (Double -> Double -> Double -> Double -> Double)- -> ViewerState -> IO ()-scroll adjust state@ViewerState{..}- = 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- adjustmentSetValue timelineAdj newValue - adjustmentValueChanged timelineAdj--vscrollDown, vscrollUp :: ViewerState -> IO ()-vscrollDown = vscroll (\val page l u -> (u - page) `min` (val + page/8))-vscrollUp = vscroll (\val page l u -> l `max` (val - page/8))--vscroll :: (Double -> Double -> Double -> Double -> Double)- -> ViewerState -> IO ()-vscroll adjust state@ViewerState{..}- = 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 ---- -------------------------------------------------------------------------------queueRedrawTimelines :: ViewerState -> IO ()-queueRedrawTimelines state = do- widgetQueueDraw (timelineDrawingArea state)- widgetQueueDraw (timelineLabelDrawingArea state)-
− Timeline/Render.hs
@@ -1,355 +0,0 @@-module Timeline.Render (- exposeTraceView,- renderTraces,- updateLabelDrawingArea,- calculateTotalTimelineHeight,- toWholePixels- ) where--import Timeline.Render.Constants-import Timeline.Motion-import Timeline.Ticks-import Timeline.HEC-import Timeline.Activity-import Timeline.RenderBookmarks-import Timeline.WithViewScale--import State-import ViewerColours-import Traces-import CairoDrawing--import GHC.RTS.Events hiding (Event)--import Graphics.UI.Gtk-import Graphics.UI.Gtk.Gdk.Events as Old-import Graphics.Rendering.Cairo as C-import Graphics.UI.Gtk.Gdk.GC--import Data.Maybe-import Data.IORef-import Control.Monad-import Text.Printf------------------------------------------------------------------------------------ |The 'updateProfileDrawingArea' function is called when an expose event--- occurs. This function redraws the currently visible part of the--- main trace canvas plus related canvases.--exposeTraceView :: ViewerState -> Region -> IO ()-exposeTraceView state@ViewerState{..} exposeRegion = do- maybeEventArray <- readIORef hecsIORef- - -- Check to see if an event trace has been loaded- case maybeEventArray of- Nothing -> return ()- Just hecs -> renderView state exposeRegion hecs--renderView :: ViewerState -> Region -> HECs -> IO ()-renderView state@ViewerState{..} exposeRegion hecs = do-- -- Get state information from user-interface components- bw_mode <- checkMenuItemGetActive bwToggle- labels_mode <- toggleToolButtonGetActive showLabelsToggle- (dAreaWidth,dAreaHeight) <- widgetGetSize timelineDrawingArea- when debug $ do- putStrLn ("\n=== updateCanvas") - putStrLn (show exposeRegion)- printf "width %d, height %d\n" dAreaWidth dAreaHeight-- scaleValue <- checkScaleValue state-- vadj_value <- adjustmentGetValue timelineVAdj- when debug $ liftIO $ printf "vadj_value: %f\n" vadj_value-- totalHeight <- calculateTotalTimelineHeight state- let timelineHeight = max totalHeight dAreaHeight- -- 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).-- -- snap the view to whole pixels, to avoid blurring- hadj_value0 <- adjustmentGetValue timelineAdj- let hadj_value = toWholePixels scaleValue hadj_value0-- when debug $ do- hadj_pagesize <- adjustmentGetPageSize timelineAdj - hadj_lower <- adjustmentGetLower timelineAdj- hadj_upper <- adjustmentGetUpper timelineAdj- ctx <- statusbarGetContextId statusBar "debug"- statusbarPush statusBar ctx $- printf "scale=%f win=(%d,%d) hadj: (val=%f, page=%f, l=%f u=%f)"- scaleValue dAreaWidth dAreaHeight- hadj_value hadj_pagesize hadj_lower hadj_upper- return ()-- traces <- getViewTraces state-- let params = ViewParameters {- width = dAreaWidth,- height = timelineHeight,- viewTraces = traces,- hadjValue = hadj_value,- scaleValue = scaleValue,- detail = 3, -- for now- bwMode = bw_mode,- labelsMode = labels_mode- }-- prev_view <- readIORef timelinePrevView- cursor_t <- readIORef cursorIORef-- rect <- regionGetClipbox exposeRegion-- win <- widgetGetDrawWindow timelineDrawingArea- renderWithDrawable win $ do-- let renderToNewSurface = do- new_surface <- withTargetSurface $ \surface -> - liftIO $ createSimilarSurface surface ContentColor- dAreaWidth timelineHeight- renderWith new_surface $ do - clearWhite- renderTraces state params traces hecs rect- return new_surface-- surface <- - case prev_view of- Nothing -> do- when debug $ liftIO $ putStrLn "no old surface"- renderToNewSurface-- Just (old_params, surface)- | old_params == params- -> do when debug $ liftIO $ putStrLn "using previously rendered view"- 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- -- and the views overlap...- then do - when debug $ liftIO $ putStrLn "scrolling"- scrollView state surface old_params params traces hecs- - else do - when debug $ liftIO $ putStrLn "using old surface"- renderWith surface $ do - clearWhite; renderTraces state params traces hecs rect- return surface-- | otherwise- -> do when debug $ liftIO $ putStrLn "old surface no good"- surfaceFinish surface- renderToNewSurface-- liftIO $ writeIORef timelinePrevView (Just (params, surface))-- region exposeRegion- clip- setSourceSurface surface 0 (-vadj_value)- -- ^^ this is where we adjust for the vertical scrollbar- setOperator OperatorSource- paint- when (scaleValue > 0) $ do- renderBookmarks state params- drawCursor cursor_t params--------------------------------------------------------------------------------------------------------------------------------------------------------------------drawCursor :: Timestamp -> ViewParameters -> Render ()-drawCursor cursor_t param@ViewParameters{..} = do- withViewScale param $ do- (threePixels, _) <- deviceToUserDistance 3 0- setLineWidth threePixels- setOperator OperatorOver- setSourceRGBAhex blue 1.0- moveTo (fromIntegral cursor_t) 0- lineTo (fromIntegral cursor_t) (fromIntegral height)- stroke------------------------------------------------------------------------------------- This function draws the current view of all the HECs with Cario--renderTraces :: ViewerState -> ViewParameters -> [Trace] -> HECs -> Rectangle- -> Render ()--renderTraces state@ViewerState{..} params@ViewParameters{..} - traces 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 (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 (max 0 (hadjValue + scale_width)),- ceiling (max 0 (hadjValue + scale_rx + scale_rw)),- hecLastEventTime hecs- ]-- when debug $ liftIO $ do- printf "rx = %d, scale_rx = %f, scale_rw = %f, hadjValue = %f, startPos = %d, endPos = %d scaleValue = %f\n" rx scale_rx scale_rw hadjValue startPos endPos scaleValue- - -- 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-- -- This function helps to render a single HEC...- let- renderTrace trace y = do- save- translate 0 (fromIntegral y)- case trace of - TraceHEC c -> - renderHEC c params startPos endPos (hecTrees hecs !! c)- TraceActivity ->- renderActivity params hecs startPos endPos- _ -> - return ()- restore- -- Now rennder all the HECs.- zipWithM_ renderTrace traces (traceYPositions labelsMode traces)- when debug $ liftIO $ putStrLn "renderTraces done\n"------------------------------------------------------------------------------------- parameters differ only in the hadjValue, we can scroll ...-scrollView :: ViewerState -> Surface- -> ViewParameters -> ViewParameters- -> [Trace] -> HECs- -> Render Surface--scrollView state surface old new traces 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-- 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.- C.fill-- let rect | old_hadj > new_hadj- = Rectangle 0 0 (ceiling off) (height new)- | otherwise- = Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new)-- case rect of - Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y) - (fromIntegral w) (fromIntegral h)- setSourceRGBA 0xffff 0xffff 0xffff 0xffff- C.fill-- renderTraces state new traces hecs rect-- surfaceFinish surface- return new_surface----------------------------------------------------------------------------------toWholePixels :: Double -> Double -> Double-toWholePixels 0 x = 0-toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale------------------------------------------------------------------------------------ This function returns a value which can be used to scale--- Timestamp event log values to pixels.--- If the scale has previous been computed then it is resued.--- An "uncomputed" scale value is represetned as -1.0 (defaultScaleValue)--- We estimate the width of the vertical scrollbar at 20 pixels--checkScaleValue :: ViewerState -> IO Double-checkScaleValue state@ViewerState{..}- = do scaleValue <- readIORef scaleIORef- if scaleValue < 0.0 - then do zoomToFit state- readIORef scaleIORef- else return scaleValue-----------------------------------------------------------------------------------updateLabelDrawingArea :: ViewerState -> Event -> IO Bool-updateLabelDrawingArea state@ViewerState{..} (Expose { Old.eventArea=rect })- = do traces <- getViewTraces state- labels_mode <- toggleToolButtonGetActive showLabelsToggle- win <- widgetGetDrawWindow timelineLabelDrawingArea- vadj_value <- adjustmentGetValue timelineVAdj- gc <- gcNew win- let ys = map (subtract (round vadj_value)) $ - traceYPositions labels_mode traces- zipWithM_ (drawLabel timelineLabelDrawingArea gc) traces ys- return True -updateLabelDrawingArea _ _ = error "updateLabelDrawingArea"--drawLabel :: DrawingArea -> GC -> Trace -> Int -> IO ()-drawLabel canvas gc trace y- = do win <- widgetGetDrawWindow canvas- txt <- canvas `widgetCreateLayout` (showTrace trace)- drawLayoutWithColors win gc 10 y txt (Just black) Nothing------------------------------------------------------------------------------------traceYPositions :: Bool -> [Trace] -> [Int]-traceYPositions labels_mode traces- = scanl (\a b -> a + (traceHeight b) + extra + tracePad) firstTraceY traces- where- extra = if labels_mode then hecLabelExtra else 0-- traceHeight (TraceHEC _) = hecTraceHeight- traceHeight TraceActivity = activityGraphHeight- traceHeight _ = 0------------------------------------------------------------------------------------showTrace :: Trace -> String-showTrace (TraceHEC n) = "HEC " ++ show n-showTrace TraceActivity = "Activity"-showTrace _ = "?"------------------------------------------------------------------------------------calculateTotalTimelineHeight :: ViewerState -> IO Int-calculateTotalTimelineHeight state@ViewerState{..} = do- traces <- getViewTraces state- labels_mode <- toggleToolButtonGetActive showLabelsToggle- return $ last (traceYPositions labels_mode traces)----------------------------------------------------------------------------------
− Timeline/Render/Constants.hs
@@ -1,51 +0,0 @@-module Timeline.Render.Constants (- ox, oy, firstTraceY, tracePad, - hecTraceHeight, hecBarOff, hecBarHeight, hecLabelExtra,- activityGraphHeight,- ticksHeight, ticksPad- ) where------------------------------------------------------------------------------------- Origin for graph--ox :: Int-ox = 10--oy :: Int-oy = 30---- Origin for capability bars--firstTraceY :: Int-firstTraceY = 60---- Gap betweem traces in the timeline view--tracePad :: Int-tracePad = 20---- HEC bar height--hecTraceHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int--hecTraceHeight = 40-hecBarHeight = 20-hecBarOff = 10---- extra space to allow between HECs when labels are on.--- ToDo: should be calculated somehow-hecLabelExtra = 80---- Activity graph--activityGraphHeight :: Int-activityGraphHeight = 100---- Ticks--ticksHeight :: Int-ticksHeight = 20--ticksPad :: Int-ticksPad = 20
− Timeline/RenderBookmarks.hs
@@ -1,42 +0,0 @@-------------------------------------------------------------------------------- --- This module implements the drawing of bookmarks in the Cario timeline --- canvas. It obtains the list of bookmarks from the list view of bookmarks --- and then renders the bookmarks in view. -------------------------------------------------------------------------------- - -module Timeline.RenderBookmarks (renderBookmarks) -where - -import Timeline.WithViewScale - -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import State -import CairoDrawing -import ViewerColours - -import GHC.RTS.Events hiding (Event) - -------------------------------------------------------------------------------- - -renderBookmarks :: ViewerState -> ViewParameters -> Render () -renderBookmarks state@ViewerState{..} params@ViewParameters{..} - = withViewScale params $ do - -- Get the list of bookmarks - bookmarkList <- liftIO $ listStoreToList bookmarkStore - -- Render the bookmarks - -- First set the line width to one pixel and set the line colour - (onePixel, _) <- deviceToUserDistance 1 0 - setLineWidth onePixel - setSourceRGBAhex bookmarkColour 1.0 - mapM_ (drawBookmark height) bookmarkList - return () - -------------------------------------------------------------------------------- - -drawBookmark :: Int -> Timestamp -> Render () -drawBookmark height bookmarkTime - = draw_line (bookmarkTime, 0) (bookmarkTime, height) - -------------------------------------------------------------------------------- -
− Timeline/Ticks.hs
@@ -1,150 +0,0 @@-module Timeline.Ticks ( - renderTicks - ) where - -import Timeline.Render.Constants -import CairoDrawing -import ViewerColours - -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - --- Imports for GHC Events -import qualified GHC.RTS.Events as GHCEvents -import GHC.RTS.Events hiding (Event) - -import Control.Monad - ---import Debug.Trace ---import Text.Printf - -------------------------------------------------------------------------------- --- Minor, semi-major and major ticks are drawn and the absolute periods 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). - --- 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. - -------------------------------------------------------------------------------- - -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 - - -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 - - 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 --- 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 - 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 :: Num a => a -> String -reformatMS pos - = deZero (show pos) - -------------------------------------------------------------------------------- - -deZero :: String -> String -deZero str - = if length str >= 3 && take 2 revstr == "0." then - reverse (drop 2 revstr) - else - str - where - revstr = reverse str - -------------------------------------------------------------------------------- -
− Timeline/WithViewScale.hs
@@ -1,18 +0,0 @@-module Timeline.WithViewScale -where - -import State - -import Graphics.Rendering.Cairo - -------------------------------------------------------------------------------- - -withViewScale :: ViewParameters -> Render () -> Render () -withViewScale params@ViewParameters{..} inner = do - save - scale (1/scaleValue) 1.0 - translate (-hadjValue) 0 - inner - restore - --------------------------------------------------------------------------------
− Traces.hs
@@ -1,55 +0,0 @@-module Traces ( - newHECs,- getViewTraces- ) where--import State--import Graphics.UI.Gtk-import Data.Tree---- Find the HEC traces in the treeStore and replace them-newHECs :: ViewerState -> HECs -> IO ()-newHECs state@ViewerState{..} hecs = do- go 0- treeStoreInsert tracesStore [] 0 (TraceActivity, True)- where- newt = Node { rootLabel = (TraceGroup "HECs", True),- subForest = [ Node { rootLabel = (TraceHEC n, True),- subForest = [] }- | n <- [ 0 .. hecCount hecs - 1 ] ] }-- go n = do- m <- treeStoreLookup tracesStore [n]- case m of- Nothing -> treeStoreInsertTree tracesStore [] 0 newt- Just t ->- case t of- Node { rootLabel = (TraceGroup "HECs", _) } -> do- treeStoreRemove tracesStore [n]- treeStoreInsertTree tracesStore [] n newt- Node { rootLabel = (TraceActivity, _) } -> do- treeStoreRemove tracesStore [n]- go (n+1)- _ ->- go (n+1)--getViewTraces :: ViewerState -> IO [Trace]-getViewTraces state@ViewerState{..} = do- f <- getTracesStoreContents state- return [ t | (t, True) <- concatMap flatten f, notGroup t ]- where- notGroup (TraceGroup _) = False- notGroup other = True--getTracesStoreContents :: ViewerState -> IO (Forest (Trace,Bool))-getTracesStoreContents ViewerState{..} = go 0- where- go !n = do- m <- treeStoreLookup tracesStore [n]- case m of- Nothing -> return []- Just t -> do- ts <- go (n+1)- return (t:ts)-
− Utils.hs
@@ -1,15 +0,0 @@-module Utils ( withBackgroundProcessing ) where--import Graphics.UI.Gtk-import Control.Exception-import Control.Concurrent---- Causes the gtk main loop to yield to other Haskell threads whenever--- it is idle. This should be used only when there is--- compute-intensive activity going on in other threads.-withBackgroundProcessing :: IO a -> IO a-withBackgroundProcessing f =- bracket - (idleAdd (yield >> return True) priorityDefaultIdle)- idleRemove- (\_ -> f)
− ViewerColours.hs
@@ -1,122 +0,0 @@-------------------------------------------------------------------------------- ---- $Id: ViewerColours.hs#2 2009/07/18 22:48:30 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $ -------------------------------------------------------------------------------- - -module ViewerColours where - -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo - -------------------------------------------------------------------------------- - --- Colours - -runningColour :: Color -runningColour = green - -gcColour :: Color -gcColour = orange - -gcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color -gcStartColour = orange -gcWorkColour = green -gcIdleColour = white -gcEndColour = orange - -createThreadColour :: Color -createThreadColour = lightBlue - -runSparkColour :: Color -runSparkColour = darkBlue - -stealSparkColour :: Color -stealSparkColour = magenta - -threadRunnableColour :: Color -threadRunnableColour = darkGreen - -seqGCReqColour :: Color -seqGCReqColour = cyan - -parGCReqColour :: Color -parGCReqColour = darkBlue - -migrateThreadColour :: Color -migrateThreadColour = darkRed - -threadWakeupColour :: Color -threadWakeupColour = purple - -shutdownColour :: Color -shutdownColour = darkBrown - -labelTextColour :: Color -labelTextColour = black - -bookmarkColour :: Color -bookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish - -------------------------------------------------------------------------------- - -black :: Color -black = Color 0 0 0 - -grey :: Color -grey = Color 0x8000 0x8000 0x8000 - -green :: Color -green = Color 0 0xFFFF 0 - -darkGreen :: Color -darkGreen = Color 0x0000 0x6600 0x0000 - -blue :: Color -blue = Color 0 0 0xFFFF - -cyan :: Color -cyan = Color 0 0xFFFF 0xFFFF - -magenta :: Color -magenta = Color 0xFFFF 0 0xFFFF - -lightBlue :: Color -lightBlue = Color 0x6600 0x9900 0xFF00 - -darkBlue :: Color -darkBlue = Color 0 0 0xBB00 - -purple :: Color -purple = Color 0x9900 0x0000 0xcc00 - -darkPurple :: Color -darkPurple = Color 0x6600 0 0x6600 - -darkRed :: Color -darkRed = Color 0xcc00 0x0000 0x0000 - -orange :: Color -orange = Color 0xFFFF 0x9900 0x0000 -- orange - -profileBackground :: Color -profileBackground = Color 0xFFFF 0xFFFF 0xFFFF - -tickColour :: Color -tickColour = Color 0x3333 0x3333 0xFFFF - -darkBrown :: Color -darkBrown = Color 0x6600 0 0 - -yellow :: Color -yellow = Color 0xff00 0xff00 0x3300 - -white :: Color -white = Color 0xffff 0xffff 0xffff - -------------------------------------------------------------------------------- -setSourceRGBAhex :: Color -> Double -> Render () -setSourceRGBAhex (Color r g b) t - = setSourceRGBA (fromIntegral r/0xFFFF) (fromIntegral g/0xFFFF) - (fromIntegral b/0xFFFF) t - --------------------------------------------------------------------------------
− ghcrts.c
@@ -1,1 +0,0 @@-char *ghc_rts_opts="-I0";
threadscope.cabal view
@@ -1,75 +1,92 @@-Name: threadscope -Version: 0.1.3 -Description: A graphical viewer for GHC eventlog traces. -License: BSD3 -License-file: LICENSE -Copyright: Released under the GHC license -Author: Donnie Jones, Simon Marlow, Satnam Singh -Maintainer: Satnam Singh <s.singh@ieee.org> -Bug-reports: Satnam Singh <s.singh@ieee.org> -Stability: Preliminary release. -Build-Type: Simple -Cabal-Version: >=1.2 -Data-files: threadscope.glade, threadscope.png -cabal-version: >= 1.6 -Category: Thread profiling utility -Synopsis: A graphical thread profiler. -Executable threadscope - Main-is: ThreadScope.hs - Build-Depends: base >= 4.0 && < 5, - gtk, cairo, glade, - binary, array, mtl, filepath, - ghc-events >= 0.2, - containers >= 0.2 && < 0.5 - extensions: RecordWildCards, BangPatterns, PatternGuards, - CPP - Other-Modules: About, - CairoDrawing, - EventDuration, - EventTree, - EventsWindow, - FileDialog, - Options, - ReadEvents, - SaveAsPDF, - SaveAsPNG, - Setup, - ShowEvents, - Sidebar, - State, - TestEvents, - Timeline, - Traces, - Utils, - ViewerColours, - Timeline.Activity, - Timeline.HEC, - Timeline.Key, - Timeline.Motion, - Timeline.Render, - Timeline.RenderBookmarks, - Timeline.Ticks, - Timeline.WithViewScale, - Timeline.Render.Constants - - ghc-options: -Wall -fno-warn-type-defaults -fno-warn-name-shadowing - - 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.5 - --- Not yet: gtk2hs doesn't support -threaded at the moment. --- ghc-options: -threaded - - c-sources: ghcrts.c - -source-repository head - type: darcs - location: http://code.haskell.org/ThreadScope/ +Name: threadscope+Version: 0.2.0+Category: Development, Profiling, Trace+Synopsis: A graphical tool for profiling parallel Haskell programs.+Description: ThreadScope is a graphical viewer for thread profile + information generated by the Glasgow Haskell compiler+ (GHC).+ .+ The Threadscope program allows us to debug the parallel+ performance of Haskell programs. Using Threadscope we can+ check to see that work is well balanced across the+ available processors and spot performance issues relating+ to garbage collection or poor load balancing.+License: BSD3+License-file: LICENSE+Copyright: 2009-2010 Satnam Singh,+ 2009-2011 Simon Marlow,+ 2009 Donnie Jones,+ 2011 Duncan Coutts,+ 2011 Mikolaj Konarski+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>+Maintainer: Satnam Singh <s.singh@ieee.org>+Bug-reports: http://trac.haskell.org/ThreadScope/+Build-Type: Simple+cabal-version: >= 1.6+Data-files: threadscope.ui, threadscope.png++source-repository head+ type: darcs+ location: http://code.haskell.org/ThreadScope/++Executable threadscope+ Main-is: Main.hs+ Build-Depends: base >= 4.0 && < 5,+ gtk >= 0.12, cairo, glib, pango,+ binary, array, mtl, filepath,+ ghc-events == 0.3.*,+ containers >= 0.2 && < 0.5+ extensions: RecordWildCards, NamedFieldPuns,+ BangPatterns, PatternGuards,+ CPP+ Other-Modules: Events.HECs,+ Events.EventDuration,+ Events.EventTree,+ Events.ReadEvents,+ Events.SparkStats,+ Events.SparkTree,+ Events.TestEvents,+ GUI.Main,+ GUI.MainWindow,+ GUI.EventsView,+ GUI.Dialogs,+ GUI.SaveAs,+ GUI.Timeline,+ GUI.TraceView,+ GUI.BookmarkView,+ GUI.KeyView,+ GUI.Types,+ GUI.ConcurrencyControl,+ GUI.ProgressView,+ GUI.ViewerColours,+ GUI.Timeline.Activity,+ GUI.Timeline.CairoDrawing,+ GUI.Timeline.HEC,+ GUI.Timeline.Motion,+ GUI.Timeline.Render,+ GUI.Timeline.Sparks,+ GUI.Timeline.Ticks,+ GUI.Timeline.Types,+ GUI.Timeline.Render.Constants,+ GUI.GtkExtras++ ghc-options: -Wall -fwarn-tabs+ -fno-warn-type-defaults -fno-warn-name-shadowing+ -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.glade
@@ -1,707 +0,0 @@-<?xml version="1.0"?>-<glade-interface>- <!-- interface-requires gtk+ 2.16 -->- <!-- interface-naming-policy toplevel-contextual -->- <widget 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_height">600</property>- <child>- <widget class="GtkVBox" id="vbox1">- <property name="visible">True</property>- <property name="orientation">vertical</property>- <property name="spacing">4</property>- <child>- <widget class="GtkMenuBar" id="menubar1">- <property name="visible">True</property>- <child>- <widget class="GtkMenuItem" id="menuitem1">- <property name="visible">True</property>- <property name="label" translatable="yes">_File</property>- <property name="use_underline">True</property>- <child>- <widget class="GtkMenu" id="menuitem1_menu">- <child>- <widget class="GtkImageMenuItem" id="openMenuItem">- <property name="label">gtk-open</property>- <property name="visible">True</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- </widget>- </child>- <child>- <widget class="GtkImageMenuItem" id="saveAsPDFMenuItem">- <property name="label">Save as PDF</property>- <property name="visible">True</property>- <property name="use_stock">False</property>- <child internal-child="image">- <widget class="GtkImage" id="image2">- <property name="visible">True</property>- <property name="stock">gtk-save-as</property>- <property name="icon-size">1</property>- </widget>- </child>- </widget>- </child>- <child>- <widget class="GtkImageMenuItem" id="saveAsPNGMenuItem">- <property name="label">Save as PNG</property>- <property name="visible">True</property>- <property name="use_stock">False</property>- <child internal-child="image">- <widget class="GtkImage" id="image3">- <property name="visible">True</property>- <property name="stock">gtk-save-as</property>- <property name="icon-size">1</property>- </widget>- </child>- </widget>- </child>- <child>- <widget class="GtkSeparatorMenuItem" id="separatormenuitem1">- <property name="visible">True</property>- </widget>- </child>- <child>- <widget class="GtkMenuItem" id="quitMenuItem">- <property name="visible">True</property>- <property name="label" translatable="yes">_Quit</property>- <property name="use_underline">True</property>- </widget>- </child>- </widget>- </child>- </widget>- </child>- <child>- <widget class="GtkMenuItem" id="viewMenuItem">- <property name="visible">True</property>- <property name="label" translatable="yes">_View</property>- <property name="use_underline">True</property>- <child>- <widget class="GtkMenu" id="viewMenuItem_menu">- <child>- <widget class="GtkCheckMenuItem" id="view_sidebar">- <property name="visible">True</property>- <property name="label" translatable="yes">Sidebar</property>- <property name="use_underline">True</property>- <property name="active">True</property>- <signal name="activate" handler="on_view_sidebar_activate"/>- </widget>- </child>- <child>- <widget class="GtkCheckMenuItem" id="black_and_white">- <property name="visible">True</property>- <property name="label" translatable="yes">Black/white</property>- <property name="use_underline">True</property>- <signal name="activate" handler="on_black_and_white_activate"/>- </widget>- </child>- <child>- <widget class="GtkSeparatorMenuItem" id="separator1">- <property name="visible">True</property>- </widget>- </child>- <child>- <widget class="GtkImageMenuItem" id="view_reload">- <property name="label">gtk-refresh</property>- <property name="visible">True</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- <signal name="activate" handler="on_view_reload_activate"/>- </widget>- </child>- </widget>- </child>- </widget>- </child>- <child>- <widget class="GtkMenuItem" id="menuitem4">- <property name="visible">True</property>- <property name="label" translatable="yes">_Help</property>- <property name="use_underline">True</property>- <child>- <widget class="GtkMenu" id="menuitem4_menu">- <child>- <widget class="GtkMenuItem" id="aboutMenuItem">- <property name="visible">True</property>- <property name="label" translatable="yes">_About</property>- <property name="use_underline">True</property>- </widget>- </child>- </widget>- </child>- </widget>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkHPaned" id="hpaned">- <property name="visible">True</property>- <property name="can_focus">True</property>- <child>- <widget class="GtkVBox" id="sidebar_vbox">- <property name="visible">True</property>- <property name="orientation">vertical</property>- <child>- <widget class="GtkHBox" id="sidebar_hbox">- <property name="visible">True</property>- <child>- <widget class="GtkComboBox" id="sidebar_combobox">- <property name="visible">True</property>- <property name="items" translatable="yes">Traces-Bookmarks-</property>- </widget>- <packing>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkButton" id="sidebar_close_button">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">False</property>- <child>- <widget class="GtkImage" id="image1">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Hide the sidebar</property>- <property name="stock">gtk-close</property>- </widget>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">1</property>- </packing>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkVBox" id="bookmarks_vbox">- <property name="visible">True</property>- <property name="orientation">vertical</property>- <child>- <widget class="GtkToolbar" id="toolbar3">- <property name="visible">True</property>- <property name="toolbar_style">both-horiz</property>- <property name="show_arrow">False</property>- <child>- <widget class="GtkToolButton" id="add_bookmark_button">- <property name="visible">True</property>- <property name="tooltip" translatable="yes">Add bookmark</property>- <property name="label" translatable="yes">Bookmark</property>- <property name="use_underline">True</property>- <property name="stock_id">gtk-add</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="delete_bookmark">- <property name="visible">True</property>- <property name="tooltip" translatable="yes">Delete bookmark</property>- <property name="stock_id">gtk-delete</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="goto_bookmark_button">- <property name="visible">True</property>- <property name="tooltip" translatable="yes">Jump to bookmark</property>- <property name="stock_id">gtk-jump-to</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkScrolledWindow" id="bookmark_list_scrolled_window">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="hscrollbar_policy">automatic</property>- <property name="vscrollbar_policy">automatic</property>- <child>- <widget class="GtkTreeView" id="bookmark_list">- <property name="visible">True</property>- <property name="can_focus">True</property>- </widget>- </child>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- </widget>- <packing>- <property name="resize">False</property>- <property name="shrink">True</property>- </packing>- </child>- <child>- <widget class="GtkNotebook" id="notebook1">- <property name="visible">True</property>- <property name="can_focus">True</property>- <child>- <widget class="GtkVBox" id="vbox2">- <property name="visible">True</property>- <property name="orientation">vertical</property>- <child>- <widget class="GtkHBox" id="hbox4">- <property name="visible">True</property>- <child>- <widget class="GtkLabel" id="label1">- <property name="visible">True</property>- </widget>- <packing>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkToolbar" id="toolbar2">- <property name="visible">True</property>- <property name="toolbar_style">both-horiz</property>- <property name="show_arrow">False</property>- <child>- <widget class="GtkToolButton" id="cpus_first">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Jump to start</property>- <property name="use_underline">True</property>- <property name="stock_id">gtk-goto-first</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="cpus_centre">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Centre view on the cursor</property>- <property name="stock_id">gtk-home</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="cpus_last">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Jump to the end</property>- <property name="use_underline">True</property>- <property name="stock_id">gtk-goto-last</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkSeparatorToolItem" id="separatortoolitem5">- <property name="visible">True</property>- </widget>- <packing>- <property name="expand">False</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="cpus_zoomin">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Zoom in</property>- <property name="stock_id">gtk-zoom-in</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="cpus_zoomout">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Zoom out</property>- <property name="stock_id">gtk-zoom-out</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="cpus_zoomfit">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Fit view to the window</property>- <property name="stock_id">gtk-zoom-fit</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkSeparatorToolItem" id="separatortoolitem4">- <property name="visible">True</property>- </widget>- <packing>- <property name="expand">False</property>- </packing>- </child>- <child>- <widget class="GtkToggleToolButton" id="cpus_showlabels">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Display labels</property>- <property name="label" translatable="yes">Show labels</property>- <property name="use_underline">True</property>- <property name="stock_id">gtk-info</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">1</property>- </packing>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkTable" id="table1">- <property name="visible">True</property>- <property name="n_rows">3</property>- <property name="n_columns">3</property>- <child>- <widget class="GtkLabel" id="label6">- <property name="visible">True</property>- </widget>- <packing>- <property name="left_attach">2</property>- <property name="right_attach">3</property>- <property name="top_attach">2</property>- <property name="bottom_attach">3</property>- <property name="x_options">GTK_SHRINK | GTK_FILL</property>- <property name="y_options">GTK_SHRINK | GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkLabel" id="label5">- <property name="visible">True</property>- </widget>- <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_SHRINK | GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkLabel" id="label4">- <property name="visible">True</property>- </widget>- <packing>- <property name="left_attach">2</property>- <property name="right_attach">3</property>- <property name="top_attach">1</property>- <property name="bottom_attach">2</property>- <property name="x_options">GTK_SHRINK | GTK_FILL</property>- <property name="y_options">GTK_SHRINK | GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkLabel" id="label3">- <property name="visible">True</property>- </widget>- <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_SHRINK | GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkVScrollbar" id="timeline_vscroll">- <property name="visible">True</property>- <property name="orientation">vertical</property>- </widget>- <packing>- <property name="left_attach">2</property>- <property name="right_attach">3</property>- <property name="x_options">GTK_SHRINK | GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkHScrollbar" id="timeline_hscroll">- <property name="visible">True</property>- </widget>- <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>- <property name="y_options">GTK_SHRINK</property>- </packing>- </child>- <child>- <widget class="GtkDrawingArea" id="timeline_drawingarea">- <property name="visible">True</property>- </widget>- <packing>- <property name="left_attach">1</property>- <property name="right_attach">2</property>- </packing>- </child>- <child>- <widget class="GtkDrawingArea" id="timeline_labels_drawingarea">- <property name="width_request">80</property>- <property name="visible">True</property>- </widget>- <packing>- <property name="x_options">GTK_FILL</property>- <property name="y_options">GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkDrawingArea" id="timeline_key_drawingarea">- <property name="height_request">30</property>- <property name="visible">True</property>- </widget>- <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="x_options">GTK_FILL</property>- <property name="y_options">GTK_FILL</property>- </packing>- </child>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- </widget>- </child>- <child>- <widget class="GtkLabel" id="timeline_label">- <property name="visible">True</property>- <property name="label" translatable="yes">Timeline</property>- </widget>- <packing>- <property name="tab_fill">False</property>- <property name="type">tab</property>- </packing>- </child>- <child>- <widget class="GtkVBox" id="vbox4">- <property name="visible">True</property>- <property name="orientation">vertical</property>- <child>- <widget class="GtkHBox" id="hbox5">- <property name="visible">True</property>- <child>- <widget class="GtkLabel" id="label2">- <property name="visible">True</property>- </widget>- <packing>- <property name="fill">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <widget 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>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- <child>- <widget class="GtkToolbar" id="toolbar5">- <property name="visible">True</property>- <property name="toolbar_style">both-horiz</property>- <property name="show_arrow">False</property>- <child>- <widget class="GtkToolButton" id="events_find">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Search for event</property>- <property name="stock_id">gtk-find</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkSeparatorToolItem" id="separatortoolitem6">- <property name="visible">True</property>- </widget>- <packing>- <property name="expand">False</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="events_first">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Jump to beginning</property>- <property name="stock_id">gtk-goto-first</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="events_home">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Centre view on cursor</property>- <property name="stock_id">gtk-home</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- <child>- <widget class="GtkToolButton" id="events_last">- <property name="visible">True</property>- <property name="has_tooltip">True</property>- <property name="tooltip" translatable="yes">Jump to end</property>- <property name="stock_id">gtk-goto-last</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="homogeneous">True</property>- </packing>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">2</property>- </packing>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkHBox" id="eventsHBox">- <property name="visible">True</property>- <child>- <widget class="GtkDrawingArea" id="eventsDrawingArea">- <property name="visible">True</property>- <property name="can_focus">True</property>- </widget>- <packing>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkVScrollbar" id="eventsVScroll">- <property name="visible">True</property>- <property name="orientation">vertical</property>- <property name="adjustment">0 0 0 0 0 0</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">1</property>- </packing>- </child>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- <child>- <widget class="GtkLabel" id="eventslabel">- <property name="visible">True</property>- <property name="label" translatable="yes">Events</property>- </widget>- <packing>- <property name="position">1</property>- <property name="tab_fill">False</property>- <property name="type">tab</property>- </packing>- </child>- </widget>- <packing>- <property name="resize">True</property>- <property name="shrink">True</property>- </packing>- </child>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- <child>- <widget class="GtkStatusbar" id="statusbar">- <property name="visible">True</property>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">2</property>- </packing>- </child>- </widget>- </child>- </widget>-</glade-interface>
+ threadscope.ui view
@@ -0,0 +1,701 @@+<?xml version="1.0" encoding="UTF-8"?>+<interface>+ <requires lib="gtk+" version="2.16"/>+ <!-- interface-naming-policy toplevel-contextual -->+ <object class="GtkAdjustment" id="adjustment1"/>+ <object class="GtkImage" id="image1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-refresh</property>+ </object>+ <object class="GtkImage" id="image2">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ <object class="GtkImage" id="image3">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-save-as</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_height">600</property>+ <child>+ <object class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkMenuBar" id="menubar1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkMenuItem" id="menuitem1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">_File</property>+ <property name="use_underline">True</property>+ <child type="submenu">+ <object class="GtkMenu" id="menu1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkImageMenuItem" id="openMenuItem">+ <property name="label">gtk-open</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="use_stock">True</property>+ <accelerator key="o" signal="activate" modifiers="GDK_CONTROL_MASK"/>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="exportMenuItem">+ <property name="label" translatable="yes">Export image...</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="image">image2</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ <child>+ <object class="GtkSeparatorMenuItem" id="separatormenuitem1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="quitMenuItem">+ <property name="label">gtk-quit</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="use_stock">True</property>+ <accelerator key="q" signal="activate" modifiers="GDK_CONTROL_MASK"/>+ </object>+ </child>+ </object>+ </child>+ </object>+ </child>+ <child>+ <object class="GtkMenuItem" id="menuitem2">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">_View</property>+ <property name="use_underline">True</property>+ <child type="submenu">+ <object class="GtkMenu" id="menu2">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkCheckMenuItem" id="view_sidebar">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">Sidebar</property>+ <property name="use_underline">True</property>+ <property name="active">True</property>+ </object>+ </child>+ <child>+ <object class="GtkCheckMenuItem" id="view_events">+ <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="use_underline">True</property>+ <property name="active">True</property>+ </object>+ </child>+ <child>+ <object class="GtkCheckMenuItem" id="black_and_white">+ <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="use_underline">True</property>+ </object>+ </child>+ <child>+ <object class="GtkSeparatorMenuItem" id="separatormenuitem2">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="view_reload">+ <property name="label">_Reload</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">image1</property>+ <property name="use_stock">False</property>+ <accelerator key="r" signal="activate" modifiers="GDK_CONTROL_MASK"/>+ </object>+ </child>+ </object>+ </child>+ </object>+ </child>+ <child>+ <object class="GtkMenuItem" id="menuitem3">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">Help</property>+ <property name="use_underline">True</property>+ <child type="submenu">+ <object class="GtkMenu" id="menu3">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkImageMenuItem" id="aboutMenuItem">+ <property name="label">gtk-about</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="use_stock">True</property>+ </object>+ </child>+ </object>+ </child>+ </object>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkToolbar" id="toolbar2">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="toolbar_style">both-horiz</property>+ <property name="show_arrow">False</property>+ <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="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="stock_id">gtk-goto-first</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkToolButton" id="cpus_centre">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Centre view on the cursor</property>+ <property name="use_action_appearance">False</property>+ <property name="stock_id">gtk-home</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkToolButton" id="cpus_last">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Jump to the end</property>+ <property name="use_action_appearance">False</property>+ <property name="use_underline">True</property>+ <property name="stock_id">gtk-goto-last</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkSeparatorToolItem" id="separatortoolitem5">+ <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_zoomin">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Zoom in</property>+ <property name="use_action_appearance">False</property>+ <property name="stock_id">gtk-zoom-in</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkToolButton" id="cpus_zoomout">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Zoom out</property>+ <property name="use_action_appearance">False</property>+ <property name="stock_id">gtk-zoom-out</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkToolButton" id="cpus_zoomfit">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="tooltip_text" translatable="yes">Fit view to the window</property>+ <property name="use_action_appearance">False</property>+ <property name="stock_id">gtk-zoom-fit</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <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>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkHPaned" id="hpaned">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <child>+ <object class="GtkNotebook" id="sidebar">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <child>+ <object class="GtkScrolledWindow" id="scrolledwindow2">+ <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="key_list">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="headers_visible">False</property>+ <property name="enable_search">False</property>+ </object>+ </child>+ </object>+ </child>+ <child type="tab">+ <object class="GtkLabel" id="label5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Key</property>+ </object>+ <packing>+ <property name="position">2</property>+ <property name="tab_fill">False</property>+ </packing>+ </child>+ <child>+ <object class="GtkScrolledWindow" id="scrolledwindow1">+ <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="traces_tree">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="headers_visible">False</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ <child type="tab">+ <object class="GtkLabel" id="label1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Traces</property>+ </object>+ <packing>+ <property name="position">1</property>+ <property name="tab_fill">False</property>+ </packing>+ </child>+ <child>+ <object class="GtkVBox" id="bookmarks_vbox">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkToolbar" id="toolbar3">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="toolbar_style">both-horiz</property>+ <property name="show_arrow">False</property>+ <child>+ <object class="GtkToolButton" id="goto_bookmark_button">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="is_important">True</property>+ <property name="stock_id">gtk-jump-to</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkToolButton" id="add_bookmark_button">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="label" translatable="yes">Bookmark</property>+ <property name="use_underline">True</property>+ <property name="stock_id">gtk-add</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkToolButton" id="delete_bookmark">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="use_action_appearance">False</property>+ <property name="stock_id">gtk-remove</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="homogeneous">True</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkScrolledWindow" id="bookmark_list_scrolled_window">+ <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="bookmark_list">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="headers_clickable">False</property>+ </object>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="position">2</property>+ </packing>+ </child>+ <child type="tab">+ <object class="GtkLabel" id="label2">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Bookmarks</property>+ </object>+ <packing>+ <property name="position">2</property>+ <property name="tab_fill">False</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="resize">False</property>+ <property name="shrink">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkVPaned" id="vpaned1">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <child>+ <object class="GtkVBox" id="timelinebox">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkLabel" id="label3">+ <property name="visible">True</property>+ <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>Timeline</b></property>+ <property name="use_markup">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkTable" id="table1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="n_rows">2</property>+ <property name="n_columns">2</property>+ <property name="column_spacing">3</property>+ <property name="row_spacing">3</property>+ <child>+ <object class="GtkVScrollbar" id="timeline_vscroll">+ <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="x_options">GTK_SHRINK | GTK_FILL</property>+ </packing>+ </child>+ <child>+ <object class="GtkHScrollbar" id="timeline_hscroll">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="restrict_to_fill_level">False</property>+ <property name="fill_level">0</property>+ </object>+ <packing>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="y_options">GTK_SHRINK</property>+ </packing>+ </child>+ <child>+ <object class="GtkViewport" id="timeline_viewport">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="has_focus">True</property>+ <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">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkDrawingArea" id="timeline_labels_drawingarea">+ <property name="width_request">100</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>+ </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>+ </packing>+ </child>+ </object>+ </child>+ </object>+ </child>+ <child>+ <placeholder/>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="resize">True</property>+ <property name="shrink">True</property>+ </packing>+ </child>+ <child>+ <object class="GtkVBox" id="eventsbox">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkLabel" id="label4">+ <property name="visible">True</property>+ <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>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <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="padding">3</property>+ <property name="position">2</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="resize">False</property>+ <property name="shrink">True</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="resize">True</property>+ <property name="shrink">True</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <object class="GtkStatusbar" id="statusbar">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="position">3</property>+ </packing>+ </child>+ </object>+ </child>+ </object>+ <object class="GtkListStore" id="sidebar_items">+ <columns>+ <!-- column-name name -->+ <column type="gchararray"/>+ </columns>+ </object>+</interface>