threadscope (empty) → 0.1
raw patch · 34 files changed
+4494/−0 lines, 34 filesdep +arraydep +basedep +binarysetup-changedbinary-added
Dependencies added: array, base, binary, cairo, containers, filepath, ghc-events, glade, gtk, mtl, unix
Files
- About.hs +34/−0
- CairoDrawing.hs +88/−0
- EventDuration.hs +174/−0
- EventTree.hs +272/−0
- EventsWindow.hs +267/−0
- FileDialog.hs +29/−0
- LICENSE +31/−0
- Options.hs +26/−0
- ReadEvents.hs +190/−0
- SaveAsPDF.hs +42/−0
- SaveAsPNG.hs +45/−0
- Setup.hs +2/−0
- ShowEvents.hs +62/−0
- Sidebar.hs +89/−0
- State.hs +125/−0
- TestEvents.hs +332/−0
- ThreadScope.hs +271/−0
- Timeline.hs +182/−0
- Timeline/Activity.hs +177/−0
- Timeline/HEC.hs +253/−0
- Timeline/Key.hs +72/−0
- Timeline/Motion.hs +147/−0
- Timeline/Render.hs +361/−0
- Timeline/Render/Constants.hs +51/−0
- Timeline/RenderBookmarks.hs +42/−0
- Timeline/Ticks.hs +140/−0
- Timeline/WithViewScale.hs +18/−0
- Traces.hs +55/−0
- Utils.hs +15/−0
- ViewerColours.hs +122/−0
- ghcrts.c +1/−0
- threadscope.cabal +72/−0
- threadscope.glade +707/−0
- threadscope.png binary
+ About.hs view
@@ -0,0 +1,34 @@+------------------------------------------------------------------------------- +--- $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 + +------------------------------------------------------------------------------- + +showAboutDialog :: Window -> IO () +showAboutDialog parent + = do aboutDialog <- aboutDialogNew + logoPath <- getDataFileName "threadscope.png" + logo <- pixbufNewFromFile logoPath + set aboutDialog [ + aboutDialogName := "ThreadScope", + aboutDialogVersion := "0.1", + aboutDialogCopyright := "Released under the GHC license.", + 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://code.haskell.org/ThreadScope" + ] + windowSetTransientFor aboutDialog parent + afterResponse aboutDialog $ \_ -> widgetDestroy aboutDialog + widgetShow aboutDialog + +-------------------------------------------------------------------------------
+ CairoDrawing.hs view
@@ -0,0 +1,88 @@+------------------------------------------------------------------------------- +--- $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 + +-------------------------------------------------------------------------------
+ EventDuration.hs view
@@ -0,0 +1,174 @@+-- 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) = findRunThreadTime events + +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] -> (Timestamp, ThreadStopStatus) +findRunThreadTime [] = error "findRunThreadTime" +findRunThreadTime (e : es) + = case spec e of + StopThread{status=s} -> (time e, s) + _ -> findRunThreadTime es + +-------------------------------------------------------------------------------
+ EventTree.hs view
@@ -0,0 +1,272 @@+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
+ EventsWindow.hs view
@@ -0,0 +1,267 @@+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)+ 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 view
@@ -0,0 +1,29 @@+------------------------------------------------------------------------------- +--- $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 + +------------------------------------------------------------------------------- +
+ LICENSE view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License + +Copyright 2002, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE.
+ Options.hs view
@@ -0,0 +1,26 @@+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 view
@@ -0,0 +1,190 @@+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 = "Loading " ++ (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 view
@@ -0,0 +1,42 @@+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 view
@@ -0,0 +1,45 @@+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
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ ShowEvents.hs view
@@ -0,0 +1,62 @@+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 view
@@ -0,0 +1,89 @@+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 view
@@ -0,0 +1,125 @@+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 view
@@ -0,0 +1,332 @@+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 view
@@ -0,0 +1,271 @@+{-# 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 view
@@ -0,0 +1,182 @@+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 view
@@ -0,0 +1,177 @@+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 view
@@ -0,0 +1,253 @@+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 view
@@ -0,0 +1,72 @@+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 + +------------------------------------------------------------------------------- + +updateKeyDrawingArea :: DrawingArea -> Event -> IO Bool +updateKeyDrawingArea canvas _ + = do win <- widgetGetDrawWindow canvas + renderWithDrawable win addKeyElements + return True + +------------------------------------------------------------------------------- + +data KeyStyle = Box | Vertical + +------------------------------------------------------------------------------- + +addKeyElements :: Render () +addKeyElements + = do 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 view
@@ -0,0 +1,147 @@+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 view
@@ -0,0 +1,361 @@+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 GHC.RTS.Events hiding (Event)++import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.Events as Old+import Graphics.Rendering.Cairo as C++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++-------------------------------------------------------------------------------++clearWhite :: Render ()+clearWhite = do+ save+ setOperator OperatorSource+ setSourceRGBA 0xffff 0xffff 0xffff 0xffff+ paint+ restore++-------------------------------------------------------------------------------++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 view
@@ -0,0 +1,51 @@+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 view
@@ -0,0 +1,42 @@+------------------------------------------------------------------------------- +-- 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 view
@@ -0,0 +1,140 @@+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) ++ ('\x00b5':"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 + +------------------------------------------------------------------------------- + +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 view
@@ -0,0 +1,18 @@+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 view
@@ -0,0 +1,55 @@+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 view
@@ -0,0 +1,15 @@+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)+ timeoutRemove+ (\_ -> f)
+ ViewerColours.hs view
@@ -0,0 +1,122 @@+------------------------------------------------------------------------------- +--- $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 view
@@ -0,0 +1,1 @@+char *ghc_rts_opts="-I0";
+ threadscope.cabal view
@@ -0,0 +1,72 @@+Name: threadscope +Version: 0.1 +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 && < 0.3, + containers >= 0.2 && < 0.3 + extensions: RecordWildCards, BangPatterns, PatternGuards + 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 + + if impl(ghc < 6.12) + -- GHC before 6.12 gave spurious warnings for RecordWildCards + ghc-options: -Wall -fno-warn-unused-matches + else + ghc-options: -Wall + + if !os(windows) + build-depends: unix >= 2.3.0 + + ghc-options: -fno-warn-type-defaults -fno-warn-name-shadowing + +-- 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/
+ threadscope.glade view
@@ -0,0 +1,707 @@+<?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.png view
binary file changed (absent → 5358 bytes)