diff --git a/About.hs b/About.hs
new file mode 100644
--- /dev/null
+++ b/About.hs
@@ -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
+
+-------------------------------------------------------------------------------
diff --git a/CairoDrawing.hs b/CairoDrawing.hs
new file mode 100644
--- /dev/null
+++ b/CairoDrawing.hs
@@ -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
+
+-------------------------------------------------------------------------------
diff --git a/EventDuration.hs b/EventDuration.hs
new file mode 100644
--- /dev/null
+++ b/EventDuration.hs
@@ -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
+
+-------------------------------------------------------------------------------
diff --git a/EventTree.hs b/EventTree.hs
new file mode 100644
--- /dev/null
+++ b/EventTree.hs
@@ -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
diff --git a/EventsWindow.hs b/EventsWindow.hs
new file mode 100644
--- /dev/null
+++ b/EventsWindow.hs
@@ -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
diff --git a/FileDialog.hs b/FileDialog.hs
new file mode 100644
--- /dev/null
+++ b/FileDialog.hs
@@ -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
+
+-------------------------------------------------------------------------------
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Options.hs b/Options.hs
new file mode 100644
--- /dev/null
+++ b/Options.hs
@@ -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
+
+-----------------------------------------------------------------------------
diff --git a/ReadEvents.hs b/ReadEvents.hs
new file mode 100644
--- /dev/null
+++ b/ReadEvents.hs
@@ -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 "Loading %s" (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)
+
+-------------------------------------------------------------------------------
+
diff --git a/SaveAsPDF.hs b/SaveAsPDF.hs
new file mode 100644
--- /dev/null
+++ b/SaveAsPDF.hs
@@ -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 ()
+
+-------------------------------------------------------------------------------
diff --git a/SaveAsPNG.hs b/SaveAsPNG.hs
new file mode 100644
--- /dev/null
+++ b/SaveAsPNG.hs
@@ -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 ()
+
+-------------------------------------------------------------------------------
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/ShowEvents.hs b/ShowEvents.hs
new file mode 100644
--- /dev/null
+++ b/ShowEvents.hs
@@ -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"
diff --git a/Sidebar.hs b/Sidebar.hs
new file mode 100644
--- /dev/null
+++ b/Sidebar.hs
@@ -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 ()
diff --git a/State.hs b/State.hs
new file mode 100644
--- /dev/null
+++ b/State.hs
@@ -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
+
diff --git a/TestEvents.hs b/TestEvents.hs
new file mode 100644
--- /dev/null
+++ b/TestEvents.hs
@@ -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
+
+-------------------------------------------------------------------------------
+
diff --git a/ThreadScope.hs b/ThreadScope.hs
new file mode 100644
--- /dev/null
+++ b/ThreadScope.hs
@@ -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 { .. }
diff --git a/Timeline.hs b/Timeline.hs
new file mode 100644
--- /dev/null
+++ b/Timeline.hs
@@ -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
diff --git a/Timeline/Activity.hs b/Timeline/Activity.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/Activity.hs
@@ -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
+
diff --git a/Timeline/HEC.hs b/Timeline/HEC.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/HEC.hs
@@ -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
+
+-------------------------------------------------------------------------------
diff --git a/Timeline/Key.hs b/Timeline/Key.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/Key.hs
@@ -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
+
+-------------------------------------------------------------------------------
+
diff --git a/Timeline/Motion.hs b/Timeline/Motion.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/Motion.hs
@@ -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)
+
diff --git a/Timeline/Render.hs b/Timeline/Render.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/Render.hs
@@ -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)
+
+--------------------------------------------------------------------------------
diff --git a/Timeline/Render/Constants.hs b/Timeline/Render/Constants.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/Render/Constants.hs
@@ -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
diff --git a/Timeline/RenderBookmarks.hs b/Timeline/RenderBookmarks.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/RenderBookmarks.hs
@@ -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)
+
+-------------------------------------------------------------------------------
+
diff --git a/Timeline/Ticks.hs b/Timeline/Ticks.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/Ticks.hs
@@ -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
+
+-------------------------------------------------------------------------------
+
diff --git a/Timeline/WithViewScale.hs b/Timeline/WithViewScale.hs
new file mode 100644
--- /dev/null
+++ b/Timeline/WithViewScale.hs
@@ -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
+
+-------------------------------------------------------------------------------
diff --git a/Traces.hs b/Traces.hs
new file mode 100644
--- /dev/null
+++ b/Traces.hs
@@ -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)
+
diff --git a/Utils.hs b/Utils.hs
new file mode 100644
--- /dev/null
+++ b/Utils.hs
@@ -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)
diff --git a/ViewerColours.hs b/ViewerColours.hs
new file mode 100644
--- /dev/null
+++ b/ViewerColours.hs
@@ -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
+
+-------------------------------------------------------------------------------
diff --git a/ghcrts.c b/ghcrts.c
new file mode 100644
--- /dev/null
+++ b/ghcrts.c
@@ -0,0 +1,1 @@
+char *ghc_rts_opts="-I0";
diff --git a/threadscope.cabal b/threadscope.cabal
new file mode 100644
--- /dev/null
+++ b/threadscope.cabal
@@ -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
+Bug-reports: Satnam Singh
+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/
diff --git a/threadscope.glade b/threadscope.glade
new file mode 100644
--- /dev/null
+++ b/threadscope.glade
@@ -0,0 +1,707 @@
+
+
+
+
+
+ 600
+ 400
+ True
+ ThreadScope
+ 1280
+ 600
+
+
+ True
+ vertical
+ 4
+
+
+
+ False
+ 0
+
+
+
+
+ True
+ True
+
+
+
+ False
+ True
+
+
+
+
+ True
+ True
+
+
+ True
+ vertical
+
+
+ True
+
+
+ True
+
+
+ 0
+
+
+
+
+ True
+ both-horiz
+ False
+
+
+ True
+ True
+ Jump to start
+ True
+ gtk-goto-first
+
+
+ False
+ True
+
+
+
+
+ True
+ True
+ Centre view on the cursor
+ gtk-home
+
+
+ False
+ True
+
+
+
+
+ True
+ True
+ Jump to the end
+ True
+ gtk-goto-last
+
+
+ False
+ True
+
+
+
+
+ True
+
+
+ False
+
+
+
+
+ True
+ True
+ Zoom in
+ gtk-zoom-in
+
+
+ False
+ True
+
+
+
+
+ True
+ True
+ Zoom out
+ gtk-zoom-out
+
+
+ False
+ True
+
+
+
+
+ True
+ True
+ Fit view to the window
+ gtk-zoom-fit
+
+
+ False
+ True
+
+
+
+
+ True
+
+
+ False
+
+
+
+
+ True
+ True
+ Display labels
+ Show labels
+ True
+ gtk-info
+
+
+ False
+ True
+
+
+
+
+ False
+ False
+ 1
+
+
+
+
+ False
+ 0
+
+
+
+
+ True
+ 3
+ 3
+
+
+ True
+
+
+ 2
+ 3
+ 2
+ 3
+ GTK_SHRINK | GTK_FILL
+ GTK_SHRINK | GTK_FILL
+
+
+
+
+ True
+
+
+ 2
+ 3
+ GTK_FILL
+ GTK_SHRINK | GTK_FILL
+
+
+
+
+ True
+
+
+ 2
+ 3
+ 1
+ 2
+ GTK_SHRINK | GTK_FILL
+ GTK_SHRINK | GTK_FILL
+
+
+
+
+ True
+
+
+ 1
+ 2
+ GTK_FILL
+ GTK_SHRINK | GTK_FILL
+
+
+
+
+ True
+ vertical
+
+
+ 2
+ 3
+ GTK_SHRINK | GTK_FILL
+
+
+
+
+ True
+
+
+ 1
+ 2
+ 1
+ 2
+ GTK_SHRINK
+
+
+
+
+ True
+
+
+ 1
+ 2
+
+
+
+
+ 80
+ True
+
+
+ GTK_FILL
+ GTK_FILL
+
+
+
+
+ 30
+ True
+
+
+ 1
+ 2
+ 2
+ 3
+ GTK_FILL
+ GTK_FILL
+
+
+
+
+ 1
+
+
+
+
+
+
+ True
+ Timeline
+
+
+ False
+ tab
+
+
+
+
+ True
+ vertical
+
+
+ True
+
+
+ True
+
+
+ False
+ 0
+
+
+
+
+ True
+ True
+ ●
+ 20
+
+
+ 1
+
+
+
+
+ True
+ both-horiz
+ False
+
+
+ True
+ True
+ Search for event
+ gtk-find
+
+
+ False
+ True
+
+
+
+
+ True
+
+
+ False
+
+
+
+
+ True
+ True
+ Jump to beginning
+ gtk-goto-first
+
+
+ False
+ True
+
+
+
+
+ True
+ True
+ Centre view on cursor
+ gtk-home
+
+
+ False
+ True
+
+
+
+
+ True
+ True
+ Jump to end
+ gtk-goto-last
+
+
+ False
+ True
+
+
+
+
+ False
+ False
+ 2
+
+
+
+
+ False
+ 0
+
+
+
+
+ True
+
+
+ True
+ True
+
+
+ 0
+
+
+
+
+ True
+ vertical
+ 0 0 0 0 0 0
+
+
+ False
+ 1
+
+
+
+
+ 1
+
+
+
+
+ 1
+
+
+
+
+ True
+ Events
+
+
+ 1
+ False
+ tab
+
+
+
+
+ True
+ True
+
+
+
+
+ 1
+
+
+
+
+ True
+
+
+ False
+ 2
+
+
+
+
+
+
diff --git a/threadscope.png b/threadscope.png
new file mode 100644
Binary files /dev/null and b/threadscope.png differ