diff -Nru threadscope-0.1.3/About.hs threadscope-0.2.1/About.hs --- threadscope-0.1.3/About.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/About.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -------------------------------------------------------------------------------- ---- $Id: About.hs#1 2009/03/20 13:27:50 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/About.hs $ -------------------------------------------------------------------------------- - -module About where - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Paths_threadscope -import Data.Version (showVersion) - -------------------------------------------------------------------------------- - -showAboutDialog :: Window -> IO () -showAboutDialog parent - = do aboutDialog <- aboutDialogNew - logoPath <- getDataFileName "threadscope.png" - logo <- pixbufNewFromFile logoPath - set aboutDialog [ - aboutDialogName := "ThreadScope", - aboutDialogVersion := showVersion version, - aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.", - aboutDialogComments := "A GHC eventlog profile viewer", - aboutDialogAuthors := ["Donnie Jones (donnie@darthik.com)", - "Simon Marlow (simonm@microsoft.com)", - "Satnam Singh (s.singh@ieee.org)"], - aboutDialogLogo := Just logo, - aboutDialogWebsite := "http://research.microsoft.com/threadscope" - ] - windowSetTransientFor aboutDialog parent - afterResponse aboutDialog $ \_ -> widgetDestroy aboutDialog - widgetShow aboutDialog - -------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/CairoDrawing.hs threadscope-0.2.1/CairoDrawing.hs --- threadscope-0.1.3/CairoDrawing.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/CairoDrawing.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -------------------------------------------------------------------------------- ---- $Id: CairoDrawing.hs#3 2009/07/18 22:48:30 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/CairoDrawing.hs $ -------------------------------------------------------------------------------- - -module CairoDrawing -where - -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C -import Control.Monad - -------------------------------------------------------------------------------- - -{-# INLINE draw_line #-} -draw_line :: (Integral a, Integral b, Integral c, Integral d) => - (a, b) -> (c, d) -> Render () -draw_line (x0, y0) (x1, y1) - = do move_to (x0, y0) - lineTo (fromIntegral x1) (fromIntegral y1) - stroke - -{-# INLINE move_to #-} -move_to :: (Integral a, Integral b) => (a, b) -> Render () -move_to (x, y) - = moveTo (fromIntegral x) (fromIntegral y) - -{-# INLINE rel_line_to #-} -rel_line_to :: (Integral a, Integral b) => (a, b) -> Render () -rel_line_to (x, y) - = relLineTo (fromIntegral x) (fromIntegral y) - -------------------------------------------------------------------------------- - -{-# INLINE draw_rectangle #-} -draw_rectangle :: (Integral x, Integral y, Integral w, Integral h) - => x -> y -> w -> h - -> Render () -draw_rectangle x y w h = do - rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - C.fill - -------------------------------------------------------------------------------- - -{-# INLINE draw_outlined_rectangle #-} -draw_outlined_rectangle :: (Integral x, Integral y, Integral w, Integral h) - => x -> y -> w -> h - -> Render () -draw_outlined_rectangle x y w h = do - rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - fillPreserve - setLineWidth 1 - setSourceRGBA 0 0 0 0.7 - stroke - -------------------------------------------------------------------------------- - -{-# INLINE draw_rectangle_opt #-} -draw_rectangle_opt :: (Integral x, Integral y, Integral w, Integral h) - => Bool -> x -> y -> w -> h - -> Render () -draw_rectangle_opt opt x y w h - = draw_rectangle_opt' opt (fromIntegral x) (fromIntegral y) - (fromIntegral w) (fromIntegral h) - -draw_rectangle_opt' :: Bool -> Double -> Double -> Double -> Double - -> Render () -draw_rectangle_opt' opt x y w h - = do rectangle x y (1.0 `max` w) h - C.fill - when opt $ do - setLineWidth 1 - setSourceRGBA 0 0 0 0.7 - rectangle x y w h - stroke - -------------------------------------------------------------------------------- - -{-# INLINE draw_rectangle_outline #-} -draw_rectangle_outline :: (Integral x, Integral y, Integral w, Integral h) - => x -> y -> w -> h - -> Render () -draw_rectangle_outline x y w h = do - setLineWidth 2 - rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - stroke - -------------------------------------------------------------------------------- - -clearWhite :: Render () -clearWhite = do - save - setOperator OperatorSource - setSourceRGBA 0xffff 0xffff 0xffff 0xffff - paint - restore diff -Nru threadscope-0.1.3/debian/changelog threadscope-0.2.1/debian/changelog --- threadscope-0.1.3/debian/changelog 2011-05-28 15:01:14.000000000 +0000 +++ threadscope-0.2.1/debian/changelog 2012-03-13 19:14:19.000000000 +0000 @@ -1,3 +1,9 @@ +threadscope (0.2.1-1) unstable; urgency=low + + * New upstream release + + -- Joachim Breitner Tue, 13 Mar 2012 20:14:13 +0100 + threadscope (0.1.3-1) unstable; urgency=low * Team upload. diff -Nru threadscope-0.1.3/debian/control threadscope-0.2.1/debian/control --- threadscope-0.1.3/debian/control 2011-05-28 15:00:31.000000000 +0000 +++ threadscope-0.2.1/debian/control 2012-03-13 14:42:30.000000000 +0000 @@ -6,11 +6,13 @@ Build-Depends: debhelper (>= 7), cdbs, haskell-devscripts (>= 0.7), ghc, libghc-mtl-dev, - libghc-binary-dev, - libghc-ghc-events-dev, + libghc-ghc-events-dev (>= 0.4), + libghc-ghc-events-dev (<< 0.5), libghc-cairo-dev, - libghc-gtk-dev, - libghc-glade-dev + libghc-gtk-dev (>= 0.12), + libghc-cairo-dev, + libghc-glib-dev, + libghc-pango-dev Standards-Version: 3.9.2 Homepage: http://hackage.haskell.org/package/threadscope Vcs-Darcs: http://darcs.debian.org/pkg-haskell/haskell-threadscope diff -Nru threadscope-0.1.3/debian/rules threadscope-0.2.1/debian/rules --- threadscope-0.1.3/debian/rules 2011-05-28 14:27:18.000000000 +0000 +++ threadscope-0.2.1/debian/rules 2012-03-13 19:09:46.000000000 +0000 @@ -3,5 +3,12 @@ include /usr/share/cdbs/1/rules/debhelper.mk include /usr/share/cdbs/1/class/hlibrary.mk +DEB_SETUP_GHC_CONFIGURE_ARGS := --datasubdir=$(CABAL_PACKAGE) + build/$(CABAL_PACKAGE) :: build-ghc-stamp +install/$(CABAL_PACKAGE) :: build/$(CABAL_PACKAGE) + $(DEB_SETUP_BIN_NAME) copy --builddir=dist-ghc --destdir=debian/$(CABAL_PACKAGE) + rm -rf debian/threadscope/usr/share/doc + + diff -Nru threadscope-0.1.3/debian/threadscope.desktop threadscope-0.2.1/debian/threadscope.desktop --- threadscope-0.1.3/debian/threadscope.desktop 2011-05-28 14:57:36.000000000 +0000 +++ threadscope-0.2.1/debian/threadscope.desktop 2012-03-13 14:47:14.000000000 +0000 @@ -2,7 +2,7 @@ Version=1.0 Encoding=UTF-8 Name=threadscope -Icon=/usr/share/threadscope-0.1.3/threadscope.png +Icon=/usr/share/threadscope/threadscope.png Comment=Haskell GHC thread profiler Exec=/usr/bin/threadscope Terminal=false diff -Nru threadscope-0.1.3/debian/threadscope.install threadscope-0.2.1/debian/threadscope.install --- threadscope-0.1.3/debian/threadscope.install 2011-05-28 14:57:44.000000000 +0000 +++ threadscope-0.2.1/debian/threadscope.install 2012-03-13 14:47:03.000000000 +0000 @@ -1,5 +1,2 @@ -dist-ghc/build/threadscope/threadscope usr/bin/ -threadscope.glade usr/share/threadscope-0.1.3/ -threadscope.png usr/share/threadscope-0.1.3/ -debian/threadscope.xpm usr/share/threadscope-0.1.3/ +debian/threadscope.xpm usr/share/threadscope debian/threadscope.desktop usr/share/applications/ diff -Nru threadscope-0.1.3/debian/threadscope.menu threadscope-0.2.1/debian/threadscope.menu --- threadscope-0.1.3/debian/threadscope.menu 2011-05-28 14:57:52.000000000 +0000 +++ threadscope-0.2.1/debian/threadscope.menu 2012-03-13 14:47:21.000000000 +0000 @@ -3,4 +3,4 @@ longtitle="Haskell GHC thread profiler" \ description="Haskell GHC thread profiler tool." \ command="/usr/bin/threadscope" \ - icon="/usr/share/threadscope-0.1.3/threadscope.xpm" + icon="/usr/share/threadscope/threadscope.xpm" diff -Nru threadscope-0.1.3/EventDuration.hs threadscope-0.2.1/EventDuration.hs --- threadscope-0.1.3/EventDuration.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/EventDuration.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,176 +0,0 @@ --- This module supports a duration-based data-type to represent thread --- execution and GC information. - -module EventDuration ( - EventDuration(..), - isGCDuration, - startTimeOf, endTimeOf, durationOf, - eventsToDurations, - isDiscreteEvent - ) where - --- Imports for GHC Events -import qualified GHC.RTS.Events as GHC -import GHC.RTS.Events hiding (Event,GCWork,GCIdle) - -------------------------------------------------------------------------------- --- This datastructure is a duration-based representation of the event --- loginformation where thread-runs and GCs are explicitly represented --- by a single constructor identifying their start and end points. - -data EventDuration - = ThreadRun {-#UNPACK#-}!ThreadId - ThreadStopStatus - {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCStart {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCWork {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCIdle {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - - | GCEnd {-#UNPACK#-}!Timestamp - {-#UNPACK#-}!Timestamp - deriving Show - -{- - GCStart GCWork GCIdle GCEnd - gc start -----> work -----> idle ------+> done -----> gc end - | | - `-------<-------<-----' --} - -isGCDuration :: EventDuration -> Bool -isGCDuration GCStart{} = True -isGCDuration GCWork{} = True -isGCDuration GCIdle{} = True -isGCDuration GCEnd{} = True -isGCDuration _ = False - -------------------------------------------------------------------------------- --- The start time of an event. - -startTimeOf :: EventDuration -> Timestamp -startTimeOf ed - = case ed of - ThreadRun _ _ startTime _ -> startTime - GCStart startTime _ -> startTime - GCWork startTime _ -> startTime - GCIdle startTime _ -> startTime - GCEnd startTime _ -> startTime - -------------------------------------------------------------------------------- --- The emd time of an event. - -endTimeOf :: EventDuration -> Timestamp -endTimeOf ed - = case ed of - ThreadRun _ _ _ endTime -> endTime - GCStart _ endTime -> endTime - GCWork _ endTime -> endTime - GCIdle _ endTime -> endTime - GCEnd _ endTime -> endTime - -------------------------------------------------------------------------------- --- The duration of an EventDuration - -durationOf :: EventDuration -> Timestamp -durationOf ed = endTimeOf ed - startTimeOf ed - -------------------------------------------------------------------------------- - -eventsToDurations :: [GHC.Event] -> [EventDuration] -eventsToDurations [] = [] -eventsToDurations (event : events) = - case spec event of - RunThread{thread=t} -> runDuration t : rest - StopThread{} -> rest - StartGC -> gcStart (time event) events - EndGC{} -> rest - _otherEvent -> rest - where - rest = eventsToDurations events - - runDuration t = ThreadRun t s (time event) endTime - where (endTime, s) = case findRunThreadTime events of - Nothing -> error $ "findRunThreadTime for " ++ (show event) - Just x -> x - -isDiscreteEvent :: GHC.Event -> Bool -isDiscreteEvent e = - case spec e of - RunThread{} -> False - StopThread{} -> False - StartGC{} -> False - EndGC{} -> False - GHC.GCWork{} -> False - GHC.GCIdle{} -> False - GHC.GCDone{} -> False - _ -> True - -gcStart :: Timestamp -> [GHC.Event] -> [EventDuration] -gcStart t0 [] = [] -gcStart t0 (event : events) = - case spec event of - GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events - GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events - GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events - GHC.EndGC{} -> GCStart t0 t1 : eventsToDurations events - RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -gcWork :: Timestamp -> [GHC.Event] -> [EventDuration] -gcWork t0 [] = [] -gcWork t0 (event : events) = - case spec event of - GHC.GCWork{} -> gcWork t0 events - GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events - GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events - GHC.EndGC{} -> GCWork t0 t1 : eventsToDurations events - RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -gcIdle :: Timestamp -> [GHC.Event] -> [EventDuration] -gcIdle t0 [] = [] -gcIdle t0 (event : events) = - case spec event of - GHC.GCIdle{} -> gcIdle t0 events - GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events - GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events - GHC.EndGC{} -> GCIdle t0 t1 : eventsToDurations events - RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -gcDone :: Timestamp -> [GHC.Event] -> [EventDuration] -gcDone t0 [] = [] -gcDone t0 (event : events) = - case spec event of - GHC.GCDone{} -> gcDone t0 events - GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events - GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events - GHC.EndGC{} -> GCEnd t0 t1 : eventsToDurations events - RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events) - _other -> gcStart t0 events - where - t1 = time event - -------------------------------------------------------------------------------- - -findRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus) -findRunThreadTime [] = Nothing -findRunThreadTime (e : es) - = case spec e of - StopThread{status=s} -> Just (time e, s) - _ -> findRunThreadTime es - -------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/Events/EventDuration.hs threadscope-0.2.1/Events/EventDuration.hs --- threadscope-0.1.3/Events/EventDuration.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Events/EventDuration.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,177 @@ +-- This module supports a duration-based data-type to represent thread +-- execution and GC information. + +module Events.EventDuration ( + EventDuration(..), + isGCDuration, + startTimeOf, endTimeOf, durationOf, + eventsToDurations, + isDiscreteEvent + ) where + +-- Imports for GHC Events +import qualified GHC.RTS.Events as GHC +import GHC.RTS.Events hiding (Event,GCWork,GCIdle) + +------------------------------------------------------------------------------- +-- This datastructure is a duration-based representation of the event +-- loginformation where thread-runs and GCs are explicitly represented +-- by a single constructor identifying their start and end points. + +data EventDuration + = ThreadRun {-#UNPACK#-}!ThreadId + ThreadStopStatus + {-#UNPACK#-}!Timestamp + {-#UNPACK#-}!Timestamp + + | GCStart {-#UNPACK#-}!Timestamp + {-#UNPACK#-}!Timestamp + + | GCWork {-#UNPACK#-}!Timestamp + {-#UNPACK#-}!Timestamp + + | GCIdle {-#UNPACK#-}!Timestamp + {-#UNPACK#-}!Timestamp + + | GCEnd {-#UNPACK#-}!Timestamp + {-#UNPACK#-}!Timestamp + deriving Show + +{- + GCStart GCWork GCIdle GCEnd + gc start -----> work -----> idle ------+> done -----> gc end + | | + `-------<-------<-----' +-} + +isGCDuration :: EventDuration -> Bool +isGCDuration GCStart{} = True +isGCDuration GCWork{} = True +isGCDuration GCIdle{} = True +isGCDuration GCEnd{} = True +isGCDuration _ = False + +------------------------------------------------------------------------------- +-- The start time of an event. + +startTimeOf :: EventDuration -> Timestamp +startTimeOf ed + = case ed of + ThreadRun _ _ startTime _ -> startTime + GCStart startTime _ -> startTime + GCWork startTime _ -> startTime + GCIdle startTime _ -> startTime + GCEnd startTime _ -> startTime + +------------------------------------------------------------------------------- +-- The emd time of an event. + +endTimeOf :: EventDuration -> Timestamp +endTimeOf ed + = case ed of + ThreadRun _ _ _ endTime -> endTime + GCStart _ endTime -> endTime + GCWork _ endTime -> endTime + GCIdle _ endTime -> endTime + GCEnd _ endTime -> endTime + +------------------------------------------------------------------------------- +-- The duration of an EventDuration + +durationOf :: EventDuration -> Timestamp +durationOf ed = endTimeOf ed - startTimeOf ed + +------------------------------------------------------------------------------- + +eventsToDurations :: [GHC.Event] -> [EventDuration] +eventsToDurations [] = [] +eventsToDurations (event : events) = + case spec event of + RunThread{thread=t} -> runDuration t : rest + StopThread{} -> rest + StartGC -> gcStart (time event) events + EndGC{} -> rest + _otherEvent -> rest + where + rest = eventsToDurations events + + runDuration t = ThreadRun t s (time event) endTime + where (endTime, s) = case findRunThreadTime events of + Nothing -> error $ "findRunThreadTime for " ++ (show event) + Just x -> x + +isDiscreteEvent :: GHC.Event -> Bool +isDiscreteEvent e = + case spec e of + RunThread{} -> False + StopThread{} -> False + StartGC{} -> False + EndGC{} -> False + GHC.GCWork{} -> False + GHC.GCIdle{} -> False + GHC.GCDone{} -> False + GHC.SparkCounters{} -> False + _ -> True + +gcStart :: Timestamp -> [GHC.Event] -> [EventDuration] +gcStart _ [] = [] +gcStart t0 (event : events) = + case spec event of + GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events + GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events + GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events + GHC.EndGC{} -> GCStart t0 t1 : eventsToDurations events + RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events) + _other -> gcStart t0 events + where + t1 = time event + +gcWork :: Timestamp -> [GHC.Event] -> [EventDuration] +gcWork _ [] = [] +gcWork t0 (event : events) = + case spec event of + GHC.GCWork{} -> gcWork t0 events + GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events + GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events + GHC.EndGC{} -> GCWork t0 t1 : eventsToDurations events + RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events) + _other -> gcStart t0 events + where + t1 = time event + +gcIdle :: Timestamp -> [GHC.Event] -> [EventDuration] +gcIdle _ [] = [] +gcIdle t0 (event : events) = + case spec event of + GHC.GCIdle{} -> gcIdle t0 events + GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events + GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events + GHC.EndGC{} -> GCIdle t0 t1 : eventsToDurations events + RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events) + _other -> gcStart t0 events + where + t1 = time event + +gcDone :: Timestamp -> [GHC.Event] -> [EventDuration] +gcDone _ [] = [] +gcDone t0 (event : events) = + case spec event of + GHC.GCDone{} -> gcDone t0 events + GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events + GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events + GHC.EndGC{} -> GCEnd t0 t1 : eventsToDurations events + RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events) + _other -> gcStart t0 events + where + t1 = time event + +------------------------------------------------------------------------------- + +findRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus) +findRunThreadTime [] = Nothing +findRunThreadTime (e : es) + = case spec e of + StopThread{status=s} -> Just (time e, s) + _ -> findRunThreadTime es + +------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/Events/EventTree.hs threadscope-0.2.1/Events/EventTree.hs --- threadscope-0.1.3/Events/EventTree.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Events/EventTree.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,286 @@ +module Events.EventTree ( + DurationTree(..), + mkDurationTree, + + runTimeOf, gcTimeOf, + reportDurationTree, + durationTreeCountNodes, + durationTreeMaxDepth, + + EventTree(..), EventNode(..), + mkEventTree, + reportEventTree, eventTreeMaxDepth, + ) where + +import Events.EventDuration + +import qualified GHC.RTS.Events as GHC +import GHC.RTS.Events hiding (Event) + +import Text.Printf +import Control.Exception (assert) + +------------------------------------------------------------------------------- + +-- 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 rhs + = splitDurations es lhs_end + + | null lhs + = error $ + printf "splitDurations: null lhs: len = %d, startTime = %d, endTime = %d\n" + (length es) startTime endTime + ++ '\n': show es + + | otherwise + = -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $ + assert (length lhs + length rhs == length es) $ + 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 + -- Just one event left: put it on the right. This ensures that we + -- have at least one event on each side of the split. + = (reverse acc, tmax, [e]) +splitDurationList (e:es) acc !tsplit !tmax + | tstart <= tsplit -- pick all events that start at or 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 "splitEvents: null lhs: len = %d, startTime = %d, endTime = %d\n" + (length es) startTime endTime + ++ '\n': show es + + | otherwise + = -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $ + assert (length lhs + length rhs == length es) $ + EventSplit (time (head rhs)) + ltree + rtree + where + -- | Integer division, rounding up. + divUp :: Timestamp -> Timestamp -> Timestamp + divUp n k = (n + k - 1) `div` k + startTime = time (head es) + splitTime = startTime + (endTime - startTime) `divUp` 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] acc !_tsplit !tmax + -- Just one event left: put it on the right. This ensures that we + -- have at least one event on each side of the split. + = (reverse acc, tmax, [e]) +splitEventList (e:es) acc !tsplit !tmax + | t <= tsplit -- pick all events that start at or 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 -Nru threadscope-0.1.3/Events/HECs.hs threadscope-0.2.1/Events/HECs.hs --- threadscope-0.1.3/Events/HECs.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Events/HECs.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP #-} +module Events.HECs ( + HECs(..), + Event, + CapEvent, + Timestamp, + + eventIndexToTimestamp, + timestampToEventIndex, + extractUserMessages, + histogram, + histogramCounts, + ) where + +import Events.EventTree +import Events.SparkTree +import GHC.RTS.Events + +import Data.Array +import qualified Data.IntMap as IM +import qualified Data.List as L + +----------------------------------------------------------------------------- + +-- all the data from a .eventlog file +data HECs = HECs { + hecCount :: Int, + hecTrees :: [(DurationTree, EventTree, SparkTree)], + hecEventArray :: Array Int CapEvent, + hecLastEventTime :: Timestamp, + maxSparkPool :: Double, + minXHistogram :: Int, + maxXHistogram :: Int, + maxYHistogram :: Timestamp, + durHistogram :: [(Timestamp, Int, Timestamp)] + } + +----------------------------------------------------------------------------- + +eventIndexToTimestamp :: HECs -> Int -> Timestamp +eventIndexToTimestamp HECs{hecEventArray=arr} n = + time (ce_event (arr ! n)) + +timestampToEventIndex :: HECs -> Timestamp -> Int +timestampToEventIndex HECs{hecEventArray=arr} ts = + search l (r+1) + where + (l,r) = bounds arr + + search !l !r + | (r - l) <= 1 = if ts > time (ce_event (arr!l)) then r else l + | ts < tmid = search l mid + | otherwise = search mid r + where + mid = l + (r - l) `quot` 2 + tmid = time (ce_event (arr!mid)) + +extractUserMessages :: HECs -> [(Timestamp, String)] +extractUserMessages hecs = + [ (ts, msg) + | CapEvent _ (Event ts (UserMessage msg)) <- elems (hecEventArray hecs) ] + +-- | Sum durations in the same buckets to form a histogram. +histogram :: [(Int, Timestamp)] -> [(Int, Timestamp)] +histogram durs = IM.toList $ fromListWith' (+) durs + +-- | Sum durations and spark counts in the same buckets to form a histogram. +histogramCounts :: [(Int, (Timestamp, Int))] -> [(Int, (Timestamp, Int))] +histogramCounts durs = + let agg (dur1, count1) (dur2, count2) = + -- bangs needed to avoid stack overflow + let !dur = dur1 + dur2 + !count = count1 + count2 + in (dur, count) + in IM.toList $ fromListWith' agg durs + +fromListWith' :: (a -> a -> a) -> [(Int, a)] -> IM.IntMap a +fromListWith' f xs = + L.foldl' ins IM.empty xs + where +#if MIN_VERSION_containers(0,4,1) + ins t (k,x) = IM.insertWith' f k x t +#else + ins t (k,x) = + let r = IM.insertWith f k x t + v = r IM.! k + in v `seq` r +#endif diff -Nru threadscope-0.1.3/Events/ReadEvents.hs threadscope-0.2.1/Events/ReadEvents.hs --- threadscope-0.1.3/Events/ReadEvents.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Events/ReadEvents.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,223 @@ +module Events.ReadEvents ( + registerEventsFromFile, registerEventsFromTrace + ) where + +import Events.EventTree +import Events.SparkTree +import Events.HECs (HECs(..), histogram) +import Events.TestEvents +import Events.EventDuration +import qualified GUI.ProgressView as ProgressView +import GUI.ProgressView (ProgressView) + +import qualified GHC.RTS.Events as GHCEvents +import GHC.RTS.Events hiding (Event) + +import GHC.RTS.Events.Analysis +import GHC.RTS.Events.Analysis.SparkThread + +import Data.Array +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import Data.Maybe (catMaybes) +import Text.Printf +import System.FilePath +import Control.Monad +import Control.Exception +import qualified Control.DeepSeq as DeepSeq + +------------------------------------------------------------------------------- +-- The GHC.RTS.Events library returns the profile information +-- in a data-streucture which contains a list data structure +-- representing the events i.e. [GHCEvents.Event] +-- ThreadScope transforms this list into an alternative representation +-- which (for each HEC) records event *durations* which are ordered in time. +-- The durations represent the run-lengths for thread execution and +-- run-lengths for garbage colleciton. This data-structure is called +-- EventDuration. +-- ThreadScope then transformations this data-structure into another +-- data-structure which gives a binary-tree view of the event information +-- by performing a binary split on the time domain i.e. the EventTree +-- data structure. + +-- GHCEvents.Event => [EventDuration] => EventTree + +------------------------------------------------------------------------------- + +rawEventsToHECs :: [(Maybe Int, [GHCEvents.Event])] -> Timestamp + -> [(Double, (DurationTree, EventTree, SparkTree))] +rawEventsToHECs eventList endTime + = map (toTree . flip lookup heclists) + [0 .. maximum (minBound : map fst heclists)] + where + heclists = [ (h, events) | (Just h, events) <- eventList ] + + toTree Nothing = (0, (DurationTreeEmpty, + EventTree 0 0 (EventTreeLeaf []), + emptySparkTree)) + toTree (Just evs) = + (maxSparkPool, + (mkDurationTree (eventsToDurations nondiscrete) endTime, + mkEventTree discrete endTime, + mkSparkTree sparkD endTime)) + where (discrete, nondiscrete) = L.partition isDiscreteEvent evs + (maxSparkPool, sparkD) = eventsToSparkDurations nondiscrete + +------------------------------------------------------------------------------- + +registerEventsFromFile :: String -> ProgressView + -> IO (HECs, String, Int, Double) +registerEventsFromFile filename = registerEvents (Left filename) + +registerEventsFromTrace :: String -> ProgressView + -> IO (HECs, String, Int, Double) +registerEventsFromTrace traceName = registerEvents (Right traceName) + +registerEvents :: Either FilePath String + -> ProgressView + -> IO (HECs, String, Int, Double) + +registerEvents from progress = do + + let msg = case from of + Left filename -> filename + Right test -> test + + ProgressView.setTitle progress ("Loading " ++ takeFileName msg) + + buildEventLog progress from + +------------------------------------------------------------------------------- +-- Runs in a background thread +-- +buildEventLog :: ProgressView -> Either FilePath String + -> IO (HECs, String, Int, Double) +buildEventLog progress from = + case from of + Right test -> build test (testTrace test) + Left filename -> do + stopPulse <- ProgressView.startPulse progress + fmt <- readEventLogFromFile filename + stopPulse + case fmt of + Left err -> fail err --FIXME: report error properly + Right evs -> build filename evs + + where + -- | Integer division, rounding up. + divUp :: Timestamp -> Timestamp -> Timestamp + divUp n k = (n + k - 1) `div` k + build name evs = do + let + specBy1000 e@EventBlock{} = + e{end_time = end_time e `divUp` 1000, + block_events = map eBy1000 (block_events e)} + specBy1000 e = e + eBy1000 ev = ev{time = time ev `divUp` 1000, + spec = specBy1000 (spec ev)} + eventsBy = map eBy1000 (events (dat evs)) + eventBlockEnd e | EventBlock{ end_time=t } <- spec e = t + eventBlockEnd e = time e + + -- 1, to avoid graph scale 0 and division by 0 later on + lastTx = maximum (1 : map eventBlockEnd eventsBy) + + groups = groupEvents eventsBy + maxTrees = rawEventsToHECs groups lastTx + maxSparkPool = maximum (0 : map fst maxTrees) + trees = map snd maxTrees + + -- sort the events by time and put them in an array + sorted = sortGroups groups + n_events = length sorted + event_arr = listArray (0, n_events-1) sorted + hec_count = length trees + + -- Pre-calculate the data for the sparks histogram. + intDoub :: Integral a => a -> Double + intDoub = fromIntegral + -- Discretizes the data using log. + -- Log base 2 seems to result in 7--15 bars, which is OK visually. + -- Better would be 10--15 bars, but we want the base to be a small + -- integer, for readable scales, and we can't go below 2. + ilog :: Timestamp -> Int + ilog 0 = 0 + ilog x = floor $ logBase 2 (intDoub x) + + sparkProfile :: Process + ((Map ThreadId (Profile SparkThreadState), + (Map Int ThreadId, Set ThreadId)), + CapEvent) + (ThreadId, (SparkThreadState, Timestamp, Timestamp)) + sparkProfile = profileRouted + (refineM (spec . ce_event) sparkThreadMachine) + capabilitySparkThreadMachine + capabilitySparkThreadIndexer + (time . ce_event) + sorted + + sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp) + -> [(ThreadId, (SparkThreadState, Timestamp, Timestamp))] + -> [Maybe (Timestamp, Int, Timestamp)] + sparkSummary _ [] = [] + sparkSummary m ((threadId, (state, timeStarted', timeElapsed')):xs) = + case state of + SparkThreadRunning sparkId' -> case M.lookup threadId m of + Just (sparkId, timeStarted, timeElapsed) -> + if sparkId == sparkId' + then let value = (sparkId, timeStarted, timeElapsed + timeElapsed') + in sparkSummary (M.insert threadId value m) xs + else let times = (timeStarted, ilog timeElapsed, timeElapsed) + in Just times : newSummary sparkId' xs + Nothing -> newSummary sparkId' xs + _ -> sparkSummary m xs + where + newSummary sparkId = let value = (sparkId, timeStarted', timeElapsed') + in sparkSummary (M.insert threadId value m) + + allHisto :: [(Timestamp, Int, Timestamp)] + allHisto = catMaybes . sparkSummary M.empty . toList $ sparkProfile + + -- Sparks of zero lenght are already well visualized in other graphs: + durHistogram = filter (\ (_, logdur, _) -> logdur > 0) allHisto + -- Precompute some extremums of the maximal interval, needed for scales. + durs = [(logdur, dur) | (_start, logdur, dur) <- durHistogram] + (logDurs, sumDurs) = L.unzip (histogram durs) + minXHistogram = minimum (maxBound : logDurs) + maxXHistogram = maximum (minBound : logDurs) + maxY = maximum (minBound : sumDurs) + -- round up to multiples of 10ms + maxYHistogram = 10000 * ceiling (fromIntegral maxY / 10000) + + hecs = HECs { + hecCount = hec_count, + hecTrees = trees, + hecEventArray = event_arr, + hecLastEventTime = lastTx, + maxSparkPool = maxSparkPool, + minXHistogram = minXHistogram, + maxXHistogram = maxXHistogram, + maxYHistogram = maxYHistogram, + durHistogram = durHistogram + } + + treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO () + treeProgress hec (tree1, tree2, tree3) = do + ProgressView.setText progress $ + printf "Building HEC %d/%d" (hec+1) hec_count + ProgressView.setProgress progress hec_count hec + evaluate tree1 + evaluate (eventTreeMaxDepth tree2) + evaluate (sparkTreeMaxDepth tree3) + when (length trees == 1 || hec == 1) -- eval only with 2nd HEC + (return $! DeepSeq.rnf durHistogram) + + zipWithM_ treeProgress [0..] trees + ProgressView.setProgress progress hec_count hec_count + + --TODO: fully evaluate HECs before returning because othewise the last + -- bit of work gets done after the progress window has been closed. + + return (hecs, name, n_events, fromIntegral lastTx / 1000000) diff -Nru threadscope-0.1.3/Events/SparkStats.hs threadscope-0.2.1/Events/SparkStats.hs --- threadscope-0.1.3/Events/SparkStats.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Events/SparkStats.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,100 @@ +module Events.SparkStats + ( SparkStats(..) + , initial, create, rescale, aggregate, agEx + ) where + +import Data.Word (Word64) + +-- | Sparks change state. Each state transition process has a duration. +-- Spark statistics, for a given duration, record the spark transition rate +-- (the number of sparks that enter a given state within the interval) +-- and the absolute mean, maximal and minimal number of sparks +-- in the spark pool within the duration. +data SparkStats = + SparkStats { rateCreated, rateDud, rateOverflowed, + rateConverted, rateFizzled, rateGCd, + meanPool, maxPool, minPool :: {-# UNPACK #-}!Double } + deriving (Show, Eq) + +-- | Initial, default value of spark stats, at the start of runtime, +-- before any spark activity is recorded. +initial :: SparkStats +initial = SparkStats 0 0 0 0 0 0 0 0 0 + +-- | Create spark stats for a duration, given absolute +-- numbers of sparks in all categories at the start and end of the duration. +-- The units for spark transitions (first 6 counters) is [spark/duration]: +-- the fact that intervals may have different lenghts is ignored here. +-- The units for the pool stats are just [spark]. +-- The values in the second counter have to be greater or equal +-- to the values in the first counter, except for the spark pool size. +-- For pool size, we take into account only the first sample, +-- to visualize more detail at high zoom levels, at the cost +-- of a slight shift of the graph. Mathematically, this corresponds +-- to taking the initial durations as centered around samples, +-- but to have the same tree for rates and pool sizes, we then have +-- to shift the durations by half interval size to the right +-- (which would be neglectable if the interval was small and even). +create :: (Word64, Word64, Word64, Word64, Word64, Word64, Word64) + -> (Word64, Word64, Word64, Word64, Word64, Word64, Word64) + -> SparkStats +create (crt1, dud1, ovf1, cnv1, fiz1, gcd1, remaining1) + (crt2, dud2, ovf2, cnv2, fiz2, gcd2, _remaining2) = + let (crt, dud, ovf, cnv, fiz, gcd) = + (fromIntegral $ crt2 - crt1, + fromIntegral $ dud2 - dud1, + fromIntegral $ ovf2 - ovf1, + fromIntegral $ cnv2 - cnv1, + fromIntegral $ fiz2 - fiz1, + fromIntegral $ gcd2 - gcd1) + p = fromIntegral remaining1 + in SparkStats crt dud ovf cnv fiz gcd p p p + +-- | Reduce a list of spark stats; spark pool stats are overwritten. +foldStats :: (Double -> Double -> Double) + -> Double -> Double -> Double + -> [SparkStats] -> SparkStats +foldStats f meanP maxP minP l + = SparkStats + (foldr f 0 (map rateCreated l)) + (foldr f 0 (map rateDud l)) + (foldr f 0 (map rateOverflowed l)) + (foldr f 0 (map rateConverted l)) + (foldr f 0 (map rateFizzled l)) + (foldr f 0 (map rateGCd l)) + meanP maxP minP + +-- | Rescale the spark transition stats, e.g., to change their units. +rescale :: Double -> SparkStats -> SparkStats +rescale scale s = + let f w _ = scale * w + in foldStats f (meanPool s) (maxPool s) (minPool s) [s] + +-- | Derive spark stats for an interval from a list of spark stats, +-- in reverse chronological order, of consecutive subintervals +-- that sum up to the original interval. +aggregate :: [SparkStats] -> SparkStats +aggregate [] = error "aggregate" +aggregate [s] = s -- optimization +aggregate l = + let meanP = sum (map meanPool l) / fromIntegral (length l) -- TODO: inaccurate + maxP = maximum (map maxPool l) + minP = minimum (map minPool l) + in foldStats (+) meanP maxP minP l + +-- | Extrapolate spark stats from previous data. +-- Absolute pools size values extrapolate by staying constant, +-- rates of change of spark status extrapolate by dropping to 0 +-- (which corresponds to absolute numbers of sparks staying constant). +extrapolate :: SparkStats -> SparkStats +extrapolate s = + let f w _ = 0 * w + in foldStats f (meanPool s) (maxPool s) (minPool s) [s] + +-- | Aggregate, if any data provided. Extrapolate from previous data, otherwise. +-- In both cases, the second component is the new choice of "previous data". +-- The list of stats is expected in reverse chronological order, +-- as for aggregate. +agEx :: [SparkStats] -> SparkStats -> (SparkStats, SparkStats) +agEx [] s = (extrapolate s, s) +agEx l@(s:_) _ = (aggregate l, s) diff -Nru threadscope-0.1.3/Events/SparkTree.hs threadscope-0.2.1/Events/SparkTree.hs --- threadscope-0.1.3/Events/SparkTree.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Events/SparkTree.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,257 @@ +module Events.SparkTree ( + SparkTree, + sparkTreeMaxDepth, + emptySparkTree, + eventsToSparkDurations, + mkSparkTree, + sparkProfile, + ) where + +import qualified Events.SparkStats as SparkStats + +import qualified GHC.RTS.Events as GHCEvents +import GHC.RTS.Events (Timestamp) + +import Control.Exception (assert) +import Text.Printf +-- import Debug.Trace + +-- | Sparks change state. Each state transition process has a duration. +-- SparkDuration is a condensed description of such a process, +-- containing a start time of the duration interval, +-- spark stats that record the spark transition rate +-- and the absolute number of sparks in the spark pool within the duration. +data SparkDuration = + SparkDuration { startT :: {-#UNPACK#-}!Timestamp, + deltaC :: {-#UNPACK#-}!SparkStats.SparkStats } + deriving Show + +-- | Calculates durations and maximal rendered values from the event log. +-- Warning: cannot be applied to a suffix of the log (assumes start at time 0). +eventsToSparkDurations :: [GHCEvents.Event] -> (Double, [SparkDuration]) +eventsToSparkDurations es = + let aux _startTime _startCounters [] = (0, []) + aux startTime startCounters (event : events) = + case GHCEvents.spec event of + GHCEvents.SparkCounters crt dud ovf cnv fiz gcd rem -> + let endTime = GHCEvents.time event + endCounters = (crt, dud, ovf, cnv, fiz, gcd, rem) + delta = SparkStats.create startCounters endCounters + newMaxSparkPool = SparkStats.maxPool delta + sd = SparkDuration { startT = startTime, + deltaC = delta } + (oldMaxSparkPool, l) = + aux endTime endCounters events + in ( max oldMaxSparkPool newMaxSparkPool, + sd : l) + _otherEvent -> aux startTime startCounters events + in aux 0 (0,0,0,0,0,0,0) es + + +-- | We map the spark transition durations (intervals) onto a binary +-- search tree, so that we can easily find the durations +-- that correspond to a particular view of the timeline. +-- Additionally, each node of the tree contains a summary +-- of the information below it, so that we can render views at various +-- levels of resolution. For example, if a tree node would represent +-- less than one pixel on the display, there is no point is descending +-- the tree further. +data SparkTree + = SparkTree + {-#UNPACK#-}!Timestamp -- ^ start time of span represented by the tree + {-#UNPACK#-}!Timestamp -- ^ end time of the span represented by the tree + SparkNode + deriving Show + +data SparkNode + = SparkSplit + {-#UNPACK#-}!Timestamp -- ^ time used to split the span into two parts + SparkNode + -- ^ the LHS split; all data lies completely between start and split + SparkNode + -- ^ the RHS split; all data lies completely between split and end + {-#UNPACK#-}!SparkStats.SparkStats + -- ^ aggregate of the spark stats within the span + | SparkTreeLeaf + {-#UNPACK#-}!SparkStats.SparkStats + -- ^ the spark stats for the base duration + | SparkTreeEmpty + -- ^ represents a span that no data referts to, e.g., after the last GC + deriving Show + +sparkTreeMaxDepth :: SparkTree -> Int +sparkTreeMaxDepth (SparkTree _ _ t) = sparkNodeMaxDepth t + +sparkNodeMaxDepth :: SparkNode -> Int +sparkNodeMaxDepth (SparkSplit _ lhs rhs _) + = 1 + sparkNodeMaxDepth lhs `max` sparkNodeMaxDepth rhs +sparkNodeMaxDepth _ = 1 + +emptySparkTree :: SparkTree +emptySparkTree = SparkTree 0 0 SparkTreeEmpty + +-- | Create spark tree from spark durations. +-- Note that the last event may be not a spark event, in which case +-- there is no data about sparks for the last time interval +-- (the subtree for the interval will have SparkTreeEmpty node). +mkSparkTree :: [SparkDuration] -- ^ spark durations calculated from events + -> Timestamp -- ^ end time of last event in the list + -> SparkTree +mkSparkTree es endTime = + SparkTree s e $ + -- trace (show tree) $ + tree + where + tree = splitSparks es endTime + (s, e) = if null es then (0, 0) else (startT (head es), endTime) + +-- | Construct spark tree, by recursively splitting time intervals.. +-- We only split at spark transition duration boundaries; +-- we never split a duration into multiple pieces. +-- Therefore, the binary tree is only roughly split by time, +-- the actual split depends on the distribution of sample points below it. +splitSparks :: [SparkDuration] -> Timestamp -> SparkNode +splitSparks [] !_endTime = + SparkTreeEmpty + +splitSparks [e] !_endTime = + SparkTreeLeaf (deltaC e) + +splitSparks es !endTime + | null rhs + = splitSparks es lhs_end + | null lhs + = error $ + printf "splitSparks: null lhs: len = %d, startTime = %d, endTime = %d\n" + (length es) startTime endTime + ++ '\n' : show es + | otherwise + = -- trace (printf "len = %d, startTime = %d, endTime = %d\n" (length es) startTime endTime) $ + assert (length lhs + length rhs == length es) $ + SparkSplit (startT $ head rhs) + ltree + rtree + (SparkStats.aggregate (subDelta rtree ++ subDelta ltree)) + where + -- | Integer division, rounding up. + divUp :: Timestamp -> Timestamp -> Timestamp + divUp n k = (n + k - 1) `div` k + startTime = startT $ head es + splitTime = startTime + (endTime - startTime) `divUp` 2 + + (lhs, lhs_end, rhs) = splitSparkList es [] splitTime 0 + + ltree = splitSparks lhs lhs_end + rtree = splitSparks rhs endTime + + subDelta (SparkSplit _ _ _ delta) = [delta] + subDelta (SparkTreeLeaf delta) = [delta] + subDelta SparkTreeEmpty = [] + + +splitSparkList :: [SparkDuration] + -> [SparkDuration] + -> Timestamp + -> Timestamp + -> ([SparkDuration], Timestamp, [SparkDuration]) +splitSparkList [] acc !_tsplit !tmax + = (reverse acc, tmax, []) +splitSparkList [e] acc !_tsplit !tmax + -- Just one event left: put it on the right. This ensures that we + -- have at least one event on each side of the split. + = (reverse acc, tmax, [e]) +splitSparkList (e:es) acc !tsplit !tmax + | startT e <= tsplit -- pick all durations that start at or before the split + = splitSparkList es (e:acc) tsplit (max tmax (startT e)) + | otherwise + = (reverse acc, tmax, e:es) + + +-- | For each timeslice, give the spark stats calculated for that interval. +-- The spark stats are Approximated from the aggregated data +-- at the level of the spark tree covering intervals of the size +-- similar to the timeslice size. +sparkProfile :: Timestamp -> Timestamp -> Timestamp -> SparkTree + -> [SparkStats.SparkStats] +sparkProfile slice start0 end0 t + = {- trace (show flat) $ -} chopped + + where + -- do an extra slice at both ends + start = if start0 < slice then start0 else start0 - slice + end = end0 + slice + + flat = flatten start t [] + -- TODO: redefine chop so that it's obvious this error will not happen + -- e.g., catch pathological cases, like a tree with only SparkTreeEmpty + -- inside and/or make it tail-recursive instead of + -- taking the 'previous' argument + chopped0 = chop (error "Fatal error in sparkProfile.") [] start flat + + chopped | start0 < slice = SparkStats.initial : chopped0 + | otherwise = chopped0 + + flatten :: Timestamp -> SparkTree -> [SparkTree] -> [SparkTree] + flatten _start (SparkTree _s _e SparkTreeEmpty) rest = rest + flatten start t@(SparkTree s e (SparkSplit split l r _)) rest + | e <= start = rest + | end <= s = rest + | start >= split = flatten start (SparkTree split e r) rest + | end <= split = flatten start (SparkTree s split l) rest + | e - s > slice = flatten start (SparkTree s split l) $ + flatten start (SparkTree split e r) rest + -- A rule of thumb: if a node is narrower than slice, don't drill down, + -- even if the node sits astride slice boundaries and so the readings + -- for each of the two neigbouring slices will not be accurate + -- (but for the pair as a whole, they will be). Smooths the curve down + -- even more than averaging over the timeslice already does. + | otherwise = t : rest + flatten _start t@(SparkTree _s _e (SparkTreeLeaf _)) rest + = t : rest + + chop :: SparkStats.SparkStats -> [SparkStats.SparkStats] + -> Timestamp -> [SparkTree] -> [SparkStats.SparkStats] + chop _previous sofar start1 _ts + | start1 >= end + = case sofar of + _ : _ -> [SparkStats.aggregate sofar] + [] -> [] + chop _previous sofar _start1 [] -- data too short for the redrawn area + | null sofar -- no data at all in the redrawn area + = [] + | otherwise + = [SparkStats.aggregate sofar] + chop previous sofar start1 (t : ts) + | e <= start1 -- skipping data left of the slice + = case sofar of + _ : _ -> error "chop" + [] -> chop previous sofar start1 ts + | s >= start1 + slice -- postponing data right of the slice + = let (c, p) = SparkStats.agEx sofar previous + in c : chop p [] (start1 + slice) (t : ts) + | e > start1 + slice + = let (c, p) = SparkStats.agEx (created_in_this_slice t ++ sofar) previous + in c : chop p [] (start1 + slice) (t : ts) + | otherwise + = chop previous (created_in_this_slice t ++ sofar) start1 ts + where + (s, e) | SparkTree s e _ <- t = (s, e) + + -- The common part of the slice and the duration. + mi = min (start1 + slice) e + ma = max start1 s + common = if mi < ma then 0 else mi - ma + -- Instead of drilling down the tree (unless it's a leaf), + -- we approximate by taking a proportion of the aggregate value, + -- depending on how much of the spark duration corresponding + -- to the tree node is covered by our timeslice. + proportion = if e > s + then fromIntegral common / fromIntegral (e - s) + else assert (e == s && common == 0) $ 0 + + -- Spark transitions in the tree are in units spark/duration. + -- Here the numbers are rescaled so that the units are spark/ms. + created_in_this_slice (SparkTree _ _ node) = case node of + SparkTreeLeaf delta -> [SparkStats.rescale proportion delta] + SparkTreeEmpty -> [] + SparkSplit _ _ _ delta -> [SparkStats.rescale proportion delta] diff -Nru threadscope-0.1.3/Events/TestEvents.hs threadscope-0.2.1/Events/TestEvents.hs --- threadscope-0.1.3/Events/TestEvents.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Events/TestEvents.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,338 @@ +module Events.TestEvents (testTrace) +where + +import GHC.RTS.Events +import Data.Word + +------------------------------------------------------------------------------- + + +testTrace :: String -> EventLog +testTrace name = eventLog (test name) + +------------------------------------------------------------------------------- + +eventLog :: [Event] -> EventLog +eventLog events = + let specBy1000 e@EventBlock{} = + e{end_time = end_time e * 1000, + block_events = map eBy1000 (block_events e)} + specBy1000 e = e + eBy1000 ev = ev{time = time ev * 1000, + spec = specBy1000 (spec ev)} + eventsBy = map eBy1000 events + in EventLog (Header testEventTypes) (Data eventsBy) + +------------------------------------------------------------------------------- + +create :: Word16 +create = 0 + +------------------------------------------------------------------------------- + +runThread :: Word16 +runThread = 1 + +------------------------------------------------------------------------------- + +stop :: Word16 +stop = 2 + +------------------------------------------------------------------------------- + +runnable :: Word16 +runnable = 3 + +------------------------------------------------------------------------------- + +migrate :: Word16 +migrate = 4 + +------------------------------------------------------------------------------- + +runSpark :: Word16 +runSpark = 5 + +------------------------------------------------------------------------------- + +stealSpark :: Word16 +stealSpark = 6 + +------------------------------------------------------------------------------- + +shutdown :: Word16 +shutdown = 7 + +------------------------------------------------------------------------------- + +wakeup :: Word16 +wakeup = 8 + +------------------------------------------------------------------------------- + +startGC :: Word16 +startGC = 9 + +------------------------------------------------------------------------------ + +finishGC :: Word16 +finishGC = 10 + +------------------------------------------------------------------------------ + +reqSeqGC :: Word16 +reqSeqGC = 11 + +------------------------------------------------------------------------------ + +reqParGC :: Word16 +reqParGC = 12 + +------------------------------------------------------------------------------ + +createSparkThread :: Word16 +createSparkThread = 15 + +------------------------------------------------------------------------------ + +logMessage :: Word16 +logMessage = 16 + +------------------------------------------------------------------------------ + +startup :: Word16 +startup = 17 + +------------------------------------------------------------------------------ + +blockMarker :: Word16 +blockMarker = 18 + +------------------------------------------------------------------------------ + +testEventTypes :: [EventType] +testEventTypes + = [EventType create "Create thread" (Just 8), + EventType runThread "Run thread" (Just 8), + EventType stop "Stop thread" (Just 10), + EventType runnable "Thread runnable" (Just 8), + EventType migrate "Migrate thread" (Just 10), + EventType runSpark "Run spark" (Just 8), + EventType stealSpark "Steal spark" (Just 10), + EventType shutdown "Shutdown" (Just 0), + EventType wakeup "Wakeup thread" (Just 10), + EventType startGC "Start GC" (Just 0), + EventType finishGC "Finish GC" (Just 0), + EventType reqSeqGC "Request sequetial GC" (Just 0), + EventType reqParGC "Reqpargc parallel GC" (Just 0), + EventType createSparkThread "Create spark thread" (Just 8), + EventType logMessage "Log message" Nothing, + EventType startup "Startup" (Just 0), + EventType blockMarker "Block marker" (Just 14) + ] + +------------------------------------------------------------------------------- +test :: String -> [Event] +------------------------------------------------------------------------------- + +test "empty0" + = [ + Event 0 (Startup 1) + ] + +------------------------------------------------------------------------------- + + +test "empty1" + = [ + Event 0 (Startup 1), + Event 0 $ EventBlock 4000000 0 [] + ] + +------------------------------------------------------------------------------- + +test "test0" + = [ + Event 0 (Startup 1), + Event 0 $ EventBlock 4000000 0 [ + Event 4000000 Shutdown + ] + ] +------------------------------------------------------------------------------- + +test "small" + = [ + Event 0 (Startup 1), + Event 0 $ EventBlock 4000000 0 [ + Event 1000000 (CreateThread 1), + Event 2000000 (RunThread 1), + Event 3000000 (StopThread 1 ThreadFinished), + Event 4000000 (Shutdown) + ] + ] + +------------------------------------------------------------------------------- + +test "tick" + = [-- A thread from 2s to 3s + Event 0 (Startup 3), + Event 0 $ EventBlock 4000000000 0 [ + Event 1000000000 (CreateThread 1), + Event 2000000000 (RunThread 1), + Event 3000000000 (StopThread 1 ThreadFinished), + Event 4000000000 (Shutdown) + ], + -- A thread from 0.2ms to 0.3ms + Event 0 $ EventBlock 4000000000 1 [ + Event 1000000 (CreateThread 2), + Event 2000000 (RunThread 2), + Event 3000000 (StopThread 2 ThreadFinished), + Event 4000000 (Shutdown) + ], + -- A thread from 0.2us to 0.3us + Event 0 $ EventBlock 4000000000 2 [ + Event 1000 (CreateThread 3), + Event 2000 (RunThread 3), + Event 3000 (StopThread 3 ThreadFinished), + Event 4000 (Shutdown) + ] + ] + +------------------------------------------------------------------------------- + +test "tick2" + = [-- A thread create but no run + Event 0 (Startup 1), + Event 0 $ EventBlock 4000000000 0 [ + Event 1000000000 (CreateThread 1), + Event 4000000000 (Shutdown) + ] + ] + +------------------------------------------------------------------------------- + +test "tick3" + = [-- A thread from 2s to 3s + Event 0 (Startup 1), + Event 0 $ EventBlock 4000000000 0 [ + Event 1000000000 (CreateThread 1), + Event 2000000000 (RunThread 1), + Event 3000000000 (StopThread 1 ThreadFinished), + Event 4000000000 (Shutdown) + ] + ] + +------------------------------------------------------------------------------- + +test "tick4" + = [-- A test for scale values close to 1.0 + Event 0 (Startup 1), + Event 0 $ EventBlock 4000000000 0 [ + Event 100 (CreateThread 1), + Event 200 (RunThread 1), + Event 300 (StopThread 1 ThreadFinished), + Event 400 (Shutdown) + ] + ] + +------------------------------------------------------------------------------- + +test "tick5" + = [-- A thread from 2s to 3s + Event 0 (Startup 1), + Event 0 $ EventBlock 4000000000 0 [ + Event 1000000000 (CreateThread 1), + Event 2000000000 (RunThread 1), + Event 3000000000 (StopThread 1 ThreadFinished), + Event 4000000000 (Shutdown) + ] + ] + +------------------------------------------------------------------------------- +-- A long tick run to check small and large tick labels + +test "tick6" = chequered 2 100 10000000 + +------------------------------------------------------------------------------- + +test "overlap" + = [-- A thread from 2s to 3s + Event 0 (Startup 1), + Event 0 $ EventBlock 3000 0 [ + Event 1000 (CreateThread 1), + Event 1100 (RunThread 1), + Event 1200 (CreateThread 2), + Event 1300 (StopThread 1 ThreadFinished), + + Event 1400 (RunThread 2), + Event 1500 (CreateThread 3), + Event 1500 (CreateThread 4), + Event 1500 (StopThread 2 ThreadFinished), + + Event 1600 (RunThread 3), + Event 1600 (CreateThread 5), + Event 1600 (StopThread 3 ThreadFinished), + + Event 1700 (RunThread 4), + Event 1700 (CreateThread 6), + Event 1800 (StopThread 4 ThreadFinished), + + Event 3000 (Shutdown) + ] + ] + +------------------------------------------------------------------------------- +-- These tests are for chequered patterns to help check for rendering +-- problems and also to help test the performance of scrolling etc. +-- Each line has a fixed frequency of a thread running and then performing GC. +-- Each successive HEC runs thread at half the frequency of the previous HEC. + +test "ch1" = chequered 1 100 100000 +test "ch2" = chequered 2 100 100000 +test "ch3" = chequered 3 100 100000 +test "ch4" = chequered 4 100 100000 +test "ch5" = chequered 5 100 100000 +test "ch6" = chequered 6 100 100000 +test "ch7" = chequered 7 100 100000 +test "ch8" = chequered 8 100 100000 + + +------------------------------------------------------------------------------- + +test _ = [] + +------------------------------------------------------------------------------- + +chequered :: ThreadId -> Timestamp -> Timestamp -> [Event] +chequered numThreads basicDuration runLength + = Event 0 (Startup (fromIntegral numThreads)) : + makeChequered 1 numThreads basicDuration runLength + +------------------------------------------------------------------------------- + +makeChequered :: ThreadId -> ThreadId -> Timestamp -> Timestamp -> [Event] +makeChequered currentThread numThreads _basicDuration _runLength + | currentThread > numThreads = [] -- All threads rendered +makeChequered currentThread numThreads basicDuration runLength + = Event 0 eventBlock : + makeChequered (currentThread+1) numThreads (2*basicDuration) runLength + where + eventBlock :: EventInfo + eventBlock = EventBlock runLength (fromIntegral (currentThread-1)) + (Event 0 (CreateThread currentThread) + : chequeredPattern currentThread 0 basicDuration runLength) + +------------------------------------------------------------------------------- + +chequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event] +chequeredPattern currentThread currentPos basicDuration runLength + = if currentPos + 2*basicDuration > runLength then + [Event runLength (Shutdown)] + else + [Event currentPos (RunThread currentThread), + Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding), + Event (currentPos+basicDuration) StartGC, + Event (currentPos+2*basicDuration) EndGC + ] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength + +------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/EventsWindow.hs threadscope-0.2.1/EventsWindow.hs --- threadscope-0.1.3/EventsWindow.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/EventsWindow.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,269 +0,0 @@ -module EventsWindow ( - setupEventsWindow, - updateEventsWindow, - eventsWindowResize, - getCursorLine, - drawEvents - ) where - -import State -import ViewerColours -import Timeline - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.EventM -import Graphics.Rendering.Cairo - -import GHC.RTS.Events as GHC -import Graphics.UI.Gtk.ModelView as New - -import Control.Monad.Reader -import Data.Array -import Data.IORef -import Text.Printf - -------------------------------------------------------------------------------- - -setupEventsWindow :: ViewerState -> IO () -setupEventsWindow state@ViewerState{..} = do - - -- make the background white - widgetModifyBg eventsDrawingArea StateNormal (Color 0xffff 0xffff 0xffff) - - adj <- rangeGetAdjustment eventsVScrollbar - adjustmentSetLower adj 0 - adjustmentSetStepIncrement adj 4 - - widgetSetCanFocus eventsDrawingArea True - - on eventsDrawingArea configureEvent $ eventsWindowResize state - - on eventsDrawingArea exposeEvent $ updateEventsWindow state - - on eventsDrawingArea buttonPressEvent $ tryEvent $ do - button <- eventButton - (_,y) <- eventCoordinates - liftIO $ do - widgetGrabFocus eventsDrawingArea - setCursor state y - - on eventsDrawingArea focusInEvent $ liftIO $ do - f <- get eventsDrawingArea widgetHasFocus - when debug $ putStrLn ("focus in: " ++ show f) --- set eventsDrawingArea [widgetHasFocus := True] - return False - - on eventsDrawingArea focusOutEvent $ liftIO $ do - f <- get eventsDrawingArea widgetHasFocus - when debug $ putStrLn ("focus out: " ++ show f) --- set eventsDrawingArea [widgetHasFocus := False] - return False - - on eventsDrawingArea keyPressEvent $ do - key <- eventKeyName - when debug $ liftIO $ putStrLn ("key " ++ key) - return True - - on eventsDrawingArea scrollEvent $ do - dir <- eventScrollDirection - liftIO $ do - val <- adjustmentGetValue adj - step <- adjustmentGetStepIncrement adj - case dir of - ScrollUp -> adjustmentSetValue adj (val - step) - ScrollDown -> adjustmentSetValue adj (val + step) - _ -> return () - return True - - onValueChanged adj $ - widgetQueueDraw eventsDrawingArea - - onToolButtonClicked eventsFirstButton $ do - putStrLn "eventsFirstButton" - adjustmentSetValue adj 0 - - onToolButtonClicked eventsLastButton $ do - upper <- adjustmentGetUpper adj - adjustmentSetValue adj upper - - onToolButtonClicked eventsHomeButton $ do - cursorpos <- getCursorLine state - page <- adjustmentGetPageSize adj - adjustmentSetValue adj (fromIntegral (max 0 (cursorpos - round page `quot` 2))) - - - -- Button for adding the cursor position to the boomark list - onToolButtonClicked addBookmarkButton $ do - when debug $ putStrLn "Add bookmark\n" - cursorPos <- readIORef cursorIORef - New.listStoreAppend bookmarkStore cursorPos - queueRedrawTimelines state - - -- Button for deleting a bookmark - onToolButtonClicked deleteBookmarkButton $ do - when debug $ putStrLn "Delete bookmark\n" - sel <- treeViewGetSelection bookmarkTreeView - selection <- treeSelectionGetSelected sel - case selection of - Nothing -> return () - Just (TreeIter _ pos _ _) -> listStoreRemove bookmarkStore (fromIntegral pos) - queueRedrawTimelines state - - -- Button for jumping to bookmark - onToolButtonClicked gotoBookmarkButton $ do - sel <- treeViewGetSelection bookmarkTreeView - selection <- treeSelectionGetSelected sel - case selection of - Nothing -> return () - Just (TreeIter _ pos _ _) -> do - l <- listStoreToList bookmarkStore - when debug $ putStrLn ("gotoBookmark: " ++ show l++ " pos = " ++ show pos) - setCursorToTime state (l!!(fromIntegral pos)) - queueRedrawTimelines state - - exts <- withImageSurface FormatARGB32 0 0 $ \s -> renderWith s eventsFont - writeIORef eventsFontExtents exts - - return () - -------------------------------------------------------------------------------- - -eventsWindowResize :: ViewerState -> EventM EConfigure Bool -eventsWindowResize state@ViewerState{..} = liftIO $ do - (_,h) <- widgetGetSize eventsDrawingArea - win <- widgetGetDrawWindow eventsDrawingArea - exts <- readIORef eventsFontExtents - let page = fromIntegral (truncate (fromIntegral h / fontExtentsHeight exts)) - mb_hecs <- readIORef hecsIORef - case mb_hecs of - Nothing -> return True - Just hecs -> do - let arr = hecEventArray hecs - let (_, n_events) = bounds arr - adjustmentSetPageIncrement eventsAdj page - adjustmentSetPageSize eventsAdj page - adjustmentSetUpper eventsAdj (fromIntegral n_events + 1) - -- printf "eventsWindowResize: %f" page - return True - -------------------------------------------------------------------------------- - -updateEventsWindow :: ViewerState -> EventM EExpose Bool -updateEventsWindow state@ViewerState{..} = liftIO $ do - value <- adjustmentGetValue eventsAdj - mb_hecs <- readIORef hecsIORef - case mb_hecs of - Nothing -> return True - Just hecs -> do - let arr = hecEventArray hecs - win <- widgetGetDrawWindow eventsDrawingArea - (w,h) <- widgetGetSize eventsDrawingArea - - cursorpos <- getCursorLine state - when debug $ printf "cursorpos: %d\n" cursorpos - renderWithDrawable win $ do - drawEvents value arr w h cursorpos - return True - -------------------------------------------------------------------------------- - -getCursorLine :: ViewerState -> IO Int -getCursorLine state@ViewerState{..} = do - -- locate the cursor position as a line number - current_cursor <- readIORef cursorIORef - eventsCursor <- readIORef eventsCursorIORef - mb_hecs <- readIORef hecsIORef - case mb_hecs of - Nothing -> return 0 - Just hecs -> do - let arr = hecEventArray hecs - case eventsCursor of - Just (cursort, cursorpos) | cursort == current_cursor -> - return cursorpos - _other -> do - let cursorpos = locateCursor arr current_cursor - writeIORef eventsCursorIORef (Just (current_cursor, cursorpos)) - return cursorpos - -------------------------------------------------------------------------------- - -setCursor :: ViewerState -> Double -> IO () -setCursor state@ViewerState{..} eventY = do - val <- adjustmentGetValue eventsAdj - mb_hecs <- readIORef hecsIORef - case mb_hecs of - Nothing -> return () - Just hecs -> do - let arr = hecEventArray hecs - exts <- readIORef eventsFontExtents - let - line' = truncate (val + eventY / fontExtentsHeight exts) - arr_max = snd $ bounds arr - line = if line' > arr_max then arr_max else line' - t = time (ce_event (arr!line)) - -- - writeIORef cursorIORef t - writeIORef eventsCursorIORef (Just (t,line)) - widgetQueueDraw eventsDrawingArea - --- find the line that corresponds to the next event after the cursor -locateCursor :: Array Int GHC.CapEvent -> Timestamp -> Int -locateCursor arr cursor = search l (r+1) - where - (l,r) = bounds arr - - search !l !r - | (r - l) <= 1 = if cursor > time (ce_event (arr!l)) then r else l - | cursor < tmid = search l mid - | otherwise = search mid r - where - mid = l + (r - l) `quot` 2 - tmid = time (ce_event (arr!mid)) - -eventsFont :: Render FontExtents -eventsFont = do - selectFontFace "Monospace" FontSlantNormal FontWeightNormal - setFontSize 12 - fontExtents - -------------------------------------------------------------------------------- - -drawEvents :: Double -> Array Int GHC.CapEvent -> Int -> Int -> Int -> Render () -drawEvents value arr width height cursor = do - let val = truncate value :: Int - exts <- eventsFont - let h = fontExtentsHeight exts - (_, upper) = bounds arr - lines = ceiling (fromIntegral height / h) - end = min upper (val + lines) - - draw y ev = do moveTo 0 y; showText (ppEvent' ev) - - zipWithM_ draw [ h, h*2 .. ] [ arr ! n | n <- [ val .. end ] ] - - when (val <= cursor && cursor <= end) $ do - setLineWidth 3 - setOperator OperatorOver - setSourceRGBAhex blue 1.0 - let cursory = fromIntegral (cursor - val) * h + 3 - moveTo 0 cursory - lineTo (fromIntegral width) cursory - stroke - -------------------------------------------------------------------------------- - - -ppEvent' :: CapEvent -> String -ppEvent' (CapEvent cap (GHC.Event time spec)) = - printf "%9d: " time ++ - (case cap of - Nothing -> "" - Just c -> printf "cap %d: " c) ++ - case spec of - UnknownEvent{ ref=ref } -> - printf "unknown event; %d" ref - - Message msg -> msg - UserMessage msg -> msg - - _other -> showEventTypeSpecificInfo spec diff -Nru threadscope-0.1.3/EventTree.hs threadscope-0.2.1/EventTree.hs --- threadscope-0.1.3/EventTree.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/EventTree.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,272 +0,0 @@ -module EventTree ( - DurationTree(..), - mkDurationTree, - - runTimeOf, gcTimeOf, - reportDurationTree, - durationTreeCountNodes, - durationTreeMaxDepth, - - EventTree(..), EventNode(..), - mkEventTree, - reportEventTree, eventTreeMaxDepth, - ) where - -import EventDuration - -import qualified GHC.RTS.Events as GHC -import GHC.RTS.Events hiding (Event) - -import Data.List --- import Debug.Trace -import Text.Printf - -------------------------------------------------------------------------------- - --- We map the events onto a binary search tree, so that we can easily --- find the events that correspond to a particular view of the --- timeline. Additionally, each node of the tree contains a summary --- of the information below it, so that we can render views at various --- levels of resolution. For example, if a tree node would represent --- less than one pixel on the display, there is no point is descending --- the tree further. - --- We only split at event boundaries; we never split an event into --- multiple pieces. Therefore, the binary tree is only roughly split --- by time, the actual split depends on the distribution of events --- below it. - -data DurationTree - = DurationSplit - {-#UNPACK#-}!Timestamp -- The start time of this run-span - {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts - {-#UNPACK#-}!Timestamp -- The end time of this run-span - DurationTree -- The LHS split; all events lie completely between - -- start and split - DurationTree -- The RHS split; all events lie completely between - -- split and end - {-#UNPACK#-}!Timestamp -- The total amount of time spent running a thread - {-#UNPACK#-}!Timestamp -- The total amount of time spend in GC - - | DurationTreeLeaf - EventDuration - - | DurationTreeEmpty - - deriving Show - -------------------------------------------------------------------------------- - -mkDurationTree :: [EventDuration] -> Timestamp -> DurationTree -mkDurationTree es endTime = - -- trace (show tree) $ - tree - where - tree = splitDurations es endTime - -splitDurations :: [EventDuration] -- events - -> Timestamp -- end time of last event in the list - -> DurationTree -splitDurations [] _endTime = - -- if len /= 0 then error "splitDurations0" else - DurationTreeEmpty -- The case for an empty list of events - -splitDurations [e] _entTime = - DurationTreeLeaf e - -splitDurations es endTime - | null lhs || null rhs - = -- error (printf "failed to split: len = %d, startTime = %d, endTime = %d\n" (length es) startTime endTime ++ '\n': show es) - DurationTreeEmpty - - | otherwise - = -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $ - -- if len /= length es || length lhs + length rhs /= len then error (printf "splitDurations3; %d %d %d %d %d" len (length es) (length lhs) lhs_len (length rhs)) else - DurationSplit startTime - lhs_end - endTime - ltree - rtree - runTime - gcTime - where - startTime = startTimeOf (head es) - splitTime = startTime + (endTime - startTime) `div` 2 - - (lhs, lhs_end, rhs) = splitDurationList es [] splitTime 0 - - ltree = splitDurations lhs lhs_end - rtree = splitDurations rhs endTime - - runTime = runTimeOf ltree + runTimeOf rtree - gcTime = gcTimeOf ltree + gcTimeOf rtree - - -splitDurationList :: [EventDuration] - -> [EventDuration] - -> Timestamp - -> Timestamp - -> ([EventDuration], Timestamp, [EventDuration]) -splitDurationList [] acc !tsplit !tmax - = (reverse acc, tmax, []) -splitDurationList [e] acc !tsplit !tmax - = (reverse acc, tmax, [e]) - -- just one event left: put it on the right. This ensures that we - -- have at least one event on each side of the split. -splitDurationList (e:es) acc !tsplit !tmax - | tstart < tsplit -- pick all events that start before the split - = splitDurationList es (e:acc) tsplit (max tmax tend) - | otherwise - = (reverse acc, tmax, e:es) - where - tstart = startTimeOf e - tend = endTimeOf e - -------------------------------------------------------------------------------- - -runTimeOf :: DurationTree -> Timestamp -runTimeOf (DurationSplit _ _ _ _ _ runTime _) = runTime -runTimeOf (DurationTreeLeaf e) | ThreadRun{} <- e = durationOf e -runTimeOf _ = 0 - -------------------------------------------------------------------------------- - -gcTimeOf :: DurationTree -> Timestamp -gcTimeOf (DurationSplit _ _ _ _ _ _ gcTime) = gcTime -gcTimeOf (DurationTreeLeaf e) | isGCDuration e = durationOf e -gcTimeOf _ = 0 - -------------------------------------------------------------------------------- - -reportDurationTree :: Int -> DurationTree -> IO () -reportDurationTree hecNumber eventTree - = putStrLn ("HEC " ++ show hecNumber ++ reportText) - where - reportText = " nodes = " ++ show (durationTreeCountNodes eventTree) ++ - " max depth = " ++ show (durationTreeMaxDepth eventTree) - -------------------------------------------------------------------------------- - -durationTreeCountNodes :: DurationTree -> Int -durationTreeCountNodes (DurationSplit _ _ _ lhs rhs _ _) - = 1 + durationTreeCountNodes lhs + durationTreeCountNodes rhs -durationTreeCountNodes _ = 1 - -------------------------------------------------------------------------------- - -durationTreeMaxDepth :: DurationTree -> Int -durationTreeMaxDepth (DurationSplit _ _ _ lhs rhs _ _) - = 1 + durationTreeMaxDepth lhs `max` durationTreeMaxDepth rhs -durationTreeMaxDepth _ = 1 - -------------------------------------------------------------------------------- - -data EventTree - = EventTree - {-#UNPACK#-}!Timestamp -- The start time of this run-span - {-#UNPACK#-}!Timestamp -- The end time of this run-span - EventNode - -data EventNode - = EventSplit - {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts - EventNode -- The LHS split; all events lie completely between - -- start and split - EventNode -- The RHS split; all events lie completely between - -- split and end - - | EventTreeLeaf [GHC.Event] - -- sometimes events happen "simultaneously" (at the same time - -- given the resolution of our clock source), so we can't - -- separate them. - - | EventTreeOne GHC.Event - -- This is a space optimisation for the common case of - -- EventTreeLeaf [e]. - -mkEventTree :: [GHC.Event] -> Timestamp -> EventTree -mkEventTree es endTime = - EventTree s e $ - -- trace (show tree) $ - tree - where - tree = splitEvents es endTime - (s,e) = if null es then (0,0) else (time (head es), endTime) - -splitEvents :: [GHC.Event] -- events - -> Timestamp -- end time of last event in the list - -> EventNode -splitEvents [] !_endTime = - -- if len /= 0 then error "splitEvents0" else - EventTreeLeaf [] -- The case for an empty list of events - -splitEvents [e] !_endTime = - EventTreeOne e - -splitEvents es !endTime - | duration == 0 - = EventTreeLeaf es - - | null rhs - = splitEvents es lhs_end - - | null lhs - = error (printf "null lhs: len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" (length es) startTime endTime ++ '\n': show es) - - | otherwise - = -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $ - -- if len /= length es || length lhs + length rhs /= len then error (printf "splitEvents3; %d %d %d %d %d" len (length es) (length lhs) lhs_len (length rhs)) else - EventSplit (time (head rhs)) - ltree - rtree - where - startTime = time (head es) - splitTime = startTime + (endTime - startTime) `div` 2 - duration = endTime - startTime - - (lhs, lhs_end, rhs) = splitEventList es [] splitTime 0 - - ltree = splitEvents lhs lhs_end - rtree = splitEvents rhs endTime - - -splitEventList :: [GHC.Event] - -> [GHC.Event] - -> Timestamp - -> Timestamp - -> ([GHC.Event], Timestamp, [GHC.Event]) -splitEventList [] acc !tsplit !tmax - = (reverse acc, tmax, []) -splitEventList (e:es) acc !tsplit !tmax - | t < tsplit -- pick all events that start before the split - = splitEventList es (e:acc) tsplit (max tmax t) - | otherwise - = (reverse acc, tmax, e:es) - where - t = time e - -------------------------------------------------------------------------------- - -reportEventTree :: Int -> EventTree -> IO () -reportEventTree hecNumber (EventTree _ _ eventTree) - = putStrLn ("HEC " ++ show hecNumber ++ reportText) - where - reportText = " nodes = " ++ show (eventTreeCountNodes eventTree) ++ - " max depth = " ++ show (eventNodeMaxDepth eventTree) - -------------------------------------------------------------------------------- - -eventTreeCountNodes :: EventNode -> Int -eventTreeCountNodes (EventSplit _ lhs rhs) - = 1 + eventTreeCountNodes lhs + eventTreeCountNodes rhs -eventTreeCountNodes _ = 1 - -------------------------------------------------------------------------------- - -eventTreeMaxDepth :: EventTree -> Int -eventTreeMaxDepth (EventTree _ _ t) = eventNodeMaxDepth t - -eventNodeMaxDepth :: EventNode -> Int -eventNodeMaxDepth (EventSplit _ lhs rhs) - = 1 + eventNodeMaxDepth lhs `max` eventNodeMaxDepth rhs -eventNodeMaxDepth _ = 1 diff -Nru threadscope-0.1.3/FileDialog.hs threadscope-0.2.1/FileDialog.hs --- threadscope-0.1.3/FileDialog.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/FileDialog.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -------------------------------------------------------------------------------- ---- $Id: FileDialog.hs#1 2009/03/20 13:27:50 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/FileDialog.hs $ -------------------------------------------------------------------------------- - -module FileDialog -where - -import Graphics.UI.Gtk - -------------------------------------------------------------------------------- - -openFileDialog :: Window -> IO (Maybe String) -openFileDialog parentWindow - = do dialog <- fileChooserDialogNew - (Just "Open Profile... ") - (Just parentWindow) - FileChooserActionOpen - [("gtk-cancel", ResponseCancel) - ,("gtk-open", ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - widgetHide dialog - case response of - ResponseAccept -> fileChooserGetFilename dialog - _ -> return Nothing - -------------------------------------------------------------------------------- - diff -Nru threadscope-0.1.3/ghcrts.c threadscope-0.2.1/ghcrts.c --- threadscope-0.1.3/ghcrts.c 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/ghcrts.c 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -char *ghc_rts_opts="-I0"; diff -Nru threadscope-0.1.3/GUI/BookmarkView.hs threadscope-0.2.1/GUI/BookmarkView.hs --- threadscope-0.1.3/GUI/BookmarkView.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/BookmarkView.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,128 @@ +module GUI.BookmarkView ( + BookmarkView, + bookmarkViewNew, + BookmarkViewActions(..), + + bookmarkViewGet, + bookmarkViewAdd, + bookmarkViewRemove, + bookmarkViewClear, + bookmarkViewSetLabel, + ) where + +import GHC.RTS.Events (Timestamp) + +import Graphics.UI.Gtk +import Numeric + +--------------------------------------------------------------------------- + +-- | Abstract bookmark view object. +-- +data BookmarkView = BookmarkView { + bookmarkStore :: ListStore (Timestamp, String) + } + +-- | The actions to take in response to TraceView events. +-- +data BookmarkViewActions = BookmarkViewActions { + bookmarkViewAddBookmark :: IO (), + bookmarkViewRemoveBookmark :: Int -> IO (), + bookmarkViewGotoBookmark :: Timestamp -> IO (), + bookmarkViewEditLabel :: Int -> String -> IO () + } + +--------------------------------------------------------------------------- + +bookmarkViewAdd :: BookmarkView -> Timestamp -> String -> IO () +bookmarkViewAdd BookmarkView{bookmarkStore} ts label = do + listStoreAppend bookmarkStore (ts, label) + return () + +bookmarkViewRemove :: BookmarkView -> Int -> IO () +bookmarkViewRemove BookmarkView{bookmarkStore} n = do + listStoreRemove bookmarkStore n + return () + +bookmarkViewClear :: BookmarkView -> IO () +bookmarkViewClear BookmarkView{bookmarkStore} = + listStoreClear bookmarkStore + +bookmarkViewGet :: BookmarkView -> IO [(Timestamp, String)] +bookmarkViewGet BookmarkView{bookmarkStore} = + listStoreToList bookmarkStore + +bookmarkViewSetLabel :: BookmarkView -> Int -> String -> IO () +bookmarkViewSetLabel BookmarkView{bookmarkStore} n label = do + (ts,_) <- listStoreGetValue bookmarkStore n + listStoreSetValue bookmarkStore n (ts, label) + +--------------------------------------------------------------------------- + +bookmarkViewNew :: Builder -> BookmarkViewActions -> IO BookmarkView +bookmarkViewNew builder BookmarkViewActions{..} = do + + let getWidget cast name = builderGetObject builder cast name + + --------------------------------------------------------------------------- + + bookmarkTreeView <- getWidget castToTreeView "bookmark_list" + bookmarkStore <- listStoreNew [] + columnTs <- treeViewColumnNew + cellTs <- cellRendererTextNew + columnLabel <- treeViewColumnNew + cellLabel <- cellRendererTextNew + selection <- treeViewGetSelection bookmarkTreeView + + treeViewColumnSetTitle columnTs "Time" + treeViewColumnSetTitle columnLabel "Label" + treeViewColumnPackStart columnTs cellTs False + treeViewColumnPackStart columnLabel cellLabel True + treeViewAppendColumn bookmarkTreeView columnTs + treeViewAppendColumn bookmarkTreeView columnLabel + + treeViewSetModel bookmarkTreeView bookmarkStore + + cellLayoutSetAttributes columnTs cellTs bookmarkStore $ \(ts,_) -> + [ cellText := showFFloat (Just 6) (fromIntegral ts / 1000000) "s" ] + + cellLayoutSetAttributes columnLabel cellLabel bookmarkStore $ \(_,label) -> + [ cellText := label ] + + --------------------------------------------------------------------------- + + addBookmarkButton <- getWidget castToToolButton "add_bookmark_button" + deleteBookmarkButton <- getWidget castToToolButton "delete_bookmark" + gotoBookmarkButton <- getWidget castToToolButton "goto_bookmark_button" + + onToolButtonClicked addBookmarkButton $ + bookmarkViewAddBookmark + + onToolButtonClicked deleteBookmarkButton $ do + selected <- treeSelectionGetSelected selection + case selected of + Nothing -> return () + Just iter -> + let pos = listStoreIterToIndex iter + in bookmarkViewRemoveBookmark pos + + onToolButtonClicked gotoBookmarkButton $ do + selected <- treeSelectionGetSelected selection + case selected of + Nothing -> return () + Just iter -> do + let pos = listStoreIterToIndex iter + (ts,_) <- listStoreGetValue bookmarkStore pos + bookmarkViewGotoBookmark ts + + onRowActivated bookmarkTreeView $ \[pos] _ -> do + (ts, _) <- listStoreGetValue bookmarkStore pos + bookmarkViewGotoBookmark ts + + set cellLabel [ cellTextEditable := True ] + on cellLabel edited $ \[pos] val -> do + bookmarkViewEditLabel pos val + + --------------------------------------------------------------------------- + + return BookmarkView{..} diff -Nru threadscope-0.1.3/GUI/ConcurrencyControl.hs threadscope-0.2.1/GUI/ConcurrencyControl.hs --- threadscope-0.1.3/GUI/ConcurrencyControl.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/ConcurrencyControl.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,66 @@ + +module GUI.ConcurrencyControl ( + ConcurrencyControl, + start, + fullSpeed, + ) where + +import qualified System.Glib.MainLoop as Glib +import qualified Control.Concurrent as Concurrent +import qualified Control.Exception as Exception +import Control.Concurrent.MVar + + +newtype ConcurrencyControl = ConcurrencyControl (MVar (Int, Glib.HandlerId)) + +-- | Setup cooperative thread scheduling with Gtk+. +-- +start :: IO ConcurrencyControl +start = do + handlerId <- normalScheduling + return . ConcurrencyControl =<< newMVar (0, handlerId) + +-- | Run an expensive action that needs to use all the available CPU power. +-- +-- The normal cooperative GUI thread scheduling does not work so well in this +-- case so we use an alternative technique. We can't use this one all the time +-- however or we'd hog the CPU even when idle. +-- +fullSpeed :: ConcurrencyControl -> IO a -> IO a +fullSpeed (ConcurrencyControl handlerRef) = + Exception.bracket_ begin end + where + -- remove the normal scheduling handler and put in the full speed one + begin = do + (count, handlerId) <- takeMVar handlerRef + if count == 0 + -- nobody else is running fullSpeed + then do Glib.timeoutRemove handlerId + handlerId' <- fullSpeedScheduling + putMVar handlerRef (1, handlerId') + -- we're already running fullSpeed, just inc the count + else do putMVar handlerRef (count+1, handlerId) + + -- reinstate the normal scheduling + end = do + (count, handlerId) <- takeMVar handlerRef + if count == 1 + -- just us running fullSpeed so we clean up + then do Glib.timeoutRemove handlerId + handlerId' <- normalScheduling + putMVar handlerRef (0, handlerId') + -- someone else running fullSpeed, they're responsible for stopping + else do putMVar handlerRef (count-1, handlerId) + +normalScheduling :: IO Glib.HandlerId +normalScheduling = + Glib.timeoutAddFull + (Concurrent.yield >> return True) + Glib.priorityDefaultIdle 50 + --50ms, ie 20 times a second. + +fullSpeedScheduling :: IO Glib.HandlerId +fullSpeedScheduling = + Glib.idleAdd + (Concurrent.yield >> return True) + Glib.priorityDefaultIdle diff -Nru threadscope-0.1.3/GUI/Dialogs.hs threadscope-0.2.1/GUI/Dialogs.hs --- threadscope-0.1.3/GUI/Dialogs.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Dialogs.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,161 @@ +module GUI.Dialogs where + +import Paths_threadscope (getDataFileName, version) + +import Graphics.UI.Gtk + +import Data.Version (showVersion) +import System.FilePath + + +------------------------------------------------------------------------------- + +aboutDialog :: WindowClass window => window -> IO () +aboutDialog parent + = do dialog <- aboutDialogNew + logoPath <- getDataFileName "threadscope.png" + logo <- pixbufNewFromFile logoPath + set dialog [ + aboutDialogName := "ThreadScope", + aboutDialogVersion := showVersion version, + aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.", + aboutDialogComments := "A GHC eventlog profile viewer", + aboutDialogAuthors := ["Donnie Jones ", + "Simon Marlow ", + "Satnam Singh ", + "Duncan Coutts ", + "Mikolaj Konarski ", + "Nicolas Wu ", + "Eric Kow "], + aboutDialogLogo := Just logo, + aboutDialogWebsite := "http://www.haskell.org/haskellwiki/ThreadScope", + windowTransientFor := toWindow parent + ] + onResponse dialog $ \_ -> widgetDestroy dialog + widgetShow dialog + +------------------------------------------------------------------------------- + +openFileDialog :: WindowClass window => window -> (FilePath -> IO ()) -> IO () +openFileDialog parent open + = do dialog <- fileChooserDialogNew + (Just "Open Profile...") + (Just (toWindow parent)) + FileChooserActionOpen + [("gtk-cancel", ResponseCancel) + ,("gtk-open", ResponseAccept)] + set dialog [ + windowModal := True + ] + + eventlogfiles <- fileFilterNew + fileFilterSetName eventlogfiles "GHC eventlog files (*.eventlog)" + fileFilterAddPattern eventlogfiles "*.eventlog" + fileChooserAddFilter dialog eventlogfiles + + allfiles <- fileFilterNew + fileFilterSetName allfiles "All files" + fileFilterAddPattern allfiles "*" + fileChooserAddFilter dialog allfiles + + onResponse dialog $ \response -> do + case response of + ResponseAccept -> do + mfile <- fileChooserGetFilename dialog + case mfile of + Just file -> open file + Nothing -> return () + _ -> return () + widgetDestroy dialog + + widgetShowAll dialog + +------------------------------------------------------------------------------- + +data FileExportFormat = FormatPDF | FormatPNG + +exportFileDialog :: WindowClass window => window + -> FilePath + -> (FilePath -> FileExportFormat -> IO ()) + -> IO () +exportFileDialog parent oldfile save = do + dialog <- fileChooserDialogNew + (Just "Save timeline image...") + (Just (toWindow parent)) + FileChooserActionSave + [("gtk-cancel", ResponseCancel) + ,("gtk-save", ResponseAccept)] + set dialog [ + fileChooserDoOverwriteConfirmation := True, + windowModal := True + ] + + let (olddir, oldfilename) = splitFileName oldfile + fileChooserSetCurrentName dialog (replaceExtension oldfilename "png") + fileChooserSetCurrentFolder dialog olddir + + pngFiles <- fileFilterNew + fileFilterSetName pngFiles "PNG bitmap files" + fileFilterAddPattern pngFiles "*.png" + fileChooserAddFilter dialog pngFiles + + pdfFiles <- fileFilterNew + fileFilterSetName pdfFiles "PDF files" + fileFilterAddPattern pdfFiles "*.pdf" + fileChooserAddFilter dialog pdfFiles + + onResponse dialog $ \response -> + case response of + ResponseAccept -> do + mfile <- fileChooserGetFilename dialog + case mfile of + Just file + | takeExtension file == ".pdf" -> do + save file FormatPDF + widgetDestroy dialog + | takeExtension file == ".png" -> do + save file FormatPNG + widgetDestroy dialog + | otherwise -> + formatError dialog + Nothing -> widgetDestroy dialog + _ -> widgetDestroy dialog + + widgetShowAll dialog + where + formatError dialog = do + msg <- messageDialogNew (Just (toWindow dialog)) + [DialogModal, DialogDestroyWithParent] + MessageError ButtonsClose + "The file format is unknown or unsupported" + set msg [ + messageDialogSecondaryText := Just $ + "The PNG and PDF formats are supported. " + ++ "Please use a file extension of '.png' or '.pdf'." + ] + dialogRun msg + widgetDestroy msg + + + +------------------------------------------------------------------------------- + +errorMessageDialog :: WindowClass window => window -> String -> String -> IO () +errorMessageDialog parent headline explanation = do + + dialog <- messageDialogNew (Just (toWindow parent)) + [] MessageError ButtonsNone "" + + set dialog + [ windowModal := True + , windowTransientFor := toWindow parent + , messageDialogText := Just headline + , messageDialogSecondaryText := Just explanation + , windowResizable := True + ] + + dialogAddButton dialog "Close" ResponseClose + dialogSetDefaultResponse dialog ResponseClose + + onResponse dialog $ \_-> widgetDestroy dialog + widgetShowAll dialog diff -Nru threadscope-0.1.3/GUI/EventsView.hs threadscope-0.2.1/GUI/EventsView.hs --- threadscope-0.1.3/GUI/EventsView.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/EventsView.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,352 @@ +module GUI.EventsView ( + EventsView, + eventsViewNew, + EventsViewActions(..), + + eventsViewSetEvents, + + eventsViewGetCursor, + eventsViewSetCursor, + eventsViewScrollToLine, + ) where + +import GHC.RTS.Events + +import Graphics.UI.Gtk +import qualified GUI.GtkExtras as GtkExt + +import Control.Monad.Reader +import Data.Array +import Data.IORef +import Numeric + +------------------------------------------------------------------------------- + +data EventsView = EventsView { + drawArea :: !Widget, + adj :: !Adjustment, + stateRef :: !(IORef ViewState) + } + +data EventsViewActions = EventsViewActions { + eventsViewCursorChanged :: Int -> IO () + } + +data ViewState = ViewState { + lineHeight :: !Double, + eventsState :: !EventsState + } + +data EventsState + = EventsEmpty + | EventsLoaded { + cursorPos :: !Int, + mrange :: !(Maybe (Int, Int)), + eventsArr :: Array Int CapEvent + } + +------------------------------------------------------------------------------- + +eventsViewNew :: Builder -> EventsViewActions -> IO EventsView +eventsViewNew builder EventsViewActions{..} = do + + stateRef <- newIORef undefined + + let getWidget cast = builderGetObject builder cast + drawArea <- getWidget castToWidget "eventsDrawingArea" + vScrollbar <- getWidget castToVScrollbar "eventsVScroll" + adj <- get vScrollbar rangeAdjustment + + -- make the background white + widgetModifyBg drawArea StateNormal (Color 0xffff 0xffff 0xffff) + widgetSetCanFocus drawArea True + --TODO: needs to be reset on each style change ^^ + + ----------------------------------------------------------------------------- + -- Line height + + -- Calculate the height of each line based on the current font + let getLineHeight = do + pangoCtx <- widgetGetPangoContext drawArea + fontDesc <- contextGetFontDescription pangoCtx + metrics <- contextGetMetrics pangoCtx fontDesc emptyLanguage + return $ ascent metrics + descent metrics --TODO: padding? + + -- We cache the height of each line + initialLineHeight <- getLineHeight + -- but have to update it when the font changes + on drawArea styleSet $ \_ -> do + lineHeight' <- getLineHeight + modifyIORef stateRef $ \viewstate -> viewstate { lineHeight = lineHeight' } + + ----------------------------------------------------------------------------- + + writeIORef stateRef ViewState { + lineHeight = initialLineHeight, + eventsState = EventsEmpty + } + + let eventsView = EventsView {..} + + ----------------------------------------------------------------------------- + -- Drawing + + on drawArea exposeEvent $ liftIO $ do + drawEvents eventsView =<< readIORef stateRef + return True + + ----------------------------------------------------------------------------- + -- Key navigation + + on drawArea keyPressEvent $ do + let scroll by = liftIO $ do + ViewState{eventsState, lineHeight} <- readIORef stateRef + pagesize <- get adj adjustmentPageSize + let pagejump = max 1 (truncate (pagesize / lineHeight) - 1) + case eventsState of + EventsEmpty -> return () + EventsLoaded{cursorPos, eventsArr} -> + eventsViewCursorChanged cursorPos' + where + cursorPos' = clampBounds range (by pagejump end cursorPos) + range@(_,end) = bounds eventsArr + return True + + key <- eventKeyName + case key of + "Up" -> scroll (\_page _end pos -> pos-1) + "Down" -> scroll (\_page _end pos -> pos+1) + "Page_Up" -> scroll (\ page _end pos -> pos-page) + "Page_Down" -> scroll (\ page _end pos -> pos+page) + "Home" -> scroll (\_page _end _pos -> 0) + "End" -> scroll (\_page end _pos -> end) + "Left" -> return True + "Right" -> return True + _ -> return False + + ----------------------------------------------------------------------------- + -- Scrolling + + set adj [ adjustmentLower := 0 ] + + on drawArea sizeAllocate $ \_ -> + updateScrollAdjustment eventsView =<< readIORef stateRef + + let hitpointToLine :: ViewState -> Double -> Double -> Maybe Int + hitpointToLine ViewState{eventsState = EventsEmpty} _ _ = Nothing + hitpointToLine ViewState{eventsState = EventsLoaded{eventsArr}, lineHeight} + yOffset eventY + | hitLine > maxIndex = Nothing + | otherwise = Just hitLine + where + hitLine = truncate ((yOffset + eventY) / lineHeight) + maxIndex = snd (bounds eventsArr) + + on drawArea buttonPressEvent $ tryEvent $ do + (_,y) <- eventCoordinates + liftIO $ do + viewState <- readIORef stateRef + yOffset <- get adj adjustmentValue + widgetGrabFocus drawArea + case hitpointToLine viewState yOffset y of + Nothing -> return () + Just n -> eventsViewCursorChanged n + + on drawArea scrollEvent $ do + dir <- eventScrollDirection + liftIO $ do + val <- get adj adjustmentValue + upper <- get adj adjustmentUpper + pagesize <- get adj adjustmentPageSize + step <- get adj adjustmentStepIncrement + case dir of + ScrollUp -> set adj [ adjustmentValue := val - step ] + ScrollDown -> set adj [ adjustmentValue := min (val + step) + (upper - pagesize) ] + _ -> return () + return True + + onValueChanged adj $ + widgetQueueDraw drawArea + + ----------------------------------------------------------------------------- + + return eventsView + +------------------------------------------------------------------------------- + +eventsViewSetEvents :: EventsView -> Maybe (Array Int CapEvent) -> IO () +eventsViewSetEvents eventWin@EventsView{drawArea, stateRef} mevents = do + viewState <- readIORef stateRef + let eventsState' = case mevents of + Nothing -> EventsEmpty + Just events -> EventsLoaded { + cursorPos = 0, + mrange = Nothing, + eventsArr = events + } + viewState' = viewState { eventsState = eventsState' } + writeIORef stateRef viewState' + updateScrollAdjustment eventWin viewState' + widgetQueueDraw drawArea + +------------------------------------------------------------------------------- + +eventsViewGetCursor :: EventsView -> IO (Maybe Int) +eventsViewGetCursor EventsView{stateRef} = do + ViewState{eventsState} <- readIORef stateRef + case eventsState of + EventsEmpty -> return Nothing + EventsLoaded{cursorPos} -> return (Just cursorPos) + +eventsViewSetCursor :: EventsView -> Int -> Maybe (Int, Int) -> IO () +eventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n mrange = do + viewState@ViewState{eventsState} <- readIORef stateRef + case eventsState of + EventsEmpty -> return () + EventsLoaded{eventsArr} -> do + let n' = clampBounds (bounds eventsArr) n + writeIORef stateRef viewState { + eventsState = eventsState { cursorPos = n', mrange } + } + eventsViewScrollToLine eventsView n' + widgetQueueDraw drawArea + +eventsViewScrollToLine :: EventsView -> Int -> IO () +eventsViewScrollToLine EventsView{adj, stateRef} n = do + ViewState{lineHeight} <- readIORef stateRef + -- make sure that the range [n..n+1] is within the current page: + adjustmentClampPage adj + (fromIntegral n * lineHeight) + (fromIntegral (n+1) * lineHeight) + +------------------------------------------------------------------------------- + +updateScrollAdjustment :: EventsView -> ViewState -> IO () +updateScrollAdjustment EventsView{drawArea, adj} + ViewState{lineHeight, eventsState} = do + + (_,windowHeight) <- widgetGetSize drawArea + let numLines = case eventsState of + EventsEmpty -> 0 + EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1 + linesHeight = fromIntegral numLines * lineHeight + upper = max linesHeight (fromIntegral windowHeight) + pagesize = fromIntegral windowHeight + + set adj [ + adjustmentUpper := upper, + adjustmentPageSize := pagesize, + adjustmentStepIncrement := pagesize * 0.2, + adjustmentPageIncrement := pagesize * 0.9 + ] + val <- get adj adjustmentValue + when (val > upper - pagesize) $ + set adj [ adjustmentValue := max 0 (upper - pagesize) ] + +------------------------------------------------------------------------------- + +drawEvents :: EventsView -> ViewState -> IO () +drawEvents _ ViewState {eventsState = EventsEmpty} = return () +drawEvents EventsView{drawArea, adj} + ViewState {lineHeight, eventsState = EventsLoaded{..}} = do + + yOffset <- get adj adjustmentValue + pageSize <- get adj adjustmentPageSize + + -- calculate which lines are visible + let lower = truncate (yOffset / lineHeight) + upper = ceiling ((yOffset + pageSize) / lineHeight) + + -- the array indexes [begin..end] inclusive + -- are partially or fully visible + begin = lower + end = min upper (snd (bounds eventsArr)) + + win <- widgetGetDrawWindow drawArea + style <- get drawArea widgetStyle + focused <- get drawArea widgetIsFocus + let state | focused = StateSelected + | otherwise = StateActive + + pangoCtx <- widgetGetPangoContext drawArea + layout <- layoutEmpty pangoCtx + layoutSetEllipsize layout EllipsizeEnd + + (width,clipHeight) <- widgetGetSize drawArea + let clipRect = Rectangle 0 0 width clipHeight + + let -- With average char width, timeWidth is enough for 24 hours of logs + -- (way more than TS can handle, currently). Aligns nicely with + -- current timeline_yscale_area width, too. + -- TODO: take timeWidth from the yScaleDrawingArea width + -- TODO: perhaps make the timeWidth area grey, too? + -- TODO: perhaps limit scroll to the selected interval (perhaps not strictly, but only so that the interval area does not completely vanish from the visible area)? + timeWidth = 105 + columnGap = 20 + descrWidth = width - timeWidth - columnGap + + sequence_ + [ do when (inside || selected) $ + GtkExt.stylePaintFlatBox + style win + state1 ShadowNone + clipRect + drawArea "" + 0 (round y) width (round lineHeight) + + -- The event time + layoutSetText layout (showEventTime event) + layoutSetAlignment layout AlignRight + layoutSetWidth layout (Just (fromIntegral timeWidth)) + GtkExt.stylePaintLayout + style win + state2 True + clipRect + drawArea "" + 0 (round y) + layout + + -- The event description text + layoutSetText layout (showEventDescr event) + layoutSetAlignment layout AlignLeft + layoutSetWidth layout (Just (fromIntegral descrWidth)) + GtkExt.stylePaintLayout + style win + state2 True + clipRect + drawArea "" + (timeWidth + columnGap) (round y) + layout + + | n <- [begin..end] + , let y = fromIntegral n * lineHeight - yOffset + event = eventsArr ! n + inside = maybe False (\ (s, e) -> s <= n && n <= e) mrange + selected = cursorPos == n + (state1, state2) + | inside = (StatePrelight, StatePrelight) + | selected = (state, state) + | otherwise = (state, StateNormal) + ] + + where + showEventTime (CapEvent _cap (Event time _spec)) = + showFFloat (Just 6) (fromIntegral time / 1000000) "s" + showEventDescr (CapEvent cap (Event _time spec)) = + (case cap of + Nothing -> "" + Just c -> "HEC " ++ show c ++ ": ") + ++ case spec of + UnknownEvent{ref} -> "unknown event; " ++ show ref + Message msg -> msg + UserMessage msg -> msg + _ -> showEventInfo spec + +------------------------------------------------------------------------------- + +clampBounds :: Ord a => (a, a) -> a -> a +clampBounds (lower, upper) x + | x <= lower = lower + | x > upper = upper + | otherwise = x diff -Nru threadscope-0.1.3/GUI/GtkExtras.hs threadscope-0.2.1/GUI/GtkExtras.hs --- threadscope-0.1.3/GUI/GtkExtras.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/GtkExtras.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,99 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module GUI.GtkExtras where + +-- This is all stuff that should be bound in the gtk package but is not yet +-- (as of gtk-0.12.0) + +import Graphics.UI.GtkInternals +import Graphics.UI.Gtk (Rectangle) +import System.Glib.GError +import System.Glib.MainLoop +import Graphics.Rendering.Pango.Types +import Graphics.Rendering.Pango.BasicTypes +import Graphics.UI.Gtk.General.Enums (StateType, ShadowType) + +import Foreign +import Foreign.C +import Control.Monad +import Control.Concurrent.MVar + +waitGUI :: IO () +waitGUI = do + resultVar <- newEmptyMVar + idleAdd (putMVar resultVar () >> return False) priorityDefaultIdle + takeMVar resultVar + +------------------------------------------------------------------------------- + +stylePaintFlatBox :: WidgetClass widget + => Style + -> DrawWindow + -> StateType + -> ShadowType + -> Rectangle + -> widget + -> String + -> Int -> Int -> Int -> Int + -> IO () +stylePaintFlatBox style window stateType shadowType + clipRect widget detail x y width height = + with clipRect $ \rectPtr -> + withCString detail $ \detailPtr -> + (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 arg10 arg11 -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 -> gtk_paint_flat_box argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 arg10 arg11) + style + window + ((fromIntegral.fromEnum) stateType) + ((fromIntegral.fromEnum) shadowType) + (castPtr rectPtr) + (toWidget widget) + detailPtr + (fromIntegral x) (fromIntegral y) + (fromIntegral width) (fromIntegral height) + +stylePaintLayout :: WidgetClass widget + => Style + -> DrawWindow + -> StateType + -> Bool + -> Rectangle + -> widget + -> String + -> Int -> Int + -> PangoLayout + -> IO () +stylePaintLayout style window stateType useText + clipRect widget detail x y (PangoLayout _ layout) = + with clipRect $ \rectPtr -> + withCString detail $ \detailPtr -> + (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 (PangoLayoutRaw arg10) -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 ->withForeignPtr arg10 $ \argPtr10 -> gtk_paint_layout argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 argPtr10) + style + window + ((fromIntegral.fromEnum) stateType) + (fromBool useText) + (castPtr rectPtr) + (toWidget widget) + detailPtr + (fromIntegral x) (fromIntegral y) + layout + + +launchProgramForURI :: String -> IO Bool +launchProgramForURI uri = + propagateGError $ \errPtrPtr -> + withCString uri $ \uriStrPtr -> do + timestamp <- gtk_get_current_event_time + liftM toBool $ gtk_show_uri nullPtr uriStrPtr timestamp errPtrPtr + +------------------------------------------------------------------------------- + +foreign import ccall safe "gtk_paint_flat_box" + gtk_paint_flat_box :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> CInt -> CInt -> IO () + +foreign import ccall safe "gtk_paint_layout" + gtk_paint_layout :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> Ptr PangoLayoutRaw -> IO () + +foreign import ccall safe "gtk_show_uri" + gtk_show_uri :: Ptr Screen -> Ptr CChar -> CUInt -> Ptr (Ptr ()) -> IO CInt + +foreign import ccall unsafe "gtk_get_current_event_time" + gtk_get_current_event_time :: IO CUInt diff -Nru threadscope-0.1.3/GUI/Histogram.hs threadscope-0.2.1/GUI/Histogram.hs --- threadscope-0.1.3/GUI/Histogram.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Histogram.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,129 @@ +module GUI.Histogram ( + HistogramView, + histogramViewNew, + histogramViewSetHECs, + histogramViewSetInterval, + ) where + +import Events.HECs +import GUI.Timeline.Render (renderTraces, renderYScaleArea) +import GUI.Timeline.Render.Constants +import GUI.Types + +import Graphics.UI.Gtk +import qualified Graphics.Rendering.Cairo as C +import qualified GUI.GtkExtras as GtkExt + +import Data.IORef + +data HistogramView = + HistogramView + { hecsIORef :: IORef (Maybe HECs) + , mintervalIORef :: IORef (Maybe Interval) + , histogramDrawingArea :: DrawingArea + , histogramYScaleArea :: DrawingArea + } + +histogramViewSetHECs :: HistogramView -> Maybe HECs -> IO () +histogramViewSetHECs HistogramView{..} mhecs = do + writeIORef hecsIORef mhecs + widgetQueueDraw histogramDrawingArea + widgetQueueDraw histogramYScaleArea + +histogramViewSetInterval :: HistogramView -> Maybe Interval -> IO () +histogramViewSetInterval HistogramView{..} minterval = do + writeIORef mintervalIORef minterval + widgetQueueDraw histogramDrawingArea + widgetQueueDraw histogramYScaleArea + +histogramViewNew :: Builder -> IO HistogramView +histogramViewNew builder = do + let getWidget cast = builderGetObject builder cast + histogramDrawingArea <- getWidget castToDrawingArea "histogram_drawingarea" + histogramYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area2" + timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area" + + -- HACK: layoutSetAttributes does not work for \mu, so let's work around + fd <- fontDescriptionNew + fontDescriptionSetSize fd 8 + fontDescriptionSetFamily fd "sans serif" + widgetModifyFont histogramYScaleArea (Just fd) + + (_, xh) <- widgetGetSize timelineXScaleArea + let xScaleAreaHeight = fromIntegral xh + traces = [TraceHistogram] + paramsHist (w, h) minterval = ViewParameters + { width = w + , height = h + , viewTraces = traces + , hadjValue = 0 + , scaleValue = 1 + , maxSpkValue = undefined + , detail = undefined + , bwMode = undefined + , labelsMode = False + , histogramHeight = h - histXScaleHeight + , minterval = minterval + , xScaleAreaHeight = xScaleAreaHeight + } + + hecsIORef <- newIORef Nothing + mintervalIORef <- newIORef Nothing + + pangoCtx <- widgetGetPangoContext histogramDrawingArea + style <- get histogramDrawingArea widgetStyle + layout <- layoutEmpty pangoCtx + layoutSetMarkup layout $ "No detailed spark events in this eventlog.\n" + ++ "Re-run with +RTS -lf to generate them." + + -- Program the callback for the capability drawingArea + on histogramDrawingArea exposeEvent $ + C.liftIO $ do + maybeEventArray <- readIORef hecsIORef + win <- widgetGetDrawWindow histogramDrawingArea + (w, windowHeight) <- widgetGetSize histogramDrawingArea + case maybeEventArray of + Nothing -> return False + Just hecs + | null (durHistogram hecs) -> do + GtkExt.stylePaintLayout + style win + StateNormal True + (Rectangle 0 0 w windowHeight) + histogramDrawingArea "" + 4 20 + layout + return True + | otherwise -> do + minterval <- readIORef mintervalIORef + if windowHeight < 80 + then return False + else do + let size = (w, windowHeight - firstTraceY) + params = paramsHist size minterval + rect = Rectangle 0 0 w (snd size) + renderWithDrawable win $ + renderTraces params hecs rect + return True + + -- Redrawing histogramYScaleArea + histogramYScaleArea `onExpose` \_ -> do + maybeEventArray <- readIORef hecsIORef + case maybeEventArray of + Nothing -> return False + Just hecs + | null (durHistogram hecs) -> return False + | otherwise -> do + win <- widgetGetDrawWindow histogramYScaleArea + minterval <- readIORef mintervalIORef + (_, windowHeight) <- widgetGetSize histogramYScaleArea + if windowHeight < 80 + then return False + else do + let size = (undefined, windowHeight - firstTraceY) + params = paramsHist size minterval + renderWithDrawable win $ + renderYScaleArea params hecs histogramYScaleArea + return True + + return HistogramView{..} diff -Nru threadscope-0.1.3/GUI/KeyView.hs threadscope-0.2.1/GUI/KeyView.hs --- threadscope-0.1.3/GUI/KeyView.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/KeyView.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,169 @@ +module GUI.KeyView ( + KeyView, + keyViewNew, + ) where + +import GUI.ViewerColours +import GUI.Timeline.Render.Constants + +import Graphics.UI.Gtk +import qualified Graphics.Rendering.Cairo as C + + +--------------------------------------------------------------------------- + +-- | Abstract key view object. +-- +data KeyView = KeyView + +--------------------------------------------------------------------------- + +keyViewNew :: Builder -> IO KeyView +keyViewNew builder = do + + keyTreeView <- builderGetObject builder castToTreeView "key_list" + + dw <- widgetGetDrawWindow keyTreeView + keyEntries <- createKeyEntries dw keyData + + keyStore <- listStoreNew keyEntries + keyColumn <- treeViewColumnNew + imageCell <- cellRendererPixbufNew + labelCell <- cellRendererTextNew + + treeViewColumnPackStart keyColumn imageCell False + treeViewColumnPackStart keyColumn labelCell True + treeViewAppendColumn keyTreeView keyColumn + + selection <- treeViewGetSelection keyTreeView + treeSelectionSetMode selection SelectionNone + + let tooltipColumn = makeColumnIdString 0 + customStoreSetColumn keyStore tooltipColumn (\(_,tooltip,_) -> tooltip) + treeViewSetModel keyTreeView keyStore + + set keyTreeView [ treeViewTooltipColumn := tooltipColumn ] + + cellLayoutSetAttributes keyColumn imageCell keyStore $ \(_,_,img) -> + [ cellPixbuf := img ] + cellLayoutSetAttributes keyColumn labelCell keyStore $ \(label,_,_) -> + [ cellText := label ] + + --------------------------------------------------------------------------- + + return KeyView + +------------------------------------------------------------------------------- + +data KeyStyle = KDuration | KEvent | KEventAndGraph + +keyData :: [(String, KeyStyle, Color, String)] +keyData = + [ ("running", KDuration, runningColour, + "Indicates a period of time spent running Haskell code (not GC, not blocked/idle)") + , ("GC", KDuration, gcColour, + "Indicates a period of time spent by the RTS performing garbage collection (GC)") + , ("create thread", KEvent, createThreadColour, + "Indicates a new Haskell thread has been created") + , ("seq GC req", KEvent, seqGCReqColour, + "Indicates a HEC has requested to start a sequential GC") + , ("par GC req", KEvent, parGCReqColour, + "Indicates a HEC has requested to start a parallel GC") + , ("migrate thread", KEvent, migrateThreadColour, + "Indicates a Haskell thread has been moved from one HEC to another") + , ("thread wakeup", KEvent, threadWakeupColour, + "Indicates that a thread that was previously blocked (e.g. I/O, MVar etc) is now ready to run") + , ("shutdown", KEvent, shutdownColour, + "Indicates a HEC is terminating") + , ("user message", KEvent, userMessageColour, + "Indicates a message generated from Haskell code (via traceEvent)") + , ("create spark", KEventAndGraph, createdConvertedColour, + "As an event it indicates a use of `par` resulted in a spark being " ++ + "created (and added to the spark pool). In the spark creation " ++ + "graph the coloured area represents the number of sparks created.") + , ("dud spark", KEventAndGraph, fizzledDudsColour, + "As an event it indicates a use of `par` resulted in the spark being " ++ + "discarded because it was a 'dud' (already evaluated). In the spark " ++ + "creation graph the coloured area represents the number of dud sparks.") + , ("overflowed spark",KEventAndGraph, overflowedColour, + "As an event it indicates a use of `par` resulted in the spark being " ++ + "discarded because the spark pool was full. In the spark creation " ++ + "graph the coloured area represents the number of overflowed sparks.") + , ("run spark", KEventAndGraph, createdConvertedColour, + "As an event it indicates a spark has started to be run/evaluated. " ++ + "In the spark conversion graph the coloured area represents the number " ++ + "of sparks run.") + , ("fizzled spark", KEventAndGraph, fizzledDudsColour, + "As an event it indicates a spark has 'fizzled', meaning it has been " ++ + "discovered that the spark's thunk was evaluated by some other thread. " ++ + "In the spark conversion graph the coloured area represents the number " ++ + "of sparks that have fizzled.") + , ("GCed spark", KEventAndGraph, gcColour, + "As an event it indicates a spark has been GC'd, meaning it has been " ++ + "discovered that the spark's thunk was no longer needed anywhere. " ++ + "In the spark conversion graph the coloured area represents the number " ++ + "of sparks that were GC'd.") + ] + + +createKeyEntries :: DrawableClass dw + => dw + -> [(String, KeyStyle, Color,String)] + -> IO [(String, String, Pixbuf)] +createKeyEntries similar entries = + sequence + [ do pixbuf <- renderToPixbuf similar (50, hecBarHeight) $ do + C.setSourceRGB 1 1 1 + C.paint + renderKeyIcon style colour + return (label, tooltip, pixbuf) + + | (label, style, colour, tooltip) <- entries ] + +renderKeyIcon :: KeyStyle -> Color -> C.Render () +renderKeyIcon KDuration keyColour = do + setSourceRGBAhex keyColour 1.0 + let x = fromIntegral ox + C.rectangle (x - 2) 5 38 (fromIntegral (hecBarHeight `div` 2)) + C.fill +renderKeyIcon KEvent keyColour = renderKEvent keyColour +renderKeyIcon KEventAndGraph keyColour = do + renderKEvent keyColour + -- An icon roughly repreenting a jagedy graph. + let x = fromIntegral ox + y = fromIntegral hecBarHeight + C.moveTo (2*x) (y - 2) + C.relLineTo 3 (-6) + C.relLineTo 3 0 + C.relLineTo 3 3 + C.relLineTo 5 1 + C.relLineTo 1 (-(y - 4)) + C.relLineTo 2 (y - 4) + C.relLineTo 1 (-(y - 4)) + C.relLineTo 2 (y - 4) + C.lineTo (2*x+20) (y - 2) + C.fill + setSourceRGBAhex black 1.0 + C.setLineWidth 1.0 + C.moveTo (2*x-4) (y - 2.5) + C.lineTo (2*x+24) (y - 2.5) + C.stroke + +renderKEvent :: Color -> C.Render () +renderKEvent keyColour = do + setSourceRGBAhex keyColour 1.0 + C.setLineWidth 3.0 + let x = fromIntegral ox + C.moveTo x 0 + C.relLineTo 0 25 + C.stroke + +renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> C.Render () + -> IO Pixbuf +renderToPixbuf similar (w, h) draw = do + pixmap <- pixmapNew (Just similar) w h Nothing + renderWithDrawable pixmap draw + Just pixbuf <- pixbufGetFromDrawable pixmap (Rectangle 0 0 w h) + return pixbuf + +------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/GUI/Main.hs threadscope-0.2.1/GUI/Main.hs --- threadscope-0.1.3/GUI/Main.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Main.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,467 @@ +{-# LANGUAGE CPP #-} +module GUI.Main (runGUI) where + +-- Imports for GTK +import qualified Graphics.UI.Gtk as Gtk +import System.Glib.GError (failOnGError) + +-- Imports from Haskell library +import Text.Printf +import Control.Monad +#ifndef mingw32_HOST_OS +import System.Posix +#endif +import Control.Concurrent +import qualified Control.Concurrent.Chan as Chan +import Control.Exception +import Prelude hiding (catch) +import Data.Array +import Data.Maybe + +import Paths_threadscope + +-- Imports for ThreadScope +import qualified GUI.MainWindow as MainWindow +import GUI.Types +import Events.HECs hiding (Event) +import GUI.Dialogs +import Events.ReadEvents +import GUI.EventsView +import GUI.SummaryView +import GUI.StartupInfoView +import GUI.Histogram +import GUI.Timeline +import GUI.TraceView +import GUI.BookmarkView +import GUI.KeyView +import GUI.SaveAs +import qualified GUI.ConcurrencyControl as ConcurrencyControl +import qualified GUI.ProgressView as ProgressView +import qualified GUI.GtkExtras as GtkExtras + +------------------------------------------------------------------------------- + +data UIEnv = UIEnv { + + mainWin :: MainWindow.MainWindow, + eventsView :: EventsView, + startupView :: StartupInfoView, + summaryView :: InfoView, + histogramView :: HistogramView, + timelineWin :: TimelineView, + traceView :: TraceView, + bookmarkView :: BookmarkView, + keyView :: KeyView, + + eventQueue :: Chan Event, + concCtl :: ConcurrencyControl.ConcurrencyControl + } + +data EventlogState + = NoEventlogLoaded + | EventlogLoaded { + mfilename :: Maybe FilePath, --test traces have no filepath + hecs :: HECs, + selection :: TimeSelection, + cursorPos :: Int + } + +postEvent :: Chan Event -> Event -> IO () +postEvent = Chan.writeChan + +getEvent :: Chan Event -> IO Event +getEvent = Chan.readChan + +data Event + = EventOpenDialog + | EventExportDialog + | EventLaunchWebsite + | EventLaunchTutorial + | EventAboutDialog + | EventQuit + + | EventFileLoad FilePath + | EventTestLoad String + | EventFileReload + | EventFileExport FilePath FileExportFormat + +-- | EventStateClear + | EventSetState HECs (Maybe FilePath) String Int Double + + | EventShowSidebar Bool + | EventShowEvents Bool + + | EventTimelineJumpStart + | EventTimelineJumpEnd + | EventTimelineJumpCursor + | EventTimelineScrollLeft + | EventTimelineScrollRight + | EventTimelineZoomIn + | EventTimelineZoomOut + | EventTimelineZoomToFit + | EventTimelineLabelsMode Bool + | EventTimelineShowBW Bool + + | EventCursorChangedIndex Int + | EventCursorChangedSelection TimeSelection + + | EventTracesChanged [Trace] + + | EventBookmarkAdd + | EventBookmarkRemove Int + | EventBookmarkEdit Int String + + | EventUserError String SomeException + -- can add more specific ones if necessary + +constructUI :: IO UIEnv +constructUI = failOnGError $ do + + builder <- Gtk.builderNew + Gtk.builderAddFromFile builder =<< getDataFileName "threadscope.ui" + + eventQueue <- Chan.newChan + let post = postEvent eventQueue + + mainWin <- MainWindow.mainWindowNew builder MainWindow.MainWindowActions { + mainWinOpen = post EventOpenDialog, + mainWinExport = post EventExportDialog, + mainWinQuit = post EventQuit, + mainWinViewSidebar = post . EventShowSidebar, + mainWinViewEvents = post . EventShowEvents, + mainWinViewReload = post EventFileReload, + mainWinWebsite = post EventLaunchWebsite, + mainWinTutorial = post EventLaunchTutorial, + mainWinAbout = post EventAboutDialog, + mainWinJumpStart = post EventTimelineJumpStart, + mainWinJumpEnd = post EventTimelineJumpEnd, + mainWinJumpCursor = post EventTimelineJumpCursor, + mainWinScrollLeft = post EventTimelineScrollLeft, + mainWinScrollRight = post EventTimelineScrollRight, + mainWinJumpZoomIn = post EventTimelineZoomIn, + mainWinJumpZoomOut = post EventTimelineZoomOut, + mainWinJumpZoomFit = post EventTimelineZoomToFit, + mainWinDisplayLabels = post . EventTimelineLabelsMode, + mainWinViewBW = post . EventTimelineShowBW + } + + timelineWin <- timelineViewNew builder TimelineViewActions { + timelineViewSelectionChanged = post . EventCursorChangedSelection + } + + eventsView <- eventsViewNew builder EventsViewActions { + eventsViewCursorChanged = post . EventCursorChangedIndex + } + + startupView <- startupInfoViewNew builder + summaryView <- summaryViewNew builder + + histogramView <- histogramViewNew builder + + traceView <- traceViewNew builder TraceViewActions { + traceViewTracesChanged = post . EventTracesChanged + } + + bookmarkView <- bookmarkViewNew builder BookmarkViewActions { + bookmarkViewAddBookmark = post EventBookmarkAdd, + bookmarkViewRemoveBookmark = post . EventBookmarkRemove, + bookmarkViewGotoBookmark = \ts -> do + post (EventCursorChangedSelection (PointSelection ts)) + post EventTimelineJumpCursor, + bookmarkViewEditLabel = \n v -> post (EventBookmarkEdit n v) + } + + keyView <- keyViewNew builder + + concCtl <- ConcurrencyControl.start + + return UIEnv{..} + +------------------------------------------------------------------------------- + +data LoopDone = LoopDone + +eventLoop :: UIEnv -> EventlogState -> IO () +eventLoop uienv@UIEnv{..} eventlogState = do + + event <- getEvent eventQueue + next <- dispatch event eventlogState +#if __GLASGOW_HASKELL__ <= 612 + -- workaround for a wierd exception handling bug in ghc-6.12 + `catch` \e -> throwIO (e :: SomeException) +#endif + case next of + Left LoopDone -> return () + Right eventlogState' -> eventLoop uienv eventlogState' + + where + dispatch :: Event -> EventlogState -> IO (Either LoopDone EventlogState) + + dispatch EventQuit _ = return (Left LoopDone) + + dispatch EventOpenDialog _ = do + openFileDialog mainWin $ \filename -> + post (EventFileLoad filename) + continue + + dispatch (EventFileLoad filename) _ = do + async "loading the eventlog" $ + loadEvents (Just filename) (registerEventsFromFile filename) + --TODO: set state to be empty during loading + continue + + dispatch (EventTestLoad testname) _ = do + async "loading the test eventlog" $ + loadEvents Nothing (registerEventsFromTrace testname) + --TODO: set state to be empty during loading + continue + + dispatch EventFileReload EventlogLoaded{mfilename = Just filename} = do + async "reloading the eventlog" $ + loadEvents (Just filename) (registerEventsFromFile filename) + --TODO: set state to be empty during loading + continue + + dispatch EventFileReload EventlogLoaded{mfilename = Nothing} = + continue + +-- dispatch EventClearState _ + + dispatch (EventSetState hecs mfilename name nevents timespan) _ = do + + MainWindow.setFileLoaded mainWin (Just name) + MainWindow.setStatusMessage mainWin $ + printf "%s (%d events, %.3fs)" name nevents timespan + + let mevents = Just $ hecEventArray hecs + eventsViewSetEvents eventsView mevents + startupInfoViewSetEvents startupView mevents + summaryViewSetEvents summaryView mevents + histogramViewSetHECs histogramView (Just hecs) + traceViewSetHECs traceView hecs + traces' <- traceViewGetTraces traceView + timelineWindowSetHECs timelineWin (Just hecs) + timelineWindowSetTraces timelineWin traces' + + -- TODO: disabled for now, until it's configurable (see the TODO file) + -- We set user 'traceEvent' messages as initial bookmarks. + -- This is somewhat of an experiment. If users use lots of trace events + -- then it will not be appropriate and we'll want a separate 'traceMark'. + --let usrMsgs = extractUserMessages hecs + --sequence_ [ bookmarkViewAdd bookmarkView ts label + -- | (ts, label) <- usrMsgs ] + -- timelineWindowSetBookmarks timelineWin (map fst usrMsgs) + bookmarkViewClear bookmarkView + timelineWindowSetBookmarks timelineWin [] + + if nevents == 0 + then continueWith NoEventlogLoaded + else continueWith EventlogLoaded + { mfilename = mfilename + , hecs = hecs + , selection = PointSelection 0 + , cursorPos = 0 + } + + dispatch EventExportDialog + EventlogLoaded {mfilename} = do + exportFileDialog mainWin (fromMaybe "" mfilename) $ \filename' format -> + post (EventFileExport filename' format) + continue + + dispatch (EventFileExport filename format) + EventlogLoaded {hecs} = do + viewParams <- timelineGetViewParameters timelineWin + let viewParams' = viewParams { + detail = 1, + bwMode = False, + labelsMode = False + } + let yScaleArea = timelineGetYScaleArea timelineWin + case format of + FormatPDF -> + saveAsPDF filename hecs viewParams' yScaleArea + FormatPNG -> + saveAsPNG filename hecs viewParams' yScaleArea + continue + + dispatch EventLaunchWebsite _ = do + GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope" + continue + + dispatch EventLaunchTutorial _ = do + GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope_Tour" + continue + + dispatch EventAboutDialog _ = do + aboutDialog mainWin + continue + + dispatch (EventShowSidebar visible) _ = do + MainWindow.sidebarSetVisibility mainWin visible + continue + + dispatch (EventShowEvents visible) _ = do + MainWindow.eventsSetVisibility mainWin visible + continue + + dispatch EventTimelineJumpStart _ = do + timelineScrollToBeginning timelineWin + eventsViewScrollToLine eventsView 0 + continue + + dispatch EventTimelineJumpEnd EventlogLoaded{hecs} = do + timelineScrollToEnd timelineWin + let (_,end) = bounds (hecEventArray hecs) + eventsViewScrollToLine eventsView end + continue + + dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do + timelineCentreOnCursor timelineWin --TODO: pass selection here + eventsViewScrollToLine eventsView cursorPos + continue + + dispatch EventTimelineScrollLeft _ = do + timelineScrollLeft timelineWin + continue + + dispatch EventTimelineScrollRight _ = do + timelineScrollRight timelineWin + continue + dispatch EventTimelineZoomIn _ = do + timelineZoomIn timelineWin + continue + dispatch EventTimelineZoomOut _ = do + timelineZoomOut timelineWin + continue + dispatch EventTimelineZoomToFit _ = do + timelineZoomToFit timelineWin + continue + + dispatch (EventTimelineLabelsMode labelsMode) _ = do + timelineSetLabelsMode timelineWin labelsMode + continue + + dispatch (EventTimelineShowBW showBW) _ = do + timelineSetBWMode timelineWin showBW + continue + + dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do + let cursorTs' = eventIndexToTimestamp hecs cursorPos' + selection' = PointSelection cursorTs' + timelineSetSelection timelineWin selection' + eventsViewSetCursor eventsView cursorPos' Nothing + continueWith eventlogState { + selection = selection', + cursorPos = cursorPos' + } + + dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs')) + EventlogLoaded{hecs} = do + let cursorPos' = timestampToEventIndex hecs cursorTs' + timelineSetSelection timelineWin selection' + eventsViewSetCursor eventsView cursorPos' Nothing + histogramViewSetInterval histogramView Nothing + continueWith eventlogState { + selection = selection', + cursorPos = cursorPos' + } + + dispatch (EventCursorChangedSelection selection'@(RangeSelection start end)) + EventlogLoaded{hecs} = do + let cursorPos' = timestampToEventIndex hecs start + mrange = Just (cursorPos', timestampToEventIndex hecs end) + timelineSetSelection timelineWin selection' + eventsViewSetCursor eventsView cursorPos' mrange + histogramViewSetInterval histogramView (Just (start, end)) + continueWith eventlogState { + selection = selection', + cursorPos = cursorPos' + } + + dispatch (EventTracesChanged traces) _ = do + timelineWindowSetTraces timelineWin traces + continue + + dispatch EventBookmarkAdd EventlogLoaded{selection} = do + case selection of + PointSelection a -> bookmarkViewAdd bookmarkView a "" + RangeSelection a b -> do bookmarkViewAdd bookmarkView a "" + bookmarkViewAdd bookmarkView b "" + --TODO: should have a way to add/set a single bookmark for the timeline + -- rather than this hack where we ask the bookmark view for the whole lot. + ts <- bookmarkViewGet bookmarkView + timelineWindowSetBookmarks timelineWin (map fst ts) + continue + + dispatch (EventBookmarkRemove n) _ = do + bookmarkViewRemove bookmarkView n + --TODO: should have a way to add/set a single bookmark for the timeline + -- rather than this hack where we ask the bookmark view for the whole lot. + ts <- bookmarkViewGet bookmarkView + timelineWindowSetBookmarks timelineWin (map fst ts) + continue + + dispatch (EventBookmarkEdit n v) _ = do + bookmarkViewSetLabel bookmarkView n v + continue + + dispatch (EventUserError doing exception) _ = do + let headline = "There was a problem " ++ doing ++ "." + explanation = show exception + errorMessageDialog mainWin headline explanation + continue + + dispatch _ NoEventlogLoaded = continue + + loadEvents mfilename registerEvents = do + ConcurrencyControl.fullSpeed concCtl $ + ProgressView.withProgress mainWin $ \progress -> do + (hecs, name, nevents, timespan) <- registerEvents progress + -- This is a desperate hack to avoid the "segfault on reload" bug + -- http://trac.haskell.org/ThreadScope/ticket/1 + -- It should be enough to let other threads finish and so avoid + -- re-entering gtk C code (see ticket for the dirty details) + threadDelay 100000 -- 1/10th of a second + post (EventSetState hecs mfilename name nevents timespan) + return () + + async doing action = + forkIO (action `catch` \e -> post (EventUserError doing e)) + + post = postEvent eventQueue + continue = continueWith eventlogState + continueWith = return . Right + +------------------------------------------------------------------------------- + +runGUI :: Maybe (Either FilePath String) -> IO () +runGUI initialTrace = do + Gtk.initGUI + + uiEnv <- constructUI + + let post = postEvent (eventQueue uiEnv) + + case initialTrace of + Nothing -> return () + Just (Left filename) -> post (EventFileLoad filename) + Just (Right traceName) -> post (EventTestLoad traceName) + + doneVar <- newEmptyMVar + + forkIO $ do + res <- try $ eventLoop uiEnv NoEventlogLoaded + Gtk.mainQuit + putMVar doneVar (res :: Either SomeException ()) + +#ifndef mingw32_HOST_OS + installHandler sigINT (Catch $ post EventQuit) Nothing +#endif + + -- Enter Gtk+ main event loop. + Gtk.mainGUI + + -- Wait for child event loop to terminate + -- This lets us wait for any exceptions. + either throwIO return =<< takeMVar doneVar diff -Nru threadscope-0.1.3/GUI/MainWindow.hs threadscope-0.2.1/GUI/MainWindow.hs --- threadscope-0.1.3/GUI/MainWindow.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/MainWindow.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,202 @@ +module GUI.MainWindow ( + MainWindow, + mainWindowNew, + MainWindowActions(..), + + setFileLoaded, + setStatusMessage, + sidebarSetVisibility, + eventsSetVisibility, + + ) where + +import Paths_threadscope + +-- Imports for GTK +import Graphics.UI.Gtk as Gtk +import qualified System.Glib.GObject as Glib + + +------------------------------------------------------------------------------- + +data MainWindow = MainWindow { + mainWindow :: Window, + + sidebarBox, + eventsBox :: Widget, + + statusBar :: Statusbar, + statusBarCxt :: ContextId + } + +instance Glib.GObjectClass MainWindow where + toGObject = toGObject . mainWindow + unsafeCastGObject = error "cannot downcast to MainView type" + +instance Gtk.ObjectClass MainWindow +instance Gtk.WidgetClass MainWindow +instance Gtk.ContainerClass MainWindow +instance Gtk.BinClass MainWindow +instance Gtk.WindowClass MainWindow + +data MainWindowActions = MainWindowActions { + + -- Menu actions + mainWinOpen :: IO (), + mainWinExport :: IO (), + mainWinQuit :: IO (), + mainWinViewSidebar :: Bool -> IO (), + mainWinViewEvents :: Bool -> IO (), + mainWinViewBW :: Bool -> IO (), + mainWinViewReload :: IO (), + mainWinWebsite :: IO (), + mainWinTutorial :: IO (), + mainWinAbout :: IO (), + + -- Toolbar actions + mainWinJumpStart :: IO (), + mainWinJumpEnd :: IO (), + mainWinJumpCursor :: IO (), + mainWinJumpZoomIn :: IO (), + mainWinJumpZoomOut :: IO (), + mainWinJumpZoomFit :: IO (), + mainWinScrollLeft :: IO (), + mainWinScrollRight :: IO (), + mainWinDisplayLabels :: Bool -> IO () + } + +------------------------------------------------------------------------------- + +setFileLoaded :: MainWindow -> Maybe FilePath -> IO () +setFileLoaded mainWin Nothing = + set (mainWindow mainWin) [ + windowTitle := "ThreadScope" + ] +setFileLoaded mainWin (Just file) = + set (mainWindow mainWin) [ + windowTitle := file ++ " - ThreadScope" + ] + +setStatusMessage :: MainWindow -> String -> IO () +setStatusMessage mainWin msg = do + statusbarPop (statusBar mainWin) (statusBarCxt mainWin) + statusbarPush (statusBar mainWin) (statusBarCxt mainWin) (' ':msg) + return () + +sidebarSetVisibility :: MainWindow -> Bool -> IO () +sidebarSetVisibility mainWin visible = + set (sidebarBox mainWin) [ widgetVisible := visible ] + +eventsSetVisibility :: MainWindow -> Bool -> IO () +eventsSetVisibility mainWin visible = + set (eventsBox mainWin) [ widgetVisible := visible ] + +------------------------------------------------------------------------------- + +mainWindowNew :: Builder -> MainWindowActions -> IO MainWindow +mainWindowNew builder actions = do + + let getWidget cast name = builderGetObject builder cast name + + + mainWindow <- getWidget castToWindow "main_window" + statusBar <- getWidget castToStatusbar "statusbar" + + sidebarBox <- getWidget castToWidget "sidebar" + eventsBox <- getWidget castToWidget "eventsbox" + + bwToggle <- getWidget castToCheckMenuItem "black_and_white" +-- TODO: tie in the button and the menu toggle and then re-enable: + labModeToggle <- getWidget castToCheckMenuItem "view_labels_mode" + sidebarToggle <- getWidget castToCheckMenuItem "view_sidebar" + eventsToggle <- getWidget castToCheckMenuItem "view_events" + openMenuItem <- getWidget castToMenuItem "openMenuItem" + exportMenuItem <- getWidget castToMenuItem "exportMenuItem" + reloadMenuItem <- getWidget castToMenuItem "view_reload" + quitMenuItem <- getWidget castToMenuItem "quitMenuItem" + websiteMenuItem <- getWidget castToMenuItem "websiteMenuItem" + tutorialMenuItem <- getWidget castToMenuItem "tutorialMenuItem" + aboutMenuItem <- getWidget castToMenuItem "aboutMenuItem" + + firstMenuItem <- getWidget castToMenuItem "move_first" + centreMenuItem <- getWidget castToMenuItem "move_centre" + lastMenuItem <- getWidget castToMenuItem "move_last" + + zoomInMenuItem <- getWidget castToMenuItem "move_zoomin" + zoomOutMenuItem <- getWidget castToMenuItem "move_zoomout" + zoomFitMenuItem <- getWidget castToMenuItem "move_zoomfit" + + openButton <- getWidget castToToolButton "cpus_open" + + firstButton <- getWidget castToToolButton "cpus_first" + centreButton <- getWidget castToToolButton "cpus_centre" + lastButton <- getWidget castToToolButton "cpus_last" + + zoomInButton <- getWidget castToToolButton "cpus_zoomin" + zoomOutButton <- getWidget castToToolButton "cpus_zoomout" + zoomFitButton <- getWidget castToToolButton "cpus_zoomfit" + + --TODO: this is currently not used, but it'be nice if it were! + eventsTextEntry <- getWidget castToEntry "events_entry" + + ------------------------------------------------------------------------ + -- Show everything + widgetShowAll mainWindow + + widgetHide eventsTextEntry -- for now we hide it, see above. + + ------------------------------------------------------------------------ + + logoPath <- getDataFileName "threadscope.png" + windowSetIconFromFile mainWindow logoPath + + ------------------------------------------------------------------------ + -- Status bar functionality + + statusBarCxt <- statusbarGetContextId statusBar "file" + statusbarPush statusBar statusBarCxt "No eventlog loaded." + + ------------------------------------------------------------------------ + -- Bind all the events + + -- Menus + on openMenuItem menuItemActivate $ mainWinOpen actions + on exportMenuItem menuItemActivate $ mainWinExport actions + + on quitMenuItem menuItemActivate $ mainWinQuit actions + on mainWindow objectDestroy $ mainWinQuit actions + + on sidebarToggle checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle + >>= mainWinViewSidebar actions + on eventsToggle checkMenuItemToggled $ checkMenuItemGetActive eventsToggle + >>= mainWinViewEvents actions + on bwToggle checkMenuItemToggled $ checkMenuItemGetActive bwToggle + >>= mainWinViewBW actions + on labModeToggle checkMenuItemToggled $ checkMenuItemGetActive labModeToggle + >>= mainWinDisplayLabels actions + on reloadMenuItem menuItemActivate $ mainWinViewReload actions + + on websiteMenuItem menuItemActivate $ mainWinWebsite actions + on tutorialMenuItem menuItemActivate $ mainWinTutorial actions + on aboutMenuItem menuItemActivate $ mainWinAbout actions + + on firstMenuItem menuItemActivate $ mainWinJumpStart actions + on centreMenuItem menuItemActivate $ mainWinJumpCursor actions + on lastMenuItem menuItemActivate $ mainWinJumpEnd actions + + on zoomInMenuItem menuItemActivate $ mainWinJumpZoomIn actions + on zoomOutMenuItem menuItemActivate $ mainWinJumpZoomOut actions + on zoomFitMenuItem menuItemActivate $ mainWinJumpZoomFit actions + + -- Toolbar + onToolButtonClicked openButton $ mainWinOpen actions + + onToolButtonClicked firstButton $ mainWinJumpStart actions + onToolButtonClicked centreButton $ mainWinJumpCursor actions + onToolButtonClicked lastButton $ mainWinJumpEnd actions + + onToolButtonClicked zoomInButton $ mainWinJumpZoomIn actions + onToolButtonClicked zoomOutButton $ mainWinJumpZoomOut actions + onToolButtonClicked zoomFitButton $ mainWinJumpZoomFit actions + + return MainWindow {..} diff -Nru threadscope-0.1.3/GUI/ProgressView.hs threadscope-0.2.1/GUI/ProgressView.hs --- threadscope-0.1.3/GUI/ProgressView.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/ProgressView.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,123 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module GUI.ProgressView ( + ProgressView, + withProgress, + setText, + setTitle, + setProgress, + startPulse, + ) where + +import Graphics.UI.Gtk as Gtk +import GUI.GtkExtras +import Graphics.Rendering.Cairo + +import qualified Control.Concurrent as Concurrent +import Control.Exception +import Data.Typeable + +import Prelude hiding (catch) + + +data ProgressView = ProgressView { + progressWindow :: Gtk.Window, + progressLabel :: Gtk.Label, + progressBar :: Gtk.ProgressBar + } + +-- | Perform a long-running operation and display a progress window. The +-- operation has access to the progress window and it is expected to update it +-- using 'setText' and 'setProgress' +-- +-- The user may cancel the operation at any time. +-- +withProgress :: WindowClass win => win -> (ProgressView -> IO a) -> IO (Maybe a) +withProgress parent action = do + self <- Concurrent.myThreadId + let cancel = throwTo self OperationInterrupted + bracket (new parent cancel) close $ \progress -> + fmap Just (action progress) + `catch` \OperationInterrupted -> return Nothing + +data OperationInterrupted = OperationInterrupted + deriving (Typeable, Show) +instance Exception OperationInterrupted + +setText :: ProgressView -> String -> IO () +setText view msg = + set (progressBar view) [ + progressBarText := msg + ] + +setTitle :: ProgressView -> String -> IO () +setTitle view msg = do + set (progressWindow view) [ windowTitle := msg ] + set (progressLabel view) [ labelLabel := "" ++ msg ++ "" ] + +startPulse :: ProgressView -> IO (IO ()) +startPulse view = do + let pulse = do + progressBarPulse (progressBar view) + Concurrent.threadDelay 200000 + pulse + thread <- Concurrent.forkIO $ + pulse `catch` \OperationInterrupted -> return () + let stop = throwTo thread OperationInterrupted + waitGUI + return stop + +setProgress :: ProgressView -> Int -> Int -> IO () +setProgress view total current = do + let frac = fromIntegral current / fromIntegral total + set (progressBar view) [ progressBarFraction := frac ] + waitGUI + +close :: ProgressView -> IO () +close view = widgetDestroy (progressWindow view) + +new :: WindowClass win => win -> IO () -> IO ProgressView +new parent cancelAction = do + win <- windowNew + set win [ + containerBorderWidth := 10, + windowTitle := "", + windowTransientFor := toWindow parent, + windowModal := True, + windowWindowPosition := WinPosCenterOnParent, + windowDefaultWidth := 400, + windowSkipTaskbarHint := True + ] + + progText <- labelNew Nothing + set progText [ + miscXalign := 0, + labelUseMarkup := True + ] + + progress <- progressBarNew + + cancel <- buttonNewFromStock stockCancel + onClicked cancel (widgetDestroy win >> cancelAction) + onDelete win (\_ -> cancelAction >> return True) + on win keyPressEvent $ do + keyVal <- eventKeyVal + case keyVal of + 0xff1b -> liftIO $ cancelAction >> return True + _ -> return False + + vbox <- vBoxNew False 20 + hbox <- hBoxNew False 0 + boxPackStart vbox progText PackRepel 10 + boxPackStart vbox progress PackGrow 5 + boxPackStart vbox hbox PackNatural 5 + boxPackEnd hbox cancel PackNatural 0 + containerAdd win vbox + + widgetShowAll win + + return ProgressView { + progressWindow = win, + progressLabel = progText, + progressBar = progress + } diff -Nru threadscope-0.1.3/GUI/SaveAs.hs threadscope-0.2.1/GUI/SaveAs.hs --- threadscope-0.1.3/GUI/SaveAs.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/SaveAs.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,62 @@ +module GUI.SaveAs (saveAsPDF, saveAsPNG) where + +-- Imports for ThreadScope +import GUI.Timeline.Render (renderTraces, renderYScaleArea) +import GUI.Timeline.Render.Constants +import GUI.Timeline.Ticks (renderXScaleArea) +import GUI.Types +import Events.HECs + +-- Imports for GTK +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo + +saveAs :: HECs -> ViewParameters -> Double -> DrawingArea + -> (Int, Int, Render ()) +saveAs hecs params' @ViewParameters{xScaleAreaHeight, width, + height = oldHeight, histogramHeight} + yScaleAreaWidth yScaleArea = + let histTotalHeight = histogramHeight + histXScaleHeight + params@ViewParameters{height} = + params'{ viewTraces = viewTraces params' ++ [TraceHistogram] + , height = oldHeight + histTotalHeight + tracePad + } + w = ceiling yScaleAreaWidth + width + h = xScaleAreaHeight + height + drawTraces = renderTraces params hecs (Rectangle 0 0 width height) + drawXScale = renderXScaleArea params hecs + drawYScale = renderYScaleArea params hecs yScaleArea + -- Functions renderTraces and renderXScaleArea draw to the left of 0 + -- which is not seen in the normal mode, but would be seen in export, + -- so it has to be cleared before renderYScaleArea is written on top: + clearLeftArea = do + rectangle 0 0 yScaleAreaWidth (fromIntegral h) + op <- getOperator + setOperator OperatorClear + fill + setOperator op + drawAll = do + translate yScaleAreaWidth (fromIntegral xScaleAreaHeight) + drawTraces + translate 0 (- fromIntegral xScaleAreaHeight) + drawXScale + translate (-yScaleAreaWidth) 0 + clearLeftArea + translate 0 (fromIntegral xScaleAreaHeight) + drawYScale + in (w, h, drawAll) + +saveAsPDF :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO () +saveAsPDF filename hecs params yScaleArea = do + (xoffset, _) <- liftIO $ widgetGetSize yScaleArea + let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea + withPDFSurface filename (fromIntegral w') (fromIntegral h') $ \surface -> + renderWith surface drawAll + +saveAsPNG :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO () +saveAsPNG filename hecs params yScaleArea = do + (xoffset, _) <- liftIO $ widgetGetSize yScaleArea + let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea + withImageSurface FormatARGB32 w' h' $ \surface -> do + renderWith surface drawAll + surfaceWriteToPNG surface filename diff -Nru threadscope-0.1.3/GUI/StartupInfoView.hs threadscope-0.2.1/GUI/StartupInfoView.hs --- threadscope-0.1.3/GUI/StartupInfoView.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/StartupInfoView.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,145 @@ +module GUI.StartupInfoView ( + StartupInfoView, + startupInfoViewNew, + startupInfoViewSetEvents, + ) where + +import GHC.RTS.Events + +import Graphics.UI.Gtk + +import Data.Array +import Data.List +import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX + +------------------------------------------------------------------------------- + +data StartupInfoView = StartupInfoView + { labelProgName :: Label + , storeProgArgs :: ListStore String + , storeProgEnv :: ListStore (String, String) + , labelProgStartTime :: Label + , labelProgRtsId :: Label + } + +data StartupInfoState + = StartupInfoEmpty + | StartupInfoLoaded + { progName :: Maybe String + , progArgs :: Maybe [String] + , progEnv :: Maybe [(String, String)] + , progStartTime :: Maybe UTCTime + , progRtsId :: Maybe String + } + +------------------------------------------------------------------------------- + +startupInfoViewNew :: Builder -> IO StartupInfoView +startupInfoViewNew builder = do + + let getWidget cast = builderGetObject builder cast + + labelProgName <- getWidget castToLabel "labelProgName" + treeviewProgArgs <- getWidget castToTreeView "treeviewProgArguments" + treeviewProgEnv <- getWidget castToTreeView "treeviewProgEnvironment" + labelProgStartTime <- getWidget castToLabel "labelProgStartTime" + labelProgRtsId <- getWidget castToLabel "labelProgRtsIdentifier" + + storeProgArgs <- listStoreNew [] + columnArgs <- treeViewColumnNew + cellArgs <- cellRendererTextNew + + treeViewColumnPackStart columnArgs cellArgs True + treeViewAppendColumn treeviewProgArgs columnArgs + + treeViewSetModel treeviewProgArgs storeProgArgs + + set cellArgs [ cellTextEditable := True ] + cellLayoutSetAttributes columnArgs cellArgs storeProgArgs $ \arg -> + [ cellText := arg ] + + storeProgEnv <- listStoreNew [] + columnVar <- treeViewColumnNew + cellVar <- cellRendererTextNew + columnValue <- treeViewColumnNew + cellValue <- cellRendererTextNew + + treeViewColumnPackStart columnVar cellVar False + treeViewColumnPackStart columnValue cellValue True + treeViewAppendColumn treeviewProgEnv columnVar + treeViewAppendColumn treeviewProgEnv columnValue + + treeViewSetModel treeviewProgEnv storeProgEnv + + cellLayoutSetAttributes columnVar cellVar storeProgEnv $ \(var,_) -> + [ cellText := var ] + + set cellValue [ cellTextEditable := True ] + cellLayoutSetAttributes columnValue cellValue storeProgEnv $ \(_,value) -> + [ cellText := value ] + + let startupInfoView = StartupInfoView{..} + + return startupInfoView + +------------------------------------------------------------------------------- + +startupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int CapEvent) -> IO () +startupInfoViewSetEvents view mevents = + updateStartupInfo view (maybe StartupInfoEmpty processEvents mevents) + +--TODO: none of this handles the possibility of an eventlog containing multiple +-- OS processes. Note that the capset arg is ignored in the events below. + +processEvents :: Array Int CapEvent -> StartupInfoState +processEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing) + . take 1000 + . elems + where + accum info (CapEvent _ (Event _ (ProgramArgs _ (name:args)))) = + info { + progName = Just name, + progArgs = Just args + } + + accum info (CapEvent _ (Event _ (ProgramEnv _ env))) = + info { progEnv = Just (sort (parseEnv env)) } + + accum info (CapEvent _ (Event _ (RtsIdentifier _ rtsid))) = + info { progRtsId = Just rtsid } + + accum info (CapEvent _ (Event timestamp (WallClockTime _ sec nsec))) = + -- WallClockTime records the wall clock time of *this* event + -- which occurs some time after startup, so we can just subtract + -- the timestamp since that is the relative time since startup. + let wallTimePosix :: NominalDiffTime + wallTimePosix = fromIntegral sec + + (fromIntegral nsec / nanoseconds) + - (fromIntegral timestamp / nanoseconds) + nanoseconds = 1000000000 + wallTimeUTC = posixSecondsToUTCTime wallTimePosix + in info { progStartTime = Just wallTimeUTC } + + accum info _ = info + + -- convert ["foo=bar", ...] to [("foo", "bar"), ...] + parseEnv env = [ (var, value) | (var, '=':value) <- map (span (/='=')) env ] + +updateStartupInfo :: StartupInfoView -> StartupInfoState -> IO () +updateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do + set labelProgName [ labelText := fromMaybe "(unknown)" progName ] + set labelProgStartTime [ labelText := maybe "(unknown)" show progStartTime ] + set labelProgRtsId [ labelText := fromMaybe "(unknown)" progRtsId ] + listStoreClear storeProgArgs + mapM_ (listStoreAppend storeProgArgs) (fromMaybe [] progArgs) + listStoreClear storeProgEnv + mapM_ (listStoreAppend storeProgEnv) (fromMaybe [] progEnv) + +updateStartupInfo StartupInfoView{..} StartupInfoEmpty = do + set labelProgName [ labelText := "" ] + set labelProgStartTime [ labelText := "" ] + set labelProgRtsId [ labelText := "" ] + listStoreClear storeProgArgs + listStoreClear storeProgEnv diff -Nru threadscope-0.1.3/GUI/SummaryView.hs threadscope-0.2.1/GUI/SummaryView.hs --- threadscope-0.1.3/GUI/SummaryView.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/SummaryView.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,80 @@ +module GUI.SummaryView ( + InfoView, + summaryViewNew, + summaryViewSetEvents, + ) where + +import GHC.RTS.Events + +import GUI.Timeline.Render.Constants + +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo + +import Data.Array +import Data.IORef + +------------------------------------------------------------------------------- + +data InfoView = InfoView + { gtkLayout :: !Layout + , stateRef :: !(IORef InfoState) + } + +data InfoState + = InfoEmpty + | InfoLoaded + { infoState :: String + } + +------------------------------------------------------------------------------- + +infoViewNew :: String -> Builder -> IO InfoView +infoViewNew widgetName builder = do + + stateRef <- newIORef undefined + let getWidget cast = builderGetObject builder cast + gtkLayout <- getWidget castToLayout widgetName + writeIORef stateRef InfoEmpty + let infoView = InfoView{..} + + -- Drawing + on gtkLayout exposeEvent $ liftIO $ do + drawInfo infoView =<< readIORef stateRef + return True + + return infoView + +summaryViewNew :: Builder -> IO InfoView +summaryViewNew = infoViewNew "eventsLayoutSummary" + +------------------------------------------------------------------------------- + +infoViewSetEvents :: (Array Int CapEvent -> InfoState) + -> InfoView -> Maybe (Array Int CapEvent) -> IO () +infoViewSetEvents f InfoView{gtkLayout, stateRef} mevents = do + let infoState = case mevents of + Nothing -> InfoEmpty + Just events -> f events + writeIORef stateRef infoState + widgetQueueDraw gtkLayout + +summaryViewProcessEvents :: Array Int CapEvent -> InfoState +summaryViewProcessEvents _events = InfoLoaded "TODO" + +summaryViewSetEvents :: InfoView -> Maybe (Array Int CapEvent) -> IO () +summaryViewSetEvents = infoViewSetEvents summaryViewProcessEvents + +------------------------------------------------------------------------------- + +drawInfo :: InfoView -> InfoState -> IO () +drawInfo _ InfoEmpty = return () +drawInfo InfoView{gtkLayout} InfoLoaded{..} = do + win <- layoutGetDrawWindow gtkLayout + pangoCtx <- widgetGetPangoContext gtkLayout + layout <- layoutText pangoCtx infoState + (_, Rectangle _ _ width height) <- layoutGetPixelExtents layout + layoutSetSize gtkLayout (width + 30) (height + 30) + renderWithDrawable win $ do + moveTo (fromIntegral ox / 2) (fromIntegral ox / 3) + showLayout layout diff -Nru threadscope-0.1.3/GUI/Timeline/Activity.hs threadscope-0.2.1/GUI/Timeline/Activity.hs --- threadscope-0.1.3/GUI/Timeline/Activity.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/Activity.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,176 @@ +module GUI.Timeline.Activity ( + renderActivity + ) where + +import GUI.Timeline.Render.Constants + +import Events.HECs +import Events.EventTree +import Events.EventDuration +import GUI.Types +import GUI.ViewerColours + +import Graphics.Rendering.Cairo + +import Control.Monad +import Data.List + +-- ToDo: +-- - we average over the slice, but the point is drawn at the beginning +-- of the slice rather than in the middle. + +----------------------------------------------------------------------------- + +renderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp + -> Render () + +renderActivity ViewParameters{..} hecs start0 end0 = do + let + slice = ceiling (fromIntegral activity_detail * scaleValue) + + -- round the start time down, and the end time up, to a slice boundary + start = (start0 `div` slice) * slice + end = ((end0 + slice) `div` slice) * slice + + hec_profs = map (actProfile slice start end) + (map (\ (t, _, _) -> t) (hecTrees hecs)) + total_prof = map sum (transpose hec_profs) + +-- liftIO $ printf "%s\n" (show (map length hec_profs)) +-- liftIO $ printf "%s\n" (show (map (take 20) hec_profs)) + drawActivity hecs start end slice total_prof + (if not bwMode then runningColour else black) + +activity_detail :: Int +activity_detail = 4 -- in pixels + +-- for each timeslice, the amount of time spent in the mutator +-- during that period. +actProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp] +actProfile slice start0 end0 t + = {- trace (show flat) $ -} chopped + + where + -- do an extra slice at both ends + start = if start0 < slice then start0 else start0 - slice + end = end0 + slice + + flat = flatten start t [] + chopped0 = chop 0 start flat + + chopped | start0 < slice = 0 : chopped0 + | otherwise = chopped0 + + flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree] + flatten _start DurationTreeEmpty rest = rest + flatten start t@(DurationSplit s split e l r _run _) rest + | e <= start = rest + | end <= s = rest + | start >= split = flatten start r rest + | end <= split = flatten start l rest + | e - s > slice = flatten start l $ flatten start r rest + | otherwise = t : rest + flatten _start t@(DurationTreeLeaf _) rest + = t : rest + + chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp] + chop sofar start _ts + | start >= end = if sofar > 0 then [sofar] else [] + chop sofar start [] + = sofar : chop 0 (start+slice) [] + chop sofar start (t : ts) + | e <= start + = if sofar /= 0 + then error "chop" + else chop sofar start ts + | s >= start + slice + = sofar : chop 0 (start + slice) (t : ts) + | e > start + slice + = (sofar + time_in_this_slice t) : chop 0 (start + slice) (t : ts) + | otherwise + = chop (sofar + time_in_this_slice t) start ts + where + (s, e) + | DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev) + | DurationSplit s _ e _ _ _run _ <- t = (s, e) + + mi = min (start + slice) e + ma = max start s + duration = if mi < ma then 0 else mi - ma + + time_in_this_slice t = case t of + DurationTreeLeaf ThreadRun{} -> duration + DurationTreeLeaf _ -> 0 + DurationSplit _ _ _ _ _ run _ -> + round (fromIntegral (run * duration) / fromIntegral (e-s)) + DurationTreeEmpty -> error "time_in_this_slice" + +drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp] + -> Color + -> Render () +drawActivity hecs start end slice ts color = 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 + setLineWidth 1 + strokePreserve + + lineTo dend dheight + lineTo dstart dheight + setSourceRGBAhex color 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) + +-- | Draw a dashed line along the current path. +dashedLine1 :: Render () +dashedLine1 = do + save + identityMatrix + let dash = fromIntegral ox + setDash [dash, dash] 0.0 + setLineWidth 1 + stroke + restore diff -Nru threadscope-0.1.3/GUI/Timeline/CairoDrawing.hs threadscope-0.2.1/GUI/Timeline/CairoDrawing.hs --- threadscope-0.1.3/GUI/Timeline/CairoDrawing.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/CairoDrawing.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------- +--- $Id: CairoDrawing.hs#3 2009/07/18 22:48:30 REDMOND\\satnams $ +--- $Source: //depot/satnams/haskell/ThreadScope/CairoDrawing.hs $ +------------------------------------------------------------------------------- + +module GUI.Timeline.CairoDrawing +where + +import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as C +import Control.Monad + +------------------------------------------------------------------------------- + +{-# INLINE draw_line #-} +draw_line :: (Integral a, Integral b, Integral c, Integral d) => + (a, b) -> (c, d) -> Render () +draw_line (x0, y0) (x1, y1) + = do move_to (x0, y0) + lineTo (fromIntegral x1) (fromIntegral y1) + stroke + +{-# INLINE move_to #-} +move_to :: (Integral a, Integral b) => (a, b) -> Render () +move_to (x, y) + = moveTo (fromIntegral x) (fromIntegral y) + +{-# INLINE rel_line_to #-} +rel_line_to :: (Integral a, Integral b) => (a, b) -> Render () +rel_line_to (x, y) + = relLineTo (fromIntegral x) (fromIntegral y) + +------------------------------------------------------------------------------- + +{-# INLINE draw_rectangle #-} +draw_rectangle :: (Integral x, Integral y, Integral w, Integral h) + => x -> y -> w -> h + -> Render () +draw_rectangle x y w h = do + rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + C.fill + +------------------------------------------------------------------------------- + +{-# INLINE draw_outlined_rectangle #-} +draw_outlined_rectangle :: (Integral x, Integral y, Integral w, Integral h) + => x -> y -> w -> h + -> Render () +draw_outlined_rectangle x y w h = do + rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + fillPreserve + setLineWidth 1 + setSourceRGBA 0 0 0 0.7 + stroke + +------------------------------------------------------------------------------- + +{-# INLINE draw_rectangle_opt #-} +draw_rectangle_opt :: (Integral x, Integral y, Integral w, Integral h) + => Bool -> x -> y -> w -> h + -> Render () +draw_rectangle_opt opt x y w h + = draw_rectangle_opt' opt (fromIntegral x) (fromIntegral y) + (fromIntegral w) (fromIntegral h) + +draw_rectangle_opt' :: Bool -> Double -> Double -> Double -> Double + -> Render () +draw_rectangle_opt' opt x y w h + = do rectangle x y (1.0 `max` w) h + C.fill + when opt $ do + setLineWidth 1 + setSourceRGBA 0 0 0 0.7 + rectangle x y w h + stroke + +------------------------------------------------------------------------------- + +{-# INLINE draw_rectangle_outline #-} +draw_rectangle_outline :: (Integral x, Integral y, Integral w, Integral h) + => x -> y -> w -> h + -> Render () +draw_rectangle_outline x y w h = do + setLineWidth 2 + rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + stroke + +------------------------------------------------------------------------------- + +clearWhite :: Render () +clearWhite = do + save + setOperator OperatorSource + setSourceRGBA 0xffff 0xffff 0xffff 0xffff + paint + restore diff -Nru threadscope-0.1.3/GUI/Timeline/HEC.hs threadscope-0.2.1/GUI/Timeline/HEC.hs --- threadscope-0.1.3/GUI/Timeline/HEC.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/HEC.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,264 @@ +module GUI.Timeline.HEC ( + renderHEC, + renderInstantHEC, + ) where + +import GUI.Timeline.Render.Constants + +import Events.EventTree +import Events.EventDuration +import GUI.Types +import GUI.Timeline.CairoDrawing +import GUI.ViewerColours + +import Graphics.Rendering.Cairo + +import qualified GHC.RTS.Events as GHC +import GHC.RTS.Events hiding (Event, GCWork, GCIdle) + +import Control.Monad + +renderHEC :: ViewParameters + -> Timestamp -> Timestamp -> (DurationTree,EventTree) + -> Render () +renderHEC params@ViewParameters{..} start end (dtree,etree) = do + renderDurations params start end dtree + when (scaleValue < detailThreshold) $ + case etree of + EventTree ltime etime tree -> + renderEvents params ltime etime start end tree + +renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp + -> EventTree + -> Render () +renderInstantHEC params@ViewParameters{..} start end + (EventTree ltime etime tree) = + renderEvents params ltime etime start end tree + +detailThreshold :: Double +detailThreshold = 3 + +------------------------------------------------------------------------------- +-- hecView draws the trace for a single HEC + +renderDurations :: ViewParameters + -> Timestamp -> Timestamp -> DurationTree + -> Render () + +renderDurations _ _ _ DurationTreeEmpty = return () + +renderDurations params@ViewParameters{..} startPos endPos (DurationTreeLeaf e) + | inView startPos endPos e = drawDuration params e + | otherwise = return () + +renderDurations params@ViewParameters{..} !startPos !endPos + (DurationSplit s splitTime e lhs rhs runAv gcAv) + | startPos < splitTime && endPos >= splitTime && + (fromIntegral (e - s) / scaleValue) <= fromIntegral detail + = -- View spans both left and right sub-tree. + -- trace (printf "hecView (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $ + drawAverageDuration params s e runAv gcAv + + | otherwise + = -- trace (printf "hecView: start:%d end:%d s:%d e:%d" startPos endPos s e) $ + do when (startPos < splitTime) $ + renderDurations params startPos endPos lhs + when (endPos >= splitTime) $ + renderDurations params startPos endPos rhs + +------------------------------------------------------------------------------- + +renderEvents :: ViewParameters + -> Timestamp -- start time of this tree node + -> Timestamp -- end time of this tree node + -> Timestamp -> Timestamp -> EventNode + -> Render () + +renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos + (EventTreeLeaf es) + = sequence_ [ drawEvent params e + | e <- es, let t = time e, t >= startPos && t < endPos ] +renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos + (EventTreeOne ev) + | t >= startPos && t < endPos = drawEvent params ev + | otherwise = return () + where t = time ev + +renderEvents params@ViewParameters{..} !s !e !startPos !endPos + (EventSplit splitTime lhs rhs) + | startPos < splitTime && endPos >= splitTime && + (fromIntegral (e - s) / scaleValue) <= fromIntegral detail + -- was: = drawTooManyEvents params s e + -- is: draw only the right hand side (let's say it overwrites LHS) + = renderEvents params splitTime e startPos endPos rhs + + | otherwise + = do when (startPos < splitTime) $ + renderEvents params s splitTime startPos endPos lhs + when (endPos >= splitTime) $ + renderEvents params splitTime e startPos endPos rhs + +------------------------------------------------------------------------------- +-- An event is in view if it is not outside the view. + +inView :: Timestamp -> Timestamp -> EventDuration -> Bool +inView viewStart viewEnd event = + not (eStart > viewEnd || eEnd <= viewStart) + where + eStart = startTimeOf event + eEnd = endTimeOf event + +------------------------------------------------------------------------------- + +drawAverageDuration :: ViewParameters + -> Timestamp -> Timestamp -> Timestamp -> Timestamp + -> Render () +drawAverageDuration ViewParameters{..} startTime endTime runAv gcAv = do + setSourceRGBAhex (if not bwMode then runningColour else black) 1.0 + when (runAv > 0) $ + draw_rectangle startTime hecBarOff -- x, y + (endTime - startTime) -- w + hecBarHeight + setSourceRGBAhex black 1.0 + --move_to (oxs + startTime, 0) + --relMoveTo (4/scaleValue) 13 + --unscaledText scaleValue (show nrEvents) + setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio + draw_rectangle startTime -- x + (hecBarOff+hecBarHeight) -- y + (endTime - startTime) -- w + (hecBarHeight `div` 2) -- h + + where + duration = endTime - startTime +-- runRatio :: Double +-- runRatio = (fromIntegral runAv) / (fromIntegral duration) + gcRatio :: Double + gcRatio = (fromIntegral gcAv) / (fromIntegral duration) + +------------------------------------------------------------------------------- + +unscaledText :: String -> Render () +unscaledText text + = do m <- getMatrix + identityMatrix + showText text + setMatrix m + +------------------------------------------------------------------------------- + +textWidth :: Double -> String -> Render TextExtents +textWidth _scaleValue text + = do m <- getMatrix + identityMatrix + tExtent <- textExtents text + setMatrix m + return tExtent + +------------------------------------------------------------------------------- + +drawDuration :: ViewParameters -> EventDuration -> Render () +drawDuration ViewParameters{..} (ThreadRun t s startTime endTime) = do + setSourceRGBAhex (if not bwMode then runningColour else black) 1.0 + setLineWidth (1/scaleValue) + draw_rectangle_opt False + startTime -- x + hecBarOff -- y + (endTime - startTime) -- w + hecBarHeight -- h + -- Optionally label the bar with the threadID if there is room + tExtent <- textWidth scaleValue tStr + let tw = textExtentsWidth tExtent + th = textExtentsHeight tExtent + when (tw + 6 < fromIntegral rectWidth) $ do + setSourceRGBAhex labelTextColour 1.0 + move_to (fromIntegral startTime + truncate (4*scaleValue), + hecBarOff + (hecBarHeight + round th) `quot` 2) + unscaledText tStr + + -- Optionally write the reason for the thread being stopped + -- depending on the zoom value + labelAt labelsMode endTime $ + show t ++ " " ++ showThreadStopStatus s + where + rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels + tStr = show t + +drawDuration ViewParameters{..} (GCStart startTime endTime) + = gcBar (if bwMode then black else gcStartColour) startTime endTime + +drawDuration ViewParameters{..} (GCWork startTime endTime) + = gcBar (if bwMode then black else gcWorkColour) startTime endTime + +drawDuration ViewParameters{..} (GCIdle startTime endTime) + = gcBar (if bwMode then black else gcIdleColour) startTime endTime + +drawDuration ViewParameters{..} (GCEnd startTime endTime) + = gcBar (if bwMode then black else gcEndColour) startTime endTime + +gcBar :: Color -> Timestamp -> Timestamp -> Render () +gcBar col !startTime !endTime = do + setSourceRGBAhex col 1.0 + draw_rectangle_opt False + startTime -- x + (hecBarOff+hecBarHeight) -- y + (endTime - startTime) -- w + (hecBarHeight `div` 2) -- h + +labelAt :: Bool -> Timestamp -> String -> Render () +labelAt labelsMode t str + | not labelsMode = return () + | otherwise = do + setSourceRGB 0.0 0.0 0.0 + move_to (t, hecBarOff+hecBarHeight+12) + save + identityMatrix + rotate (pi/4) + showText str + restore + +drawEvent :: ViewParameters -> GHC.Event -> Render () +drawEvent params@ViewParameters{..} event + = case spec event of + CreateThread{} -> renderInstantEvent params event createThreadColour + RequestSeqGC{} -> renderInstantEvent params event seqGCReqColour + RequestParGC{} -> renderInstantEvent params event parGCReqColour + MigrateThread{} -> renderInstantEvent params event migrateThreadColour + WakeupThread{} -> renderInstantEvent params event threadWakeupColour + Shutdown{} -> renderInstantEvent params event shutdownColour + + SparkCreate{} -> renderInstantEvent params event createdConvertedColour + SparkDud{} -> renderInstantEvent params event fizzledDudsColour + SparkOverflow{} -> renderInstantEvent params event overflowedColour + SparkRun{} -> renderInstantEvent params event createdConvertedColour + SparkSteal{} -> renderInstantEvent params event createdConvertedColour + SparkFizzle{} -> renderInstantEvent params event fizzledDudsColour + SparkGC{} -> renderInstantEvent params event gcColour + + UserMessage{} -> renderInstantEvent params event userMessageColour + + RunThread{} -> return () + StopThread{} -> return () + StartGC{} -> return () + + _ -> return () + +renderInstantEvent :: ViewParameters -> GHC.Event -> Color -> Render () +renderInstantEvent ViewParameters{..} event color = do + setSourceRGBAhex color 1.0 + setLineWidth (3 * scaleValue) + let t = time event + draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4) + labelAt labelsMode t $ showEventInfo (spec event) + + +_drawTooManyEvents :: ViewParameters -> Timestamp -> Timestamp + -> Render () +_drawTooManyEvents _params@ViewParameters{..} _start _end = do + return () +-- setSourceRGBAhex grey 1.0 +-- setLineWidth (3 * scaleValue) +-- draw_rectangle start (hecBarOff-4) (end - start) 4 +-- draw_rectangle start (hecBarOff+hecBarHeight) (end - start) 4 + +------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/GUI/Timeline/Motion.hs threadscope-0.2.1/GUI/Timeline/Motion.hs --- threadscope-0.1.3/GUI/Timeline/Motion.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/Motion.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,134 @@ +module GUI.Timeline.Motion ( + zoomIn, zoomOut, zoomToFit, + scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, scrollTo, centreOnCursor, + vscrollDown, vscrollUp, + ) where + +import GUI.Timeline.Types +import GUI.Timeline.Sparks +import Events.HECs + +import Graphics.UI.Gtk + +import Data.IORef +import Control.Monad +-- import Text.Printf +-- import Debug.Trace + +------------------------------------------------------------------------------- +-- Zoom in works by expanding the current view such that the +-- left hand edge of the original view remains at the same +-- position and the zoom in factor is 2. +-- For example, zoom into the time range 1.0 3.0 +-- produces a new view with the time range 1.0 2.0 + +zoomIn :: TimelineState -> Timestamp -> IO () +zoomIn = zoom (/2) + +zoomOut :: TimelineState -> Timestamp -> IO () +zoomOut = zoom (*2) + +zoom :: (Double -> Double) -> TimelineState -> Timestamp -> IO () +zoom factor TimelineState{timelineAdj, scaleIORef} cursor = do + scaleValue <- readIORef scaleIORef + -- TODO: we'd need HECs, as below, to fit maxScale to graphs at hand + let maxScale = 10000000000 -- big enough for hours of eventlogs + clampedFactor = + if factor scaleValue < 0.2 || factor scaleValue > maxScale + then id + else factor + newScaleValue = clampedFactor scaleValue + writeIORef scaleIORef newScaleValue + + hadj_value <- adjustmentGetValue timelineAdj + hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar + + let newPageSize = clampedFactor hadj_pagesize + adjustmentSetPageSize timelineAdj newPageSize + + let cursord = fromIntegral cursor + when (cursord >= hadj_value && cursord < hadj_value + hadj_pagesize) $ + adjustmentSetValue timelineAdj $ + cursord - clampedFactor (cursord - hadj_value) + + let pageshift = 0.9 * newPageSize + let nudge = 0.1 * newPageSize + + adjustmentSetStepIncrement timelineAdj nudge + adjustmentSetPageIncrement timelineAdj pageshift + +------------------------------------------------------------------------------- + +zoomToFit :: TimelineState -> Maybe HECs -> IO () +zoomToFit TimelineState{scaleIORef, maxSpkIORef,timelineAdj, + timelineDrawingArea} mb_hecs = do + case mb_hecs of + Nothing -> return () + Just hecs -> do + let lastTx = hecLastEventTime hecs + upper = fromIntegral lastTx + lower = 0 + (w, _) <- widgetGetSize timelineDrawingArea + let newScaleValue = upper / fromIntegral w + (sliceAll, profAll) = treesProfile newScaleValue 0 lastTx hecs + -- TODO: verify that no empty lists possible below + maxmap l = maximum (0 : map (maxSparkRenderedValue sliceAll) l) + maxAll = map maxmap profAll + newMaxSpkValue = maximum (0 : maxAll) + + writeIORef scaleIORef newScaleValue + writeIORef maxSpkIORef newMaxSpkValue + + -- Configure the horizontal scrollbar units to correspond to micro-secs. + adjustmentSetLower timelineAdj lower + adjustmentSetValue timelineAdj lower + adjustmentSetUpper timelineAdj upper + adjustmentSetPageSize timelineAdj upper + -- TODO: this seems suspicious: + adjustmentSetStepIncrement timelineAdj 0 + adjustmentSetPageIncrement timelineAdj 0 + +------------------------------------------------------------------------------- + +scrollLeft, scrollRight, scrollToBeginning, scrollToEnd :: TimelineState -> IO () + +scrollLeft = scroll (\val page l _ -> l `max` (val - page/2)) +scrollRight = scroll (\val page _ u -> (u - page) `min` (val + page/2)) +scrollToBeginning = scroll (\_ _ l _ -> l) +scrollToEnd = scroll (\_ _ _ u -> u) + +scrollTo :: TimelineState -> Double -> IO () +scrollTo s x = scroll (\_ _ _ _ -> x) s + +centreOnCursor :: TimelineState -> Timestamp -> IO () + +centreOnCursor state cursor = + scroll (\_ page l _u -> max l (fromIntegral cursor - page/2)) state + +scroll :: (Double -> Double -> Double -> Double -> Double) + -> TimelineState -> IO () +scroll adjust TimelineState{timelineAdj} = do + hadj_value <- adjustmentGetValue timelineAdj + hadj_pagesize <- adjustmentGetPageSize timelineAdj + hadj_lower <- adjustmentGetLower timelineAdj + hadj_upper <- adjustmentGetUpper timelineAdj + let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper + newValue' = max hadj_lower (min (hadj_upper - hadj_pagesize) newValue) + adjustmentSetValue timelineAdj newValue' + +vscrollDown, vscrollUp :: TimelineState -> IO () +vscrollDown = vscroll (\val page _l u -> (u - page) `min` (val + page/8)) +vscrollUp = vscroll (\val page l _u -> l `max` (val - page/8)) + +vscroll :: (Double -> Double -> Double -> Double -> Double) + -> TimelineState -> IO () +vscroll adjust TimelineState{timelineVAdj} = do + hadj_value <- adjustmentGetValue timelineVAdj + hadj_pagesize <- adjustmentGetPageSize timelineVAdj + hadj_lower <- adjustmentGetLower timelineVAdj + hadj_upper <- adjustmentGetUpper timelineVAdj + let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper + adjustmentSetValue timelineVAdj newValue + adjustmentValueChanged timelineVAdj + +-- ----------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/GUI/Timeline/Render/Constants.hs threadscope-0.2.1/GUI/Timeline/Render/Constants.hs --- threadscope-0.1.3/GUI/Timeline/Render/Constants.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/Render/Constants.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,63 @@ +module GUI.Timeline.Render.Constants ( + ox, firstTraceY, tracePad, + hecTraceHeight, hecInstantHeight, hecSparksHeight, + hecBarOff, hecBarHeight, hecLabelExtra, + activityGraphHeight, stdHistogramHeight, histXScaleHeight, + ticksHeight, ticksPad + ) where + +------------------------------------------------------------------------------- + +-- The standard gap in various graphs + +ox :: Int +ox = 10 + +-- Origin for traces + +firstTraceY :: Int +firstTraceY = 13 + +-- Gap betweem traces in the timeline view + +tracePad :: Int +tracePad = 20 + +-- HEC bar height + +hecTraceHeight, hecInstantHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int + +hecTraceHeight = 40 +hecInstantHeight = 25 +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 + +-- Height of the spark graphs. +hecSparksHeight :: Int +hecSparksHeight = activityGraphHeight + +-- Histogram graph height when displayed with other traces (e.g., in PNG/PDF). +stdHistogramHeight :: Int +stdHistogramHeight = hecSparksHeight + +-- The X scale of histogram has this constant height, as opposed +-- to the timeline X scale, which takes its height from the .ui file. +histXScaleHeight :: Int +histXScaleHeight = 30 + +-- Ticks + +ticksHeight :: Int +ticksHeight = 20 + +ticksPad :: Int +ticksPad = 20 diff -Nru threadscope-0.1.3/GUI/Timeline/Render.hs threadscope-0.2.1/GUI/Timeline/Render.hs --- threadscope-0.1.3/GUI/Timeline/Render.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/Render.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,430 @@ +module GUI.Timeline.Render ( + renderView, + renderTraces, + updateXScaleArea, + renderYScaleArea, + updateYScaleArea, + calculateTotalTimelineHeight, + toWholePixels, + ) where + +import GUI.Timeline.Types +import GUI.Timeline.Render.Constants +import GUI.Timeline.Ticks +import GUI.Timeline.HEC +import GUI.Timeline.Sparks +import GUI.Timeline.Activity + +import Events.HECs +import GUI.Types +import GUI.ViewerColours +import GUI.Timeline.CairoDrawing + +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo + +import Data.IORef +import Control.Monad + +------------------------------------------------------------------------------- + +-- | This function redraws the currently visible part of the +-- main trace canvas plus related canvases. +-- +renderView :: TimelineState + -> ViewParameters + -> HECs -> TimeSelection -> [Timestamp] + -> Region -> IO () +renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView} + params hecs selection bookmarks exposeRegion = do + + -- Get state information from user-interface components + (w, _) <- widgetGetSize timelineDrawingArea + vadj_value <- adjustmentGetValue timelineVAdj + + prev_view <- readIORef timelinePrevView + + rect <- regionGetClipbox exposeRegion + + win <- widgetGetDrawWindow timelineDrawingArea + renderWithDrawable win $ do + + let renderToNewSurface = do + new_surface <- withTargetSurface $ \surface -> + liftIO $ createSimilarSurface surface ContentColor w (height params) + renderWith new_surface $ do + clearWhite + renderTraces params hecs rect + return new_surface + + surface <- + case prev_view of + Nothing -> renderToNewSurface + + Just (old_params, surface) + | old_params == params + -> return surface + + | width old_params == width params && + height old_params == height params + -> do + if old_params { hadjValue = hadjValue params } == params + -- only the hadjValue changed + && abs (hadjValue params - hadjValue old_params) < + fromIntegral (width params) * scaleValue params + -- and the views overlap... + then + scrollView surface old_params params hecs + else do + renderWith surface $ do + clearWhite; renderTraces params hecs rect + return surface + + | otherwise + -> do surfaceFinish surface + renderToNewSurface + + liftIO $ writeIORef timelinePrevView (Just (params, surface)) + + region exposeRegion + clip + setSourceSurface surface 0 (-vadj_value) + -- ^^ this is where we adjust for the vertical scrollbar + setOperator OperatorSource + paint + renderBookmarks bookmarks params + drawSelection params selection + +------------------------------------------------------------------------------- + +-- Render the bookmarks +renderBookmarks :: [Timestamp] -> ViewParameters -> Render () +renderBookmarks bookmarks vp@ViewParameters{height} = do + setLineWidth 1 + setSourceRGBAhex bookmarkColour 1.0 + sequence_ + [ do moveTo x 0 + lineTo x (fromIntegral height) + stroke + | bookmark <- bookmarks + , let x = timestampToView vp bookmark ] + +------------------------------------------------------------------------------- + +drawSelection :: ViewParameters -> TimeSelection -> Render () +drawSelection vp@ViewParameters{height} (PointSelection x) = do + setLineWidth 3 + setOperator OperatorOver + setSourceRGBAhex blue 1.0 + moveTo xv 0 + lineTo xv (fromIntegral height) + stroke + where + xv = timestampToView vp x + +drawSelection vp@ViewParameters{height} (RangeSelection x x') = do + setLineWidth 1.5 + setOperator OperatorOver + + setSourceRGBAhex blue 0.25 + rectangle xv 0 (xv' - xv) (fromIntegral height) + fill + + setSourceRGBAhex blue 1.0 + moveTo xv 0 + lineTo xv (fromIntegral height) + moveTo xv' 0 + lineTo xv' (fromIntegral height) + stroke + where + xv = timestampToView vp x + xv' = timestampToView vp x' + +------------------------------------------------------------------------------- + +-- We currently have two different way of converting from logical units +-- (ie timestamps in micro-seconds) to device units (ie pixels): +-- * the first is to set the cairo context to the appropriate scale +-- * the second is to do the conversion ourself +-- +-- While in principle the first is superior due to the simplicity: cairo +-- lets us use Double as the logical unit and scaling factor. In practice +-- however cairo does not support the full Double range because internally +-- it makes use of a 32bit fixed point float format. With very large scaling +-- factors we end up with artifacts like lines disappearing. +-- +-- So sadly we will probably have to convert to using the second method. + +-- | Use cairo to convert from logical units (timestamps) to device units +-- +withViewScale :: ViewParameters -> Render () -> Render () +withViewScale ViewParameters{scaleValue, hadjValue} inner = do + save + scale (1/scaleValue) 1.0 + translate (-hadjValue) 0 + inner + restore + +-- | Manually convert from logical units (timestamps) to device units. +-- +timestampToView :: ViewParameters -> Timestamp -> Double +timestampToView ViewParameters{scaleValue, hadjValue} ts = + (fromIntegral ts - hadjValue) / scaleValue + +------------------------------------------------------------------------------- +-- This function draws the current view of all the HECs with Cairo. + +renderTraces :: ViewParameters -> HECs -> Rectangle + -> Render () +renderTraces params@ViewParameters{..} hecs (Rectangle rx _ry rw _rh) = do + let scale_rx = fromIntegral rx * scaleValue + scale_rw = fromIntegral rw * scaleValue + scale_width = fromIntegral width * scaleValue + + startPos :: Timestamp + startPos = fromIntegral $ truncate (scale_rx + hadjValue) + + endPos :: Timestamp + endPos = minimum [ + ceiling (hadjValue + scale_width), + ceiling (hadjValue + scale_rx + scale_rw), + hecLastEventTime hecs + ] + + -- For spark traces, round the start time down, and the end time up, + -- to a slice boundary: + start = (startPos `div` slice) * slice + end = ((endPos + slice) `div` slice) * slice + (slice, prof) = treesProfile scaleValue start end hecs + + withViewScale params $ do + -- Render the vertical rulers across all the traces. + renderVRulers scaleValue startPos endPos height XScaleTime + + -- This function helps to render a single HEC. + -- Traces are rendered even if the y-region falls outside visible area. + -- OTOH, trace rendering function tend to drawn only the visible + -- x-region of the graph. + let renderTrace trace y = do + save + translate 0 (fromIntegral y) + case trace of + TraceHEC c -> + let (dtree, etree, _) = hecTrees hecs !! c + in renderHEC params startPos endPos (dtree, etree) + TraceInstantHEC c -> + let (_, etree, _) = hecTrees hecs !! c + in renderInstantHEC params startPos endPos etree + TraceCreationHEC c -> + renderSparkCreation params slice start end (prof !! c) + TraceConversionHEC c -> + renderSparkConversion params slice start end (prof !! c) + TracePoolHEC c -> + let maxP = maxSparkPool hecs + in renderSparkPool params slice start end (prof !! c) maxP + TraceHistogram -> + renderSparkHistogram params hecs + TraceGroup _ -> error "renderTrace" + TraceActivity -> + renderActivity params hecs startPos endPos + restore + histTotalHeight = histogramHeight + histXScaleHeight + -- Now render all the HECs. + zipWithM_ renderTrace viewTraces + (traceYPositions labelsMode histTotalHeight viewTraces) + +------------------------------------------------------------------------------- + +-- parameters differ only in the hadjValue, we can scroll ... +scrollView :: Surface + -> ViewParameters -> ViewParameters + -> HECs + -> Render Surface +scrollView surface old new hecs = do +-- scrolling on the same surface seems not to work, I get garbled results. +-- Not sure what the best way to do this is. +-- let new_surface = surface + new_surface <- withTargetSurface $ \surface -> + liftIO $ createSimilarSurface surface ContentColor + (width new) (height new) + + renderWith new_surface $ do + let scale = scaleValue new + old_hadj = hadjValue old + new_hadj = hadjValue new + w = fromIntegral (width new) + h = fromIntegral (height new) + off = (old_hadj - new_hadj) / scale + +-- liftIO $ printf "scrollView: old: %f, new %f, dist = %f (%f pixels)\n" +-- old_hadj new_hadj (old_hadj - new_hadj) off + + -- copy the content from the old surface to the new surface, + -- shifted by the appropriate amount. + setSourceSurface surface off 0 + if old_hadj > new_hadj + then rectangle off 0 (w - off) h -- scroll right. + else rectangle 0 0 (w + off) h -- scroll left. + fill + + let rect | old_hadj > new_hadj + = Rectangle 0 0 (ceiling off) (height new) + | otherwise + = Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new) + + case rect of + Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y) + (fromIntegral w) (fromIntegral h) + setSourceRGBA 0xffff 0xffff 0xffff 0xffff + fill + + renderTraces new hecs rect + + surfaceFinish surface + return new_surface + +-------------------------------------------------------------------------------- + +-- | Update the X scale widget, based on the state of all timeline areas. +-- For simplicity, unlike for the traces, we redraw the whole area +-- and not only the newly exposed area. This is comparatively very cheap. +updateXScaleArea :: TimelineState -> Timestamp -> IO () +updateXScaleArea TimelineState{..} lastTx = do + win <- widgetGetDrawWindow timelineXScaleArea + (width, _) <- widgetGetSize timelineDrawingArea + (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea + scaleValue <- readIORef scaleIORef + -- Snap the view to whole pixels, to avoid blurring. + hadjValue0 <- adjustmentGetValue timelineAdj + let hadjValue = toWholePixels scaleValue hadjValue0 + off y = y + xScaleAreaHeight - 17 + renderWithDrawable win $ + renderXScale scaleValue hadjValue lastTx width off XScaleTime + return () + +-------------------------------------------------------------------------------- + +-- | Render the Y scale area (an axis, ticks and a label for each graph), +-- based on view parameters and hecs. +renderYScaleArea :: ViewParameters -> HECs -> DrawingArea -> Render () +renderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces, + histogramHeight, minterval} + hecs yScaleArea = do + let maxP = maxSparkPool hecs + maxH = fromIntegral $ maxYHistogram hecs + (xoffset, _) <- liftIO $ widgetGetSize yScaleArea + drawYScaleArea + maxSpkValue maxP maxH minterval (fromIntegral xoffset) 0 + labelsMode histogramHeight viewTraces yScaleArea + +-- | Update the Y scale widget, based on the state of all timeline areas +-- and on traces (only for graph labels and relative positions). +updateYScaleArea :: TimelineState -> Double -> Double -> Maybe Interval + -> Bool -> [Trace] -> IO () +updateYScaleArea TimelineState{..} maxSparkPool maxYHistogram minterval + labelsMode traces = do + win <- widgetGetDrawWindow timelineYScaleArea + maxSpkValue <- readIORef maxSpkIORef + vadj_value <- adjustmentGetValue timelineVAdj + (xoffset, _) <- widgetGetSize timelineYScaleArea + renderWithDrawable win $ + drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval + (fromIntegral xoffset) vadj_value labelsMode stdHistogramHeight traces + timelineYScaleArea + +-- | Render the Y scale area, by rendering an axis, ticks and a label +-- for each graph-like trace in turn (and only labels for other traces). +drawYScaleArea :: Double -> Double -> Double -> Maybe Interval -> Double + -> Double -> Bool -> Int -> [Trace] -> DrawingArea + -> Render () +drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval xoffset + vadj_value labelsMode histogramHeight traces yScaleArea = do + let histTotalHeight = histogramHeight + histXScaleHeight + ys = map (subtract (round vadj_value)) $ + traceYPositions labelsMode histTotalHeight traces + pcontext <- liftIO $ widgetCreatePangoContext yScaleArea + zipWithM_ + (drawSingleYScale + maxSpkValue maxSparkPool maxYHistogram minterval xoffset + histogramHeight pcontext) + traces ys + +-- | Render a single Y scale axis, set of ticks and label, or only a label, +-- if the trace is not a graph. +drawSingleYScale :: Double -> Double -> Double -> Maybe Interval -> Double -> Int + -> PangoContext -> Trace -> Int + -> Render () +drawSingleYScale maxSpkValue maxSparkPool maxYHistogram minterval xoffset + histogramHeight pcontext trace y = do + setSourceRGBAhex black 1 + move_to (ox, y + 8) + layout <- liftIO $ layoutText pcontext (showTrace minterval trace) + liftIO $ do + layoutSetWidth layout (Just $ xoffset - 50) + -- Note: the following does not always work, see the HACK in Timeline.hs + layoutSetAttributes layout [AttrSize minBound maxBound 8, + AttrFamily minBound maxBound "sans serif"] + showLayout layout + case traceMaxSpark maxSpkValue maxSparkPool maxYHistogram trace of + Just v -> + renderYScale + (traceHeight histogramHeight trace) 1 v (xoffset - 13) (fromIntegral y) + Nothing -> return () -- not a graph-like trace + +-------------------------------------------------------------------------------- + +-- | Calculate Y positions of all traces. +traceYPositions :: Bool -> Int -> [Trace] -> [Int] +traceYPositions labelsMode histTotalHeight traces = + scanl (\a b -> a + (height b) + extra + tracePad) firstTraceY traces + where + height b = traceHeight histTotalHeight b + extra = if labelsMode then hecLabelExtra else 0 + +traceHeight :: Int -> Trace -> Int +traceHeight _ TraceHEC{} = hecTraceHeight +traceHeight _ TraceInstantHEC{} = hecInstantHeight +traceHeight _ TraceCreationHEC{} = hecSparksHeight +traceHeight _ TraceConversionHEC{} = hecSparksHeight +traceHeight _ TracePoolHEC{} = hecSparksHeight +traceHeight h TraceHistogram = h +traceHeight _ TraceGroup{} = error "traceHeight" +traceHeight _ TraceActivity = activityGraphHeight + +-- | Calculate the total Y span of all traces. +calculateTotalTimelineHeight :: Bool -> Int -> [Trace] -> Int +calculateTotalTimelineHeight labelsMode histTotalHeight traces = + last (traceYPositions labelsMode histTotalHeight traces) + +-- | Produce a descriptive label for a trace. +showTrace :: Maybe Interval -> Trace -> String +showTrace _ (TraceHEC n) = + "HEC " ++ show n +showTrace _ (TraceInstantHEC n) = + "HEC " ++ show n ++ "\nInstant" +showTrace _ (TraceCreationHEC n) = + "\nHEC " ++ show n ++ "\n\nSpark creation rate (spark/ms)" +showTrace _ (TraceConversionHEC n) = + "\nHEC " ++ show n ++ "\n\nSpark conversion rate (spark/ms)" +showTrace _ (TracePoolHEC n) = + "\nHEC " ++ show n ++ "\n\nSpark pool size" +showTrace Nothing TraceHistogram = + "Sum of spark times\n(" ++ mu ++ "s)" +showTrace Just{} TraceHistogram = + "Sum of selected spark times\n(" ++ mu ++ "s)" +showTrace _ TraceActivity = + "Activity" +showTrace _ TraceGroup{} = error "Render.showTrace" + +-- | Calcaulate the maximal Y value for a graph-like trace, or Nothing. +traceMaxSpark :: Double -> Double -> Double -> Trace -> Maybe Double +traceMaxSpark maxS _ _ TraceCreationHEC{} = Just $ maxS * 1000 +traceMaxSpark maxS _ _ TraceConversionHEC{} = Just $ maxS * 1000 +traceMaxSpark _ maxP _ TracePoolHEC{} = Just $ maxP +traceMaxSpark _ _ maxH TraceHistogram = Just $ maxH +traceMaxSpark _ _ _ _ = Nothing + +-- | Snap a value to a whole pixel, based on drawing scale. +toWholePixels :: Double -> Double -> Double +toWholePixels 0 _ = 0 +toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale diff -Nru threadscope-0.1.3/GUI/Timeline/Sparks.hs threadscope-0.2.1/GUI/Timeline/Sparks.hs --- threadscope-0.1.3/GUI/Timeline/Sparks.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/Sparks.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,245 @@ +module GUI.Timeline.Sparks ( + treesProfile, + maxSparkRenderedValue, + renderSparkCreation, + renderSparkConversion, + renderSparkPool, + renderSparkHistogram, + ) where + +import GUI.Timeline.Render.Constants + +import Events.HECs +import Events.SparkTree +import qualified Events.SparkStats as SparkStats + +import GUI.Types +import GUI.ViewerColours +import GUI.Timeline.Ticks + +import Graphics.Rendering.Cairo + +import Control.Monad + +-- Rendering sparks. No approximation nor extrapolation is going on here. +-- The sample data, recalculated for a given slice size in sparkProfile, +-- before these functions are called, is straightforwardly rendered. + +maxSparkRenderedValue :: Timestamp -> SparkStats.SparkStats -> Double +maxSparkRenderedValue duration c = + max (SparkStats.rateDud c + + SparkStats.rateCreated c + + SparkStats.rateOverflowed c) + (SparkStats.rateFizzled c + + SparkStats.rateConverted c + + SparkStats.rateGCd c) + / fromIntegral duration + +spark_detail :: Int +spark_detail = 4 -- in pixels + +treesProfile :: Double -> Timestamp -> Timestamp -> HECs + -> (Timestamp, [[SparkStats.SparkStats]]) +treesProfile scale start end hecs = + let slice = ceiling (fromIntegral spark_detail * scale) + pr trees = let (_, _, stree) = trees + in sparkProfile slice start end stree + in (slice, map pr (hecTrees hecs)) + + +renderSparkCreation :: ViewParameters -> Timestamp -> Timestamp -> Timestamp + -> [SparkStats.SparkStats] + -> Render () +renderSparkCreation params !slice !start !end prof = do + let f1 c = SparkStats.rateCreated c + f2 c = f1 c + SparkStats.rateDud c + f3 c = f2 c + SparkStats.rateOverflowed c + renderSpark params slice start end prof + f1 createdConvertedColour f2 fizzledDudsColour f3 overflowedColour + +renderSparkConversion :: ViewParameters -> Timestamp -> Timestamp -> Timestamp + -> [SparkStats.SparkStats] + -> Render () +renderSparkConversion params !slice !start !end prof = do + let f1 c = SparkStats.rateConverted c + f2 c = f1 c + SparkStats.rateFizzled c + f3 c = f2 c + SparkStats.rateGCd c + renderSpark params slice start end prof + f1 createdConvertedColour f2 fizzledDudsColour f3 gcColour + +renderSparkPool :: ViewParameters -> Timestamp -> Timestamp -> Timestamp + -> [SparkStats.SparkStats] + -> Double -> Render () +renderSparkPool ViewParameters{..} !slice !start !end prof !maxSparkPool = do + let f1 c = SparkStats.minPool c + f2 c = SparkStats.meanPool c + f3 c = SparkStats.maxPool c + addSparks outerPercentilesColour maxSparkPool f1 f2 start slice prof + addSparks outerPercentilesColour maxSparkPool f2 f3 start slice prof + outlineSparks maxSparkPool f2 start slice prof + outlineSparks maxSparkPool (const 0) start slice prof + renderHRulers hecSparksHeight start end + +renderSpark :: ViewParameters -> Timestamp -> Timestamp -> Timestamp + -> [SparkStats.SparkStats] + -> (SparkStats.SparkStats -> Double) -> Color + -> (SparkStats.SparkStats -> Double) -> Color + -> (SparkStats.SparkStats -> Double) -> Color + -> Render () +renderSpark ViewParameters{..} slice start end prof f1 c1 f2 c2 f3 c3 = do + -- maxSpkValue is maximal spark transition rate, so + -- maxSliceSpark is maximal number of sparks per slice for current data. + let maxSliceSpark = maxSpkValue * fromIntegral slice + outlineSparks maxSliceSpark f3 start slice prof + addSparks c1 maxSliceSpark (const 0) f1 start slice prof + addSparks c2 maxSliceSpark f1 f2 start slice prof + addSparks c3 maxSliceSpark f2 f3 start slice prof + renderHRulers hecSparksHeight start end + +off :: Double -> (SparkStats.SparkStats -> Double) + -> SparkStats.SparkStats + -> Double +off maxSliceSpark f t = + let clipped = min 1 (f t / maxSliceSpark) + in fromIntegral hecSparksHeight * (1 - clipped) + +outlineSparks :: Double + -> (SparkStats.SparkStats -> Double) + -> Timestamp -> Timestamp + -> [SparkStats.SparkStats] + -> Render () +outlineSparks maxSliceSpark f start slice ts = do + case ts of + [] -> return () + ts -> do + let dstart = fromIntegral start + dslice = fromIntegral slice + points = [dstart-dslice/2, dstart+dslice/2 ..] + t = zip points (map (off maxSliceSpark f) ts) + newPath + moveTo (dstart-dslice/2) (snd $ head t) + mapM_ (uncurry lineTo) t + setSourceRGBAhex black 1.0 + setLineWidth 1 + stroke + +addSparks :: Color + -> Double + -> (SparkStats.SparkStats -> Double) + -> (SparkStats.SparkStats -> Double) + -> Timestamp -> Timestamp + -> [SparkStats.SparkStats] + -> Render () +addSparks colour maxSliceSpark f0 f1 start slice ts = do + case ts of + [] -> return () + ts -> do + -- liftIO $ printf "ts: %s\n" (show (map f1 (ts))) + -- liftIO $ printf "off: %s\n" + -- (show (map (off maxSliceSpark f1) (ts) :: [Double])) + let dstart = fromIntegral start + dslice = fromIntegral slice + points = [dstart-dslice/2, dstart+dslice/2 ..] + t0 = zip points (map (off maxSliceSpark f0) ts) + t1 = zip points (map (off maxSliceSpark f1) ts) + newPath + moveTo (dstart-dslice/2) (snd $ head t1) + mapM_ (uncurry lineTo) t1 + mapM_ (uncurry lineTo) (reverse t0) + setSourceRGBAhex colour 1.0 + fill + +-- | Render the spark duration histogram together with it's X scale and +-- horizontal and vertical rulers. +renderSparkHistogram :: ViewParameters -> HECs -> Render () +renderSparkHistogram ViewParameters{..} hecs = + let intDoub :: Integral a => a -> Double + intDoub = fromIntegral + inR :: Timestamp -> Bool + inR = case minterval of + Nothing -> const True + Just (from, to) -> \ t -> t >= from && t <= to + -- TODO: if xs is sorted, we can slightly optimize the filtering + inRange :: [(Timestamp, Int, Timestamp)] -> [(Int, (Timestamp, Int))] + inRange xs = [(logdur, (dur, 1)) + | (start, logdur, dur) <- xs, inR start] + xs = durHistogram hecs + bars :: [(Double, Double, Int)] + bars = [(intDoub t, intDoub height, count) + | (t, (height, count)) <- histogramCounts $ inRange xs] + -- TODO: data processing up to this point could be done only at interval + -- changes (keeping @bars@ in ViewParameters and in probably also in IOref. + -- The rest has to be recomputed at each redraw, because resizing + -- the window modifies the way the graph is drawn. + -- TODO: at least pull the above out into a separate function. + + -- Define general parameters for visualization. + width' = width - 5 -- add a little margin on the right + (w, h) = (intDoub width', intDoub histogramHeight) + (minX, maxX, maxY) = (intDoub (minXHistogram hecs), + intDoub (maxXHistogram hecs), + intDoub (maxYHistogram hecs)) + nBars = max 5 (maxX - minX + 1) + segmentWidth = w / nBars + -- Define parameters for drawing the bars. + gapWidth = 10 + barWidth = segmentWidth - gapWidth + sX x = gapWidth / 2 + (x - minX) * segmentWidth + sY y = y * h / (max 2 maxY) + plotRect (x, y, count) = do + -- Draw a single bar. + setSourceRGBAhex blue 1.0 + rectangle (sX x) (sY maxY) barWidth (sY (-y)) + fillPreserve + setSourceRGBA 0 0 0 0.7 + setLineWidth 1 + stroke + -- Print the number of sparks in the bar. + selectFontFace "sans serif" FontSlantNormal FontWeightNormal + setFontSize 10 + let above = sY (-y) > -20 + if above + then setSourceRGBAhex black 1.0 + else setSourceRGBAhex white 1.0 + moveTo (sX x + 3) (sY (maxY - y) + if above then -3 else 13) + showText (show count) + drawHist = forM_ bars plotRect + -- Define parameters for X scale. + off y = 16 - y + xScaleMode = XScaleLog minX segmentWidth + drawXScale = renderXScale 1 0 maxBound width' off xScaleMode + -- Define parameters for vertical rulers. + nB = round nBars + mult | nB <= 7 = 1 + | nB `mod` 5 == 0 = 5 + | nB `mod` 4 == 0 = 4 + | nB `mod` 3 == 0 = 3 + | nB `mod` 2 == 0 = nB `div` 2 + | otherwise = nB + drawVRulers = renderVRulers 1 0 (fromIntegral width') histogramHeight + (XScaleLog undefined (segmentWidth * fromIntegral mult)) + -- Define the horizontal rulers call. + drawHRulers = renderHRulers histogramHeight 0 (fromIntegral width') + in do + -- Start the drawing by wiping out timeline vertical rules + -- (for PNG/PDF that require clear, transparent background) + save + translate hadjValue 0 + scale scaleValue 1 + rectangle 0 (fromIntegral $ - tracePad) (fromIntegral width) + (fromIntegral $ histogramHeight + histXScaleHeight + 2 * tracePad) + setSourceRGBAhex white 1 + op <- getOperator + setOperator OperatorAtop -- TODO: fixme: it paints white vertical rulers + fill + setOperator op + -- Draw the bars. + drawHist + -- Draw the rulers on top of the bars (they are partially transparent). + drawVRulers + drawHRulers + -- Move to the bottom and draw the X scale. The Y scale is drawn + -- independetly in another drawing area. + translate 0 (fromIntegral histogramHeight) + drawXScale + restore diff -Nru threadscope-0.1.3/GUI/Timeline/Ticks.hs threadscope-0.2.1/GUI/Timeline/Ticks.hs --- threadscope-0.1.3/GUI/Timeline/Ticks.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/Ticks.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,280 @@ +{-# LANGUAGE CPP #-} +module GUI.Timeline.Ticks ( + renderVRulers, + XScaleMode(..), + renderXScaleArea, + renderXScale, + renderHRulers, + renderYScale, + mu, + deZero, + ) where + +import Events.HECs +import GUI.Types +import GUI.Timeline.CairoDrawing +import GUI.ViewerColours + +import Graphics.Rendering.Cairo +import Control.Monad +import Text.Printf + +-- Minor, semi-major and major ticks are drawn and the absolute period of +-- the ticks is determined by the zoom level. +-- There are ten minor ticks to a major tick and a semi-major tick +-- occurs half way through a major tick (overlapping the corresponding +-- minor tick). +-- The timestamp values are in micro-seconds (1e-6) i.e. +-- a timestamp value of 1000000 represents 1s. The position on the drawing +-- canvas is in milliseconds (ms) (1e-3). +-- scaleValue is used to divide a timestamp value to yield a pixel value. +-- NOTE: the code below will crash if the timestampFor100Pixels is 0. +-- The zoom factor should be controlled to ensure that this never happens. + +-- | Render vertical rulers (solid translucent lines), matching scale ticks. +renderVRulers :: Double -> Timestamp -> Timestamp -> Int -> XScaleMode + -> Render() +renderVRulers scaleValue startPos endPos height xScaleMode = do + let timestampFor100Pixels = truncate (100 * scaleValue) + snappedTickDuration :: Timestamp + snappedTickDuration = + 10 ^ max 0 (truncate (logBase 10 (fromIntegral timestampFor100Pixels) + :: Double)) + tickWidthInPixels :: Double + tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue + firstTick :: Timestamp + firstTick = snappedTickDuration * (startPos `div` snappedTickDuration) + setSourceRGBAhex black 0.15 + setLineWidth scaleValue + case xScaleMode of + XScaleTime -> + drawVRulers tickWidthInPixels scaleValue + (fromIntegral $ firstTick + snappedTickDuration) + (fromIntegral snappedTickDuration) endPos height + (1 + fromIntegral (startPos `div` snappedTickDuration)) + XScaleLog _ dx -> + drawVRulers 1e1000 1 dx dx endPos height 1 + +-- | Render a single vertical ruler and then recurse. +drawVRulers :: Double -> Double -> Double -> Double + -> Timestamp -> Int -> Int -> Render () +drawVRulers tickWidthInPixels scaleValue pos incr endPos height i = + if floor pos <= endPos then do + when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do + draw_line (round pos, 0) (round pos, height) + drawVRulers + tickWidthInPixels scaleValue (pos + incr) incr endPos height (i + 1) + else + return () + where + atMidTick = i `mod` 5 == 0 + atMajorTick = i `mod` 10 == 0 + + +-- | Render the X scale, based on view parameters and hecs. +renderXScaleArea :: ViewParameters -> HECs -> Render () +renderXScaleArea ViewParameters{width, scaleValue, hadjValue, xScaleAreaHeight} + hecs = + let lastTx = hecLastEventTime hecs + off y = y + xScaleAreaHeight - 17 + in renderXScale scaleValue hadjValue lastTx width off XScaleTime + + +data XScaleMode = XScaleTime | XScaleLog Double Double deriving Eq + +-- | Render the X (vertical) scale: render X axis and call ticks rendering. +-- TODO: refactor common parts with renderVRulers, in particlar to expose +-- that ruler positions match tick positions. +renderXScale :: Double -> Double -> Timestamp -> Int + -> (Int -> Int) -> XScaleMode + -> Render () +renderXScale scaleValue hadjValue lastTx width off xScaleMode = do + let scale_width = fromIntegral width * scaleValue + startPos :: Timestamp + startPos = truncate hadjValue + endPos :: Timestamp + endPos = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx) + save + scale (1/scaleValue) 1.0 + translate (-hadjValue) 0 + selectFontFace "sans serif" FontSlantNormal FontWeightNormal + setFontSize 12 + setSourceRGBAhex black 1.0 +-- setLineCap LineCapRound -- TODO: breaks rendering currently (see BrokenX.png) + setLineWidth 1.0 -- TODO: it's not really 1 pixel, due to the scale + -- TODO: snap to pixels, currently looks semi-transparent + draw_line (startPos, off 16) (endPos, off 16) + let tFor100Pixels = truncate (100 * scaleValue) + snappedTickDuration :: Timestamp + snappedTickDuration = + 10 ^ max 0 (truncate (logBase 10 (fromIntegral tFor100Pixels) + :: Double)) + tickWidthInPixels :: Double + tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue + firstTick :: Timestamp + firstTick = snappedTickDuration * (startPos `div` snappedTickDuration) + setLineWidth scaleValue -- TODO: should be 0.5 pixels (when we rewrite stuff) + case xScaleMode of + XScaleTime -> + drawXTicks tickWidthInPixels scaleValue (fromIntegral firstTick) + (fromIntegral snappedTickDuration) endPos off xScaleMode + (fromIntegral (startPos `div` snappedTickDuration)) + XScaleLog _ segmentWidth -> + drawXTicks 1e1000 1 0 segmentWidth endPos off xScaleMode 0 + restore + +-- | Render a single X scale tick and then recurse. +drawXTicks :: Double -> Double -> Double -> Double -> Timestamp + -> (Int -> Int) -> XScaleMode -> Int + -> Render () +drawXTicks tickWidthInPixels scaleValue pos incr endPos off xScaleMode i = + if floor pos <= endPos then do + -- TODO: snap to pixels, currently looks semi-transparent + when (pos /= 0 || xScaleMode == XScaleTime) $ + draw_line (x1, off 16) (x1, off (16 - tickLength)) + when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do + tExtent <- textExtents tickTimeText + let tExtentWidth = textExtentsWidth tExtent + move_to textPos + m <- getMatrix + identityMatrix + when (floor (pos + incr) <= endPos + && (tExtentWidth + tExtentWidth / 3 < width || atMajorTick)) $ + showText tickTimeText + setMatrix m + drawXTicks + tickWidthInPixels scaleValue (pos + incr) incr endPos off xScaleMode (i+1) + else + return () + where + atMidTick = xScaleMode == XScaleTime && i `mod` 5 == 0 + atMajorTick = xScaleMode == XScaleTime && i `mod` 10 == 0 + textPos = + if xScaleMode == XScaleTime + then (x1 + ceiling (scaleValue * 3), off (-3)) + else (x1 + ceiling (scaleValue * 2), tickLength + 13) + tickLength | atMajorTick = 16 + | atMidTick = 10 + | otherwise = if xScaleMode == XScaleTime then 6 else 8 + posTime = case xScaleMode of + XScaleTime -> round pos + XScaleLog minX _ -> round $ 2 ** (minX + pos / incr) + tickTimeText = showMultiTime posTime + width = if atMidTick then 5 * tickWidthInPixels + else tickWidthInPixels + -- We cheat at pos 0, to avoid half covering the tick by the grey label area. + lineWidth = scaleValue + x1 = round $ if pos == 0 && xScaleMode == XScaleTime then lineWidth else pos + +-- | Display the micro-second time unit with an appropriate suffix +-- depending on the actual time value. +-- For times < 1e-6 the time is shown in micro-seconds. +-- For times >= 1e-6 and < 0.1 seconds the time is shown in ms +-- For times >= 0.5 seconds the time is shown in seconds +showMultiTime :: Timestamp -> String +showMultiTime pos = + if pos == 0 then "0s" + else if pos < 1000 then -- Show time as micro-seconds for times < 1e-6 + reformatMS posf ++ (mu ++ "s") -- microsecond (1e-6s). + else if pos < 100000 then -- Show miliseonds for time < 0.1s + reformatMS (posf / 1000) ++ "ms" -- miliseconds 1e-3 + else -- Show time in seconds + reformatMS (posf / 1000000) ++ "s" + where + posf :: Double + posf = fromIntegral pos + reformatMS :: Show a => a -> String + reformatMS pos = deZero (show pos) + +------------------------------------------------------------------------------- + +-- | Render horizontal rulers (dashed translucent lines), +-- matching scale ticks (visible in the common @incr@ value and starting at 0). +renderHRulers :: Int -> Timestamp -> Timestamp -> Render () +renderHRulers hecSparksHeight start end = do + let dstart = fromIntegral start + dend = fromIntegral end + incr = fromIntegral hecSparksHeight / 10 + -- dashed lines across the graphs + setSourceRGBAhex black 0.15 + setLineWidth 1 + save + forM_ [0, 5] $ \h -> do + let y = h * incr + moveTo dstart y + lineTo dend y + stroke + restore + +-- | Render one of the Y (horizontal) scales: render the Y axis +-- and call ticks rendering. +renderYScale :: Int -> Double -> Double -> Double -> Double -> Render () +renderYScale hecSparksHeight scaleValue maxSpark xoffset yoffset = do + let -- This is slightly off (by 1% at most), but often avoids decimal dot: + maxS = if maxSpark < 100 + then maxSpark -- too small, would be visible on screen + else fromIntegral (2 * (ceiling maxSpark ` div` 2)) + incr = fromIntegral hecSparksHeight / 10 + save + newPath + moveTo (xoffset + 12) yoffset + lineTo (xoffset + 12) (yoffset + fromIntegral hecSparksHeight) + setSourceRGBAhex black 1.0 + setLineCap LineCapRound + setLineWidth 1.0 -- TODO: it's not really 1 pixel, due to the scale + stroke + selectFontFace "sans serif" FontSlantNormal FontWeightNormal + setFontSize 12 + scale scaleValue 1.0 + setLineWidth 0.5 -- TODO: it's not really 0.5 pixels, due to the scale + drawYTicks maxS 0 incr xoffset yoffset 0 + restore + +-- | Render a single Y scale tick and then recurse. +drawYTicks :: Double -> Double -> Double -> Double -> Double -> Int -> Render () +drawYTicks maxS pos incr xoffset yoffset i = + if i <= 10 then do + -- TODO: snap to pixels, currently looks semi-transparent + moveTo (xoffset + 12) (yoffset + majorTick - pos) + lineTo (xoffset + 12 - tickLength) (yoffset + majorTick - pos) + stroke + when (atMajorTick || atMidTick) $ do + tExtent <- textExtents tickText + (fewPixels, yPix) <- deviceToUserDistance 3 4 + moveTo (xoffset - textExtentsWidth tExtent - fewPixels) + (yoffset + majorTick - pos + yPix) + when (atMidTick || atMajorTick) $ + showText tickText + drawYTicks maxS (pos + incr) incr xoffset yoffset (i + 1) + else + return () + where + atMidTick = i `mod` 5 == 0 + atMajorTick = i `mod` 10 == 0 + majorTick = 10 * incr + tickText = reformatV (fromIntegral i * maxS / 10) + tickLength | atMajorTick = 11 + | atMidTick = 9 + | otherwise = 6 + reformatV :: Double -> String + reformatV v = deZero (printf "%.2f" v) + +------------------------------------------------------------------------------- + +-- | The 'micro' symbol. +mu :: String +#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1) +-- this version of cairo doesn't handle Unicode properly. +-- Thus, we do the encoding by hand: +mu = "\194\181" +#else +-- Haskell cairo bindings 0.12.1 have proper Unicode support +mu = "\x00b5" +#endif + +-- | Remove all meaningless trailing zeroes. +deZero :: String -> String +deZero s + | '.' `elem` s = + reverse . dropWhile (=='.') . dropWhile (=='0') . reverse $ s + | otherwise = s diff -Nru threadscope-0.1.3/GUI/Timeline/Types.hs threadscope-0.2.1/GUI/Timeline/Types.hs --- threadscope-0.1.3/GUI/Timeline/Types.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline/Types.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,37 @@ +module GUI.Timeline.Types ( + TimelineState(..), + TimeSelection(..), + ) where + + +import GUI.Types + +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo +import Data.IORef + +----------------------------------------------------------------------------- + +data TimelineState = TimelineState { + timelineDrawingArea :: DrawingArea, + timelineYScaleArea :: DrawingArea, + timelineXScaleArea :: DrawingArea, + timelineAdj :: Adjustment, + timelineVAdj :: Adjustment, + + timelinePrevView :: IORef (Maybe (ViewParameters, Surface)), + + -- This scale value is used to map a micro-second value to a pixel unit. + -- To convert a timestamp value to a pixel value, multiply it by scale. + -- To convert a pixel value to a micro-second value, divide it by scale. + scaleIORef :: IORef Double, + + -- Maximal number of sparks/slice measured after every zoom to fit. + maxSpkIORef :: IORef Double + } + + +data TimeSelection = PointSelection Timestamp + | RangeSelection Timestamp Timestamp + +----------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/GUI/Timeline.hs threadscope-0.2.1/GUI/Timeline.hs --- threadscope-0.1.3/GUI/Timeline.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Timeline.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,512 @@ +{-# LANGUAGE CPP #-} +module GUI.Timeline ( + TimelineView, + timelineViewNew, + TimelineViewActions(..), + + timelineSetBWMode, + timelineSetLabelsMode, + timelineGetViewParameters, + timelineGetYScaleArea, + timelineWindowSetHECs, + timelineWindowSetTraces, + timelineWindowSetBookmarks, + timelineSetSelection, + TimeSelection(..), + + timelineZoomIn, + timelineZoomOut, + timelineZoomToFit, + timelineScrollLeft, + timelineScrollRight, + timelineScrollToBeginning, + timelineScrollToEnd, + timelineCentreOnCursor, + ) where + +import GUI.Types +import GUI.Timeline.Types + +import GUI.Timeline.Motion +import GUI.Timeline.Render +import GUI.Timeline.Render.Constants + +import Events.HECs + +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo + +import Data.IORef +import Control.Monad + +----------------------------------------------------------------------------- +-- The CPUs view + +data TimelineView = TimelineView { + + timelineState :: TimelineState, + + hecsIORef :: IORef (Maybe HECs), + tracesIORef :: IORef [Trace], + bookmarkIORef :: IORef [Timestamp], + + selectionRef :: IORef TimeSelection, + labelsModeIORef :: IORef Bool, + bwmodeIORef :: IORef Bool, + + cursorIBeam :: Cursor, + cursorMove :: Cursor + } + +data TimelineViewActions = TimelineViewActions { + timelineViewSelectionChanged :: TimeSelection -> IO () + } + +-- | Draw some parts of the timeline in black and white rather than colour. +timelineSetBWMode :: TimelineView -> Bool -> IO () +timelineSetBWMode timelineWin bwmode = do + writeIORef (bwmodeIORef timelineWin) bwmode + widgetQueueDraw (timelineDrawingArea (timelineState timelineWin)) + +timelineSetLabelsMode :: TimelineView -> Bool -> IO () +timelineSetLabelsMode timelineWin labelsMode = do + writeIORef (labelsModeIORef timelineWin) labelsMode + widgetQueueDraw (timelineDrawingArea (timelineState timelineWin)) + +timelineGetViewParameters :: TimelineView -> IO ViewParameters +timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef, + timelineState=TimelineState{..}} = do + + (w, _) <- widgetGetSize timelineDrawingArea + scaleValue <- readIORef scaleIORef + maxSpkValue <- readIORef maxSpkIORef + + -- snap the view to whole pixels, to avoid blurring + hadj_value0 <- adjustmentGetValue timelineAdj + let hadj_value = toWholePixels scaleValue hadj_value0 + + traces <- readIORef tracesIORef + bwmode <- readIORef bwmodeIORef + labelsMode <- readIORef labelsModeIORef + + (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea + let histTotalHeight = stdHistogramHeight + histXScaleHeight + timelineHeight = + calculateTotalTimelineHeight labelsMode histTotalHeight traces + + return ViewParameters + { width = w + , height = timelineHeight + , viewTraces = traces + , hadjValue = hadj_value + , scaleValue = scaleValue + , maxSpkValue = maxSpkValue + , detail = 3 --for now + , bwMode = bwmode + , labelsMode = labelsMode + , histogramHeight = stdHistogramHeight + , minterval = Nothing + , xScaleAreaHeight = xScaleAreaHeight + } + +timelineGetYScaleArea :: TimelineView -> DrawingArea +timelineGetYScaleArea timelineWin = + timelineYScaleArea $ timelineState timelineWin + +timelineWindowSetHECs :: TimelineView -> Maybe HECs -> IO () +timelineWindowSetHECs timelineWin@TimelineView{..} mhecs = do + writeIORef hecsIORef mhecs + zoomToFit timelineState mhecs + timelineParamsChanged timelineWin + +timelineWindowSetTraces :: TimelineView -> [Trace] -> IO () +timelineWindowSetTraces timelineWin@TimelineView{tracesIORef} traces = do + writeIORef tracesIORef traces + timelineParamsChanged timelineWin + +timelineWindowSetBookmarks :: TimelineView -> [Timestamp] -> IO () +timelineWindowSetBookmarks timelineWin@TimelineView{bookmarkIORef} bookmarks = do + writeIORef bookmarkIORef bookmarks + timelineParamsChanged timelineWin + +----------------------------------------------------------------------------- + +timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView +timelineViewNew builder actions@TimelineViewActions{..} = do + + let getWidget cast = builderGetObject builder cast + timelineViewport <- getWidget castToWidget "timeline_viewport" + timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea" + timelineYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area" + timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area" + timelineHScrollbar <- getWidget castToHScrollbar "timeline_hscroll" + timelineVScrollbar <- getWidget castToVScrollbar "timeline_vscroll" + timelineAdj <- rangeGetAdjustment timelineHScrollbar + timelineVAdj <- rangeGetAdjustment timelineVScrollbar + + -- HACK: layoutSetAttributes does not work for \mu, so let's work around + fd <- fontDescriptionNew + fontDescriptionSetSize fd 8 + fontDescriptionSetFamily fd "sans serif" + widgetModifyFont timelineYScaleArea (Just fd) + + cursorIBeam <- cursorNew Xterm + cursorMove <- cursorNew Fleur + + hecsIORef <- newIORef Nothing + tracesIORef <- newIORef [] + bookmarkIORef <- newIORef [] + scaleIORef <- newIORef 0 + maxSpkIORef <- newIORef 0 + selectionRef <- newIORef (PointSelection 0) + bwmodeIORef <- newIORef False + labelsModeIORef <- newIORef False + timelinePrevView <- newIORef Nothing + + let timelineState = TimelineState{..} + timelineWin = TimelineView{..} + + ------------------------------------------------------------------------ + -- Redrawing labelDrawingArea + timelineYScaleArea `onExpose` \_ -> do + maybeEventArray <- readIORef hecsIORef + + -- Check to see if an event trace has been loaded + case maybeEventArray of + Nothing -> return False + Just hecs -> do + traces <- readIORef tracesIORef + labelsMode <- readIORef labelsModeIORef + let maxP = maxSparkPool hecs + maxH = fromIntegral (maxYHistogram hecs) + updateYScaleArea timelineState maxP maxH Nothing labelsMode traces + return True + + ------------------------------------------------------------------------ + -- Redrawing XScaleArea + timelineXScaleArea `onExpose` \_ -> do + maybeEventArray <- readIORef hecsIORef + + -- Check to see if an event trace has been loaded + case maybeEventArray of + Nothing -> return False + Just hecs -> do + let lastTx = hecLastEventTime hecs + updateXScaleArea timelineState lastTx + return True + + ------------------------------------------------------------------------ + -- Allow mouse wheel to be used for zoom in/out + on timelineViewport scrollEvent $ tryEvent $ do + dir <- eventScrollDirection + mods <- eventModifier + (x, _y) <- eventCoordinates + x_ts <- liftIO $ viewPointToTime timelineWin x + liftIO $ case (dir,mods) of + (ScrollUp, [Control]) -> zoomIn timelineState x_ts + (ScrollDown, [Control]) -> zoomOut timelineState x_ts + (ScrollUp, []) -> vscrollUp timelineState + (ScrollDown, []) -> vscrollDown timelineState + _ -> return () + + ------------------------------------------------------------------------ + -- Mouse button and selection + + widgetSetCursor timelineDrawingArea (Just cursorIBeam) + + mouseStateVar <- newIORef None + + let withMouseState action = liftIO $ do + st <- readIORef mouseStateVar + st' <- action st + writeIORef mouseStateVar st' + + on timelineDrawingArea buttonPressEvent $ do + (x,_y) <- eventCoordinates + button <- eventButton + liftIO $ widgetGrabFocus timelineViewport + withMouseState (\st -> mousePress timelineWin actions st button x) + return False + + on timelineDrawingArea buttonReleaseEvent $ do + (x,_y) <- eventCoordinates + button <- eventButton + withMouseState (\st -> mouseRelease timelineWin actions st button x) + return False + + widgetAddEvents timelineDrawingArea [Button1MotionMask, Button2MotionMask] + on timelineDrawingArea motionNotifyEvent $ do + (x, _y) <- eventCoordinates + withMouseState (\st -> mouseMove timelineWin st x) + return False + + on timelineDrawingArea grabBrokenEvent $ do + withMouseState (mouseMoveCancel timelineWin actions) + return False + + -- Escape key to cancel selection or drag + on timelineViewport keyPressEvent $ do + let liftNoMouse a = + let whenNoMouse None = a >> return None + whenNoMouse st = return st + in withMouseState whenNoMouse >> return True + keyName <- eventKeyName + keyVal <- eventKeyVal + case (keyName, keyToChar keyVal, keyVal) of + ("Right", _, _) -> liftNoMouse $ scrollRight timelineState + ("Left", _, _) -> liftNoMouse $ scrollLeft timelineState + (_ , Just '+', _) -> liftNoMouse $ timelineZoomIn timelineWin + (_ , Just '-', _) -> liftNoMouse $ timelineZoomOut timelineWin + (_, _, 0xff1b) -> withMouseState (mouseMoveCancel timelineWin actions) + >> return True + _ -> return False + + ------------------------------------------------------------------------ + -- Scroll bars + + onValueChanged timelineAdj $ queueRedrawTimelines timelineState + onValueChanged timelineVAdj $ queueRedrawTimelines timelineState + onAdjChanged timelineAdj $ queueRedrawTimelines timelineState + onAdjChanged timelineVAdj $ queueRedrawTimelines timelineState + + ------------------------------------------------------------------------ + -- Redrawing + + on timelineDrawingArea exposeEvent $ do + exposeRegion <- eventRegion + liftIO $ do + maybeEventArray <- readIORef hecsIORef + + -- Check to see if an event trace has been loaded + case maybeEventArray of + Nothing -> return () + Just hecs -> do + params <- timelineGetViewParameters timelineWin + -- render either the whole height of the timeline, or the window, whichever + -- is larger (this just ensure we fill the background if the timeline is + -- smaller than the window). + (_, h) <- widgetGetSize timelineDrawingArea + let params' = params { height = max (height params) h } + selection <- readIORef selectionRef + bookmarks <- readIORef bookmarkIORef + + renderView timelineState params' hecs selection bookmarks exposeRegion + + return True + + on timelineDrawingArea configureEvent $ do + liftIO $ configureTimelineDrawingArea timelineWin + return True + + return timelineWin + +------------------------------------------------------------------------------- + +viewPointToTime :: TimelineView -> Double -> IO Timestamp +viewPointToTime TimelineView{timelineState=TimelineState{..}} x = do + hadjValue <- adjustmentGetValue timelineAdj + scaleValue <- readIORef scaleIORef + let ts = round (max 0 (hadjValue + x * scaleValue)) + return $! ts + +viewPointToTimeNoClamp :: TimelineView -> Double -> IO Double +viewPointToTimeNoClamp TimelineView{timelineState=TimelineState{..}} x = do + hadjValue <- adjustmentGetValue timelineAdj + scaleValue <- readIORef scaleIORef + let ts = hadjValue + x * scaleValue + return $! ts + +viewRangeToTimeRange :: TimelineView + -> (Double, Double) -> IO (Timestamp, Timestamp) +viewRangeToTimeRange view (x, x') = do + let xMin = min x x' + xMax = max x x' + xv <- viewPointToTime view xMin + xv' <- viewPointToTime view xMax + return (xv, xv') + +------------------------------------------------------------------------------- +-- Update the internal state and the timemline view after changing which +-- traces are displayed, or the order of traces. + +queueRedrawTimelines :: TimelineState -> IO () +queueRedrawTimelines TimelineState{..} = do + widgetQueueDraw timelineDrawingArea + widgetQueueDraw timelineYScaleArea + widgetQueueDraw timelineXScaleArea + +--FIXME: we are still unclear about which state changes involve which updates +timelineParamsChanged :: TimelineView -> IO () +timelineParamsChanged timelineWin@TimelineView{timelineState} = do + queueRedrawTimelines timelineState + updateTimelineVScroll timelineWin + +configureTimelineDrawingArea :: TimelineView -> IO () +configureTimelineDrawingArea timelineWin@TimelineView{timelineState} = do + updateTimelineVScroll timelineWin + updateTimelineHPageSize timelineState + +updateTimelineVScroll :: TimelineView -> IO () +updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=TimelineState{..}} = do + traces <- readIORef tracesIORef + labelsMode <- readIORef labelsModeIORef + let histTotalHeight = stdHistogramHeight + histXScaleHeight + h = calculateTotalTimelineHeight labelsMode histTotalHeight traces + (_,winh) <- widgetGetSize timelineDrawingArea + let winh' = fromIntegral winh; + h' = fromIntegral h + adjustmentSetLower timelineVAdj 0 + adjustmentSetUpper timelineVAdj h' + + val <- adjustmentGetValue timelineVAdj + when (val > h') $ adjustmentSetValue timelineVAdj h' + + set timelineVAdj [ + adjustmentPageSize := winh', + adjustmentStepIncrement := winh' * 0.1, + adjustmentPageIncrement := winh' * 0.9 + ] + +-- when the drawing area is resized, we update the page size of the +-- adjustment. Everything else stays the same: we don't scale or move +-- the view at all. +updateTimelineHPageSize :: TimelineState -> IO () +updateTimelineHPageSize TimelineState{..} = do + (winw,_) <- widgetGetSize timelineDrawingArea + scaleValue <- readIORef scaleIORef + adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue) + +------------------------------------------------------------------------------- +-- Cursor / selection and mouse interaction + +timelineSetSelection :: TimelineView -> TimeSelection -> IO () +timelineSetSelection TimelineView{..} selection = do + writeIORef selectionRef selection + queueRedrawTimelines timelineState + +-- little state machine +data MouseState = None + | PressLeft !Double -- left mouse button is currently pressed + -- but not over threshold for dragging + | DragLeft !Double -- dragging with left mouse button + | DragMiddle !Double !Double -- dragging with middle mouse button + +mousePress :: TimelineView -> TimelineViewActions + -> MouseState -> MouseButton -> Double -> IO MouseState +mousePress view@TimelineView{..} TimelineViewActions{..} state button x = + case (state, button) of + (None, LeftButton) -> do xv <- viewPointToTime view x + -- update the view without notifying the client + timelineSetSelection view (PointSelection xv) + return (PressLeft x) + (None, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorMove) + v <- adjustmentGetValue timelineAdj + return (DragMiddle x v) + _ -> return state + where + TimelineState{timelineAdj, timelineDrawingArea} = timelineState + + +mouseMove :: TimelineView -> MouseState + -> Double -> IO MouseState +mouseMove view@TimelineView{..} state x = + case state of + None -> return None + PressLeft x0 + | dragThreshold -> mouseMove view (DragLeft x0) x + | otherwise -> return (PressLeft x0) + where + dragThreshold = abs (x - x0) > 5 + DragLeft x0 -> do (xv, xv') <- viewRangeToTimeRange view (x0, x) + -- update the view without notifying the client + timelineSetSelection view (RangeSelection xv xv') + return (DragLeft x0) + DragMiddle x0 v -> do xv <- viewPointToTimeNoClamp view x + xv' <- viewPointToTimeNoClamp view x0 + scrollTo timelineState (v + (xv' - xv)) + return (DragMiddle x0 v) + + +mouseMoveCancel :: TimelineView -> TimelineViewActions + -> MouseState -> IO MouseState +mouseMoveCancel view@TimelineView{..} TimelineViewActions{..} state = + case state of + PressLeft x0 -> do xv <- viewPointToTime view x0 + timelineViewSelectionChanged (PointSelection xv) + return None + DragLeft x0 -> do xv <- viewPointToTime view x0 + timelineViewSelectionChanged (PointSelection xv) + return None + DragMiddle _ _ -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam) + return None + None -> return None + where + TimelineState{timelineDrawingArea} = timelineState + +mouseRelease :: TimelineView -> TimelineViewActions + -> MouseState -> MouseButton -> Double -> IO MouseState +mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x = + case (state, button) of + (PressLeft x0, LeftButton) -> do xv <- viewPointToTime view x0 + timelineViewSelectionChanged (PointSelection xv) + return None + (DragLeft x0, LeftButton) -> do (xv, xv') <- viewRangeToTimeRange view (x0, x) + timelineViewSelectionChanged (RangeSelection xv xv') + return None + (DragMiddle{}, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam) + return None + _ -> return state + where + TimelineState{timelineDrawingArea} = timelineState + + +widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO () +widgetSetCursor widget cursor = do +#if MIN_VERSION_gtk(0,12,1) + dw <- widgetGetDrawWindow widget + drawWindowSetCursor dw cursor +#endif + return () + +------------------------------------------------------------------------------- + +timelineZoomIn :: TimelineView -> IO () +timelineZoomIn TimelineView{..} = do + selection <- readIORef selectionRef + zoomIn timelineState (selectionPoint selection) + +timelineZoomOut :: TimelineView -> IO () +timelineZoomOut TimelineView{..} = do + selection <- readIORef selectionRef + zoomOut timelineState (selectionPoint selection) + +timelineZoomToFit :: TimelineView -> IO () +timelineZoomToFit TimelineView{..} = do + mhecs <- readIORef hecsIORef + zoomToFit timelineState mhecs + +timelineScrollLeft :: TimelineView -> IO () +timelineScrollLeft TimelineView{timelineState} = scrollLeft timelineState + +timelineScrollRight :: TimelineView -> IO () +timelineScrollRight TimelineView{timelineState} = scrollRight timelineState + +timelineScrollToBeginning :: TimelineView -> IO () +timelineScrollToBeginning TimelineView{timelineState} = + scrollToBeginning timelineState + +timelineScrollToEnd :: TimelineView -> IO () +timelineScrollToEnd TimelineView{timelineState} = + scrollToEnd timelineState + +-- This one is especially evil since it relies on a shared cursor IORef +timelineCentreOnCursor :: TimelineView -> IO () +timelineCentreOnCursor TimelineView{..} = do + selection <- readIORef selectionRef + centreOnCursor timelineState (selectionPoint selection) + +selectionPoint :: TimeSelection -> Timestamp +selectionPoint (PointSelection x) = x +selectionPoint (RangeSelection x x') = midpoint x x' + where + midpoint a b = a + (b - a) `div` 2 diff -Nru threadscope-0.1.3/GUI/TraceView.hs threadscope-0.2.1/GUI/TraceView.hs --- threadscope-0.1.3/GUI/TraceView.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/TraceView.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,183 @@ +module GUI.TraceView ( + TraceView, + traceViewNew, + TraceViewActions(..), + traceViewSetHECs, + traceViewGetTraces, + ) where + +import Events.HECs +import GUI.Types + +import Graphics.UI.Gtk +import Data.Tree + + +-- | Abstract trace view object. +-- +data TraceView = TraceView { + tracesStore :: TreeStore (Trace, Visibility) + } + +data Visibility = Visible | Hidden | MixedVisibility + deriving Eq + +-- | The actions to take in response to TraceView events. +-- +data TraceViewActions = TraceViewActions { + traceViewTracesChanged :: [Trace] -> IO () + } + +traceViewNew :: Builder -> TraceViewActions -> IO TraceView +traceViewNew builder actions = do + + tracesTreeView <- builderGetObject builder castToTreeView "traces_tree" + + tracesStore <- treeStoreNew [] + traceColumn <- treeViewColumnNew + textcell <- cellRendererTextNew + togglecell <- cellRendererToggleNew + + let traceview = TraceView {..} + + treeViewColumnPackStart traceColumn textcell True + treeViewColumnPackStart traceColumn togglecell False + treeViewAppendColumn tracesTreeView traceColumn + + treeViewSetModel tracesTreeView tracesStore + + cellLayoutSetAttributes traceColumn textcell tracesStore $ \(tr, _) -> + [ cellText := renderTrace tr ] + + cellLayoutSetAttributes traceColumn togglecell tracesStore $ \(_, vis) -> + [ cellToggleActive := vis == Visible + , cellToggleInconsistent := vis == MixedVisibility ] + + on togglecell cellToggled $ \str -> do + let path = stringToTreePath str + Node (trace, visibility) subtrees <- treeStoreGetTree tracesStore path + let visibility' = invertVisibility visibility + treeStoreSetValue tracesStore path (trace, visibility') + updateChildren tracesStore path subtrees visibility' + updateParents tracesStore (init path) + + traceViewTracesChanged actions =<< traceViewGetTraces traceview + + return traceview + + where + renderTrace (TraceHEC hec) = "HEC " ++ show hec + renderTrace (TraceInstantHEC hec) = "HEC " ++ show hec + renderTrace (TraceCreationHEC hec) = "HEC " ++ show hec + renderTrace (TraceConversionHEC hec) = "HEC " ++ show hec + renderTrace (TracePoolHEC hec) = "HEC " ++ show hec + renderTrace (TraceHistogram) = "Spark Histogram" + renderTrace (TraceGroup label) = label + renderTrace (TraceActivity) = "Activity Profile" + + updateChildren tracesStore path subtrees visibility' = + sequence_ + [ do treeStoreSetValue tracesStore path' (trace, visibility') + updateChildren tracesStore path' subtrees' visibility' + | (Node (trace, _) subtrees', n) <- zip subtrees [0..] + , let path' = path ++ [n] ] + + updateParents :: TreeStore (Trace, Visibility) -> TreePath -> IO () + updateParents _ [] = return () + updateParents tracesStore path = do + Node (trace, _) subtrees <- treeStoreGetTree tracesStore path + let visibility = accumVisibility [ vis | subtree <- subtrees + , (_, vis) <- flatten subtree ] + treeStoreSetValue tracesStore path (trace, visibility) + updateParents tracesStore (init path) + + invertVisibility Hidden = Visible + invertVisibility _ = Hidden + + accumVisibility = foldr1 (\a b -> if a == b then a else MixedVisibility) + +-- Find the HEC traces in the treeStore and replace them +traceViewSetHECs :: TraceView -> HECs -> IO () +traceViewSetHECs TraceView{tracesStore} hecs = do + treeStoreClear tracesStore + -- for testing only (e.g., to compare with histogram of data from interval + -- or to compare visually with other traces): + -- treeStoreInsert tracesStore [] 0 (TraceHistogram, Visible) + go 0 + treeStoreInsert tracesStore [] 0 (TraceActivity, Visible) + where + newT = Node { rootLabel = (TraceGroup "HEC Traces", Visible), + subForest = [ Node { rootLabel = (TraceHEC k, Visible), + subForest = [] } + | k <- [ 0 .. hecCount hecs - 1 ] ] } + newI = Node { rootLabel = (TraceGroup "Instant Events", Hidden), + subForest = [ Node { rootLabel = (TraceInstantHEC k, Hidden), + subForest = [] } + | k <- [ 0 .. hecCount hecs - 1 ] ] } + nCre = Node { rootLabel = (TraceGroup "Spark Creation", Hidden), + subForest = [ Node { rootLabel = (TraceCreationHEC k, Hidden), + subForest = [] } + | k <- [ 0 .. hecCount hecs - 1 ] ] } + nCon = Node { rootLabel = (TraceGroup "Spark Conversion", Hidden), + subForest = [ Node { rootLabel = (TraceConversionHEC k, Hidden), + subForest = [] } + | k <- [ 0 .. hecCount hecs - 1 ] ] } + nPoo = Node { rootLabel = (TraceGroup "Spark Pool", Hidden), + subForest = [ Node { rootLabel = (TracePoolHEC k, Hidden), + subForest = [] } + | k <- [ 0 .. hecCount hecs - 1 ] ] } + go n = do + m <- treeStoreLookup tracesStore [n] + case m of + Nothing -> do + treeStoreInsertTree tracesStore [] 0 nPoo + treeStoreInsertTree tracesStore [] 0 nCon + treeStoreInsertTree tracesStore [] 0 nCre + treeStoreInsertTree tracesStore [] 0 newI + treeStoreInsertTree tracesStore [] 0 newT + Just t -> + case t of + Node { rootLabel = (TraceGroup "HEC Traces", _) } -> do + treeStoreRemove tracesStore [n] + treeStoreInsertTree tracesStore [] n newT + go (n+1) + Node { rootLabel = (TraceGroup "HEC Instant Events", _) } -> do + treeStoreRemove tracesStore [n] + treeStoreInsertTree tracesStore [] n newI + go (n+1) + Node { rootLabel = (TraceGroup "Spark Creation", _) } -> do + treeStoreRemove tracesStore [n] + treeStoreInsertTree tracesStore [] n nCre + go (n+1) + Node { rootLabel = (TraceGroup "Spark Conversion", _) } -> do + treeStoreRemove tracesStore [n] + treeStoreInsertTree tracesStore [] n nCon + go (n+1) + Node { rootLabel = (TraceGroup "Spark Pool", _) } -> do + treeStoreRemove tracesStore [n] + treeStoreInsertTree tracesStore [] n nPoo + go (n+1) + Node { rootLabel = (TraceActivity, _) } -> do + treeStoreRemove tracesStore [n] + go (n+1) + _ -> + go (n+1) + +traceViewGetTraces :: TraceView -> IO [Trace] +traceViewGetTraces TraceView{tracesStore} = do + f <- getTracesStoreContents tracesStore + return [ t | (t, Visible) <- concatMap flatten f, notGroup t ] + where + notGroup (TraceGroup _) = False + notGroup _ = True + +getTracesStoreContents :: TreeStore a -> IO (Forest a) +getTracesStoreContents tracesStore = go 0 + where + go !n = do + m <- treeStoreLookup tracesStore [n] + case m of + Nothing -> return [] + Just t -> do + ts <- go (n+1) + return (t:ts) diff -Nru threadscope-0.1.3/GUI/Types.hs threadscope-0.2.1/GUI/Types.hs --- threadscope-0.1.3/GUI/Types.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/Types.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,41 @@ +module GUI.Types ( + ViewParameters(..), + Trace(..), + Timestamp, + Interval, + ) where + +import GHC.RTS.Events + +----------------------------------------------------------------------------- + +data Trace + = TraceHEC Int + | TraceInstantHEC Int + | TraceCreationHEC Int + | TraceConversionHEC Int + | TracePoolHEC Int + | TraceHistogram + | TraceGroup String + | TraceActivity + -- more later ... + -- | TraceThread ThreadId + deriving Eq + +type Interval = (Timestamp, Timestamp) + +-- the parameters for a timeline render; used to figure out whether +-- we're drawing the same thing twice. +data ViewParameters = ViewParameters { + width, height :: Int, + viewTraces :: [Trace], + hadjValue :: Double, + scaleValue :: Double, + maxSpkValue :: Double, + detail :: Int, + bwMode, labelsMode :: Bool, + histogramHeight :: Int, + minterval :: Maybe Interval, + xScaleAreaHeight :: Int + } + deriving Eq diff -Nru threadscope-0.1.3/GUI/ViewerColours.hs threadscope-0.2.1/GUI/ViewerColours.hs --- threadscope-0.1.3/GUI/ViewerColours.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/GUI/ViewerColours.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------- +--- $Id: ViewerColours.hs#2 2009/07/18 22:48:30 REDMOND\\satnams $ +--- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $ +------------------------------------------------------------------------------- + +module GUI.ViewerColours (Color, module GUI.ViewerColours) where + +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo + +------------------------------------------------------------------------------- + +-- Colours + +runningColour :: Color +runningColour = darkGreen + +gcColour :: Color +gcColour = orange + +gcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color +gcStartColour = orange +gcWorkColour = orange +gcIdleColour = white +gcEndColour = orange + +createThreadColour :: Color +createThreadColour = lightBlue + +seqGCReqColour :: Color +seqGCReqColour = cyan + +parGCReqColour :: Color +parGCReqColour = darkBlue + +migrateThreadColour :: Color +migrateThreadColour = darkRed + +threadWakeupColour :: Color +threadWakeupColour = green + +shutdownColour :: Color +shutdownColour = darkBrown + +labelTextColour :: Color +labelTextColour = black + +bookmarkColour :: Color +bookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish + +fizzledDudsColour, createdConvertedColour, overflowedColour :: Color +fizzledDudsColour = grey +createdConvertedColour = darkGreen +overflowedColour = red + +userMessageColour :: Color +userMessageColour = darkRed + +outerPercentilesColour :: Color +outerPercentilesColour = lightGrey + +------------------------------------------------------------------------------- + +black :: Color +black = Color 0 0 0 + +grey :: Color +grey = Color 0x8000 0x8000 0x8000 + +lightGrey :: Color +lightGrey = Color 0xD000 0xD000 0xD000 + +gtkBorderGrey :: Color +gtkBorderGrey = Color 0xF200 0xF100 0xF000 + +red :: Color +red = Color 0xFFFF 0 0 + +green :: Color +green = Color 0 0xFFFF 0 + +darkGreen :: Color +darkGreen = Color 0x0000 0x6600 0x0000 + +blue :: Color +blue = Color 0 0 0xFFFF + +cyan :: Color +cyan = Color 0 0xFFFF 0xFFFF + +magenta :: Color +magenta = Color 0xFFFF 0 0xFFFF + +lightBlue :: Color +lightBlue = Color 0x6600 0x9900 0xFF00 + +darkBlue :: Color +darkBlue = Color 0 0 0xBB00 + +purple :: Color +purple = Color 0x9900 0x0000 0xcc00 + +darkPurple :: Color +darkPurple = Color 0x6600 0 0x6600 + +darkRed :: Color +darkRed = Color 0xcc00 0x0000 0x0000 + +orange :: Color +orange = Color 0xE000 0x7000 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 -Nru threadscope-0.1.3/Main.hs threadscope-0.2.1/Main.hs --- threadscope-0.1.3/Main.hs 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/Main.hs 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,81 @@ +module Main where + +import GUI.Main (runGUI) + +import System.Environment +import System.Exit +import System.Console.GetOpt +import Data.Version (showVersion) +import Paths_threadscope (version) + +------------------------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + (flags, args') <- parseArgs args + handleArgs flags args' + +handleArgs :: Flags -> [String] -> IO () +handleArgs flags args + | flagHelp flags = printHelp + | flagVersion flags = printVersion + | otherwise = do + + initialTrace <- case (args, flagTest flags) of + ([filename], Nothing) -> return (Just (Left filename)) + ([], Just tracename) -> return (Just (Right tracename)) + ([], Nothing) -> return Nothing + _ -> printUsage >> exitFailure + + runGUI initialTrace + + where + printVersion = putStrLn ("ThreadScope version " ++ showVersion version) + printUsage = putStrLn usageHeader + usageHeader = "Usage: threadscope [eventlog]\n" ++ + " or: threadscope [FLAGS]" + helpHeader = usageHeader ++ "\n\nFlags: " + printHelp = putStrLn (usageInfo helpHeader flagDescrs + ++ "\nFor more details see http://www.haskell.org/haskellwiki/ThreadScope_Tour\n") + + +------------------------------------------------------------------------------- + +data Flags = Flags { + flagTest :: Maybe FilePath, + flagVersion :: Bool, + flagHelp :: Bool + } + +defaultFlags :: Flags +defaultFlags = Flags Nothing False False + +flagDescrs :: [OptDescr (Flags -> Flags)] +flagDescrs = + [ Option ['h'] ["help"] + (NoArg (\flags -> flags { flagHelp = True })) + "Show this help text" + + , Option ['v'] ["version"] + (NoArg (\flags -> flags { flagVersion = True })) + "Program version" + + , Option ['t'] ["test"] + (ReqArg (\name flags -> flags { flagTest = Just name }) "NAME") + "Load a named internal test (see Events/TestEvents.hs)" + ] + +parseArgs :: [String] -> IO (Flags, [String]) +parseArgs args + | flagHelp flags = return (flags, args') + | not (null errs) = printErrors errs + | otherwise = return (flags, args') + + where + (flags0, args', errs) = getOpt Permute flagDescrs args + flags = foldr (flip (.)) id flags0 defaultFlags + + printErrors errs = do + putStrLn $ concat errs ++ "Try --help." + exitFailure diff -Nru threadscope-0.1.3/Options.hs threadscope-0.2.1/Options.hs --- threadscope-0.1.3/Options.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Options.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -module Options -where - -------------------------------------------------------------------------------- - -data Option - = Debug - | Filename String - | TestTrace String - deriving Eq - -------------------------------------------------------------------------------- - -parseOptions :: [String] -> [Option] -parseOptions [] = [] -parseOptions ("--debug":rest) - = Debug : parseOptions rest -parseOptions ("--test":rest) - = if rest == [] then - error ("--test needs an argument") - else - TestTrace (head rest) : parseOptions (tail rest) -parseOptions (filename:rest) - = Filename filename : parseOptions rest - ------------------------------------------------------------------------------ diff -Nru threadscope-0.1.3/ReadEvents.hs threadscope-0.2.1/ReadEvents.hs --- threadscope-0.1.3/ReadEvents.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/ReadEvents.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +0,0 @@ -module ReadEvents ( - registerEventsFromFile, registerEventsFromTrace - ) where - -import EventTree -import State -import TestEvents -import EventDuration -import Timeline -import Traces -import Utils - -import Graphics.UI.Gtk hiding (on) - -import qualified GHC.RTS.Events as GHCEvents -import GHC.RTS.Events hiding (Event) - -import System.IO -import Data.Array -import qualified Data.Function -import Data.IORef -import Data.List -import Text.Printf -import System.FilePath -import Control.Monad -import Data.Function -import Control.Concurrent -import Control.Exception - -------------------------------------------------------------------------------- --- The GHC.RTS.Events library returns the profile information --- in a data-streucture which contains a list data structure --- representing the events i.e. [GHCEvents.Event] --- ThreadScope transforms this list into an alternative representation --- which (for each HEC) records event *durations* which are ordered in time. --- The durations represent the run-lengths for thread execution and --- run-lengths for garbage colleciton. This data-structure is called --- EventDuration. --- ThreadScope then transformations this data-structure into another --- data-structure which gives a binary-tree view of the event information --- by performing a binary split on the time domain i.e. the EventTree --- data structure. - --- GHCEvents.Event => [EventDuration] => EventTree - -------------------------------------------------------------------------------- - -rawEventsToHECs :: [(Maybe Int, [GHCEvents.Event])] -> Timestamp - -> [(DurationTree,EventTree)] -rawEventsToHECs eventList endTime - = map (toTree . flip lookup heclists) [0 .. maximum0 (map fst heclists)] - where - heclists = [ (h,events) | (Just h,events) <- eventList ] - - toTree Nothing = (DurationTreeEmpty, EventTree 0 0 (EventTreeLeaf [])) - toTree (Just evs) = - ( mkDurationTree (eventsToDurations nondiscrete) endTime, - mkEventTree discrete endTime ) - where (discrete,nondiscrete) = partition isDiscreteEvent evs - -------------------------------------------------------------------------------- - --- XXX: what's this for? -maximum0 :: (Num a, Ord a) => [a] -> a -maximum0 [] = -1 -maximum0 x = maximum x - -------------------------------------------------------------------------------- - -registerEventsFromFile :: String -> ViewerState -> IO () -registerEventsFromFile filename state = registerEvents (Left filename) state - -registerEventsFromTrace :: String -> ViewerState -> IO () -registerEventsFromTrace traceName state = registerEvents (Right traceName) state - -registerEvents :: Either FilePath String - -> ViewerState - -> IO () - -registerEvents from state@ViewerState{..} = do - - let msg = case from of - Left filename -> filename - Right test -> test - --- dialog <- messageDialogNew Nothing [DialogModal] MessageInfo ButtonsCancel msg - - dialog <- dialogNew - dialogAddButton dialog "gtk-cancel" ResponseCancel - widgetSetSizeRequest dialog 400 (-1) - upper <- dialogGetUpper dialog - hbox <- hBoxNew True 0 - label <- labelNew Nothing - miscSetAlignment label 0 0.5 - miscSetPadding label 20 0 - labelSetMarkup label $ - printf "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 -Nru threadscope-0.1.3/SaveAsPDF.hs threadscope-0.2.1/SaveAsPDF.hs --- threadscope-0.1.3/SaveAsPDF.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/SaveAsPDF.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -module SaveAsPDF -where - --- Imports from Haskell library -import Control.Monad -import Data.IORef - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - --- Imports for ThreadScope -import EventsWindow -import Timeline.Render -import State -import Timeline -import Traces - -------------------------------------------------------------------------------- - -saveAsPDF :: ViewerState -> IO () -saveAsPDF state@ViewerState{..} - = liftIO $ do - scaleValue <- readIORef scaleIORef - hadj_value0 <- adjustmentGetValue timelineAdj - let hadj_value = toWholePixels scaleValue hadj_value0 - mb_hecs <- readIORef hecsIORef - Just fn <- readIORef filenameIORef - case mb_hecs of - Nothing -> return () - Just hecs -> do - (w, h) <- widgetGetSize timelineDrawingArea - traces <- getViewTraces state - cursorpos <- getCursorLine state - let params = ViewParameters w h traces hadj_value scaleValue 1 False - False - let r = renderTraces state params traces hecs (Rectangle 0 0 w h) - withPDFSurface (fn++".pdf") (fromIntegral w) (fromIntegral h) (flip renderWith $ r) - return () - -------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/SaveAsPNG.hs threadscope-0.2.1/SaveAsPNG.hs --- threadscope-0.1.3/SaveAsPNG.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/SaveAsPNG.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -module SaveAsPNG -where - --- Imports from Haskell library -import Control.Monad -import Data.IORef - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - --- Imports for ThreadScope -import EventsWindow -import Timeline.Render -import State -import Timeline -import Traces - -------------------------------------------------------------------------------- - -saveAsPNG :: ViewerState -> IO () -saveAsPNG state@ViewerState{..} - = liftIO $ do - scaleValue <- readIORef scaleIORef - hadj_value0 <- adjustmentGetValue timelineAdj - let hadj_value = toWholePixels scaleValue hadj_value0 - mb_hecs <- readIORef hecsIORef - Just fn <- readIORef filenameIORef - case mb_hecs of - Nothing -> return () - Just hecs -> do - (w, h) <- widgetGetSize timelineDrawingArea - traces <- getViewTraces state - cursorpos <- getCursorLine state - let params = ViewParameters w h traces hadj_value scaleValue 1 False - False - let r = renderTraces state params traces hecs (Rectangle 0 0 w h) - withImageSurface C.FormatARGB32 (fromIntegral w) (fromIntegral h) - $ \ surface -> - do renderWith surface r - surfaceWriteToPNG surface (fn++".png") - return () - -------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/Setup.hs threadscope-0.2.1/Setup.hs --- threadscope-0.1.3/Setup.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Setup.hs 2012-01-14 02:08:07.000000000 +0000 @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain \ No newline at end of file diff -Nru threadscope-0.1.3/ShowEvents.hs threadscope-0.2.1/ShowEvents.hs --- threadscope-0.1.3/ShowEvents.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/ShowEvents.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -module Main where - -import GHC.RTS.Events -import System.Environment -import Text.Printf -import Data.List -import Data.Function - -main = do - [file] <- getArgs - - fmt <- buildFormat file - - printf "Event Types:\n" - case fmtHeader fmt of - Header (EventTypes ets) -> putStrLn (unlines (map ppEventType ets)) - - let pes = events (fmtData fmt) - sorted = sortBy (compare `on` ts) (reverse pes) - -- the events come out reversed, and we want a stable sort - - printf "Events:\n" - putStrLn $ unlines $ map ppEvent $ sorted - --- putStrLn (show $ getFirstPE dat) --- let len = length $ phaseEvents dat --- putStrLn (show $ phaseEvents dat !! (len - 3)) --- putStrLn (show $ phaseEvents dat !! (len - 2)) --- putStrLn (show $ phaseEvents dat !! (len - 1)) --- --- getFirstPE dat = head $ phaseEvents dat - -{- EOF. -} - -ppEventType :: EventType -> String -ppEventType et = printf "%4d: %s (size %d)" (etNum et) (etDesc et) (etSize et) - -ppEvent :: Event -> String -ppEvent Event{..} = - printf "%9d: cap %d: " ts (cap spec) ++ - case spec of - CreateThread{..} -> printf "creating thread %d" thread - RunThread{..} -> printf "running thread %d" thread - StopThread{..} -> printf "stopping thread %d (%s)" thread (showThreadStopStatus status) - ThreadRunnable{..} -> printf "thread %d is runnable" thread - MigrateThread{..} -> printf "migrating thread %d to cap %d" thread newCap - RunSpark{..} -> printf "running a local spark (thread %d)" thread - StealSpark{..} -> printf "thread %d stealing a spark from cap %d" thread origCap - Shutdown{..} -> printf "shutting down" - WakeupThread{..} -> printf "waking up thread %d on cap %d" thread otherCap - RequestSeqGC{..} -> printf "requesting sequential GC" - RequestParGC{..} -> printf "requesting parallel GC" - StartGC{..} -> printf "starting GC" - EndGC{..} -> printf "finished GC" - -showThreadStopStatus :: ThreadStopStatus -> String -showThreadStopStatus HeapOverflow = "heap overflow" -showThreadStopStatus StackOverflow = "stack overflow" -showThreadStopStatus ThreadYielding = "thread yielding" -showThreadStopStatus ThreadBlocked = "thread blocked" -showThreadStopStatus ThreadFinished = "thread finished" -showThreadStopStatus ForeignCall = "making a foreign call" diff -Nru threadscope-0.1.3/Sidebar.hs threadscope-0.2.1/Sidebar.hs --- threadscope-0.1.3/Sidebar.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Sidebar.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -module Sidebar ( - setupSideBar, - sidebarBookmarks, - sidebarTraces, - ) where - -import State -import Timeline - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.EventM - -import Data.IORef -import Control.Monad -import Control.Monad.Trans - --- XXX: we should be using a Model here, but not sure how to do that --- with Glade. -sidebarTraces, sidebarBookmarks :: Int -sidebarTraces = 0 -sidebarBookmarks = 1 - -setupSideBar :: ViewerState -> IO () -setupSideBar state@ViewerState{..} = do - on sidebarCloseButton buttonPressEvent $ tryEvent $ liftIO $ do - checkMenuItemSetActive sidebarToggle False - containerRemove hpaned sidebarVBox - - onToggle sidebarToggle $ do -- no new-style event for menu toggles? - b <- checkMenuItemGetActive sidebarToggle - if b - then panedAdd1 hpaned sidebarVBox - else containerRemove hpaned sidebarVBox - - on sidebarCombo changed $ do - sidebarChangeView state - - writeIORef sidebarComboState 1 - comboBoxSetActive sidebarCombo 0 - sidebarChangeView state - - traceColumn <- treeViewColumnNew --- treeViewColumnSetTitle traceColumn "Trace" - - textcell <- cellRendererTextNew - togglecell <- cellRendererToggleNew - - treeViewColumnPackStart traceColumn textcell True - treeViewColumnPackEnd traceColumn togglecell False - - cellLayoutSetAttributes traceColumn textcell tracesStore $ - \(t,bool) -> case t of - TraceGroup str -> [cellText := str] - TraceHEC n -> [cellText := show n] - TraceThread n -> [cellText := show n] - TraceActivity -> [cellText := "Activity Profile"] - - cellLayoutSetAttributes traceColumn togglecell tracesStore $ - \(str,bool) -> [cellToggleActive := bool] - - on togglecell cellToggled $ \str -> do - let p = stringToTreePath str - (str,bool) <- treeStoreGetValue tracesStore p - treeStoreSetValue tracesStore p (str, not bool) - timelineParamsChanged state - - treeViewAppendColumn tracesTreeView traceColumn - - return () - -sidebarChangeView :: ViewerState -> IO () -sidebarChangeView state@ViewerState{..} = do - r <- readIORef sidebarComboState - v <- comboBoxGetActive sidebarCombo - when (v /= r) $ do - writeIORef sidebarComboState v - case v of - _ | v == sidebarTraces -> do - containerRemove sidebarVBox bookmarkVBox - boxPackEnd sidebarVBox tracesVBox PackGrow 0 - widgetShowAll tracesVBox - - | v == sidebarBookmarks -> do - containerRemove sidebarVBox tracesVBox - boxPackEnd sidebarVBox bookmarkVBox PackGrow 0 - widgetShowAll bookmarkVBox - - _ -> - return () diff -Nru threadscope-0.1.3/State.hs threadscope-0.2.1/State.hs --- threadscope-0.1.3/State.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/State.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,125 +0,0 @@ -module State ( - ViewerState(..), - ViewParameters(..), - Trace(..), - HECs(..) - ) where - -import EventTree - -import qualified GHC.RTS.Events as GHCEvents -import GHC.RTS.Events hiding (Event) - -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo - -import Data.IORef -import Data.Array - ------------------------------------------------------------------------------ - -data ViewerState = ViewerState { - filenameIORef :: IORef (Maybe FilePath), - debug :: Bool, - - -- The loaded profile - hecsIORef :: IORef (Maybe HECs), - scaleIORef :: IORef Double, -- in ns/pixel - cursorIORef :: IORef Timestamp, - - -- WIDGETS - - -- main window - mainWindow :: Window, - statusBar :: Statusbar, - hpaned :: HPaned, - - -- menu items - bwToggle :: CheckMenuItem, - sidebarToggle :: CheckMenuItem, - openMenuItem :: MenuItem, - saveAsPDFMenuItem :: MenuItem, - saveAsPNGMenuItem :: MenuItem, - reloadMenuItem :: MenuItem, - quitMenuItem :: MenuItem, - aboutMenuItem :: MenuItem, - - -- Timeline view - timelineDrawingArea :: DrawingArea, - timelineLabelDrawingArea :: DrawingArea, - timelineKeyDrawingArea :: DrawingArea, - timelineHScrollbar :: HScrollbar, - timelineVScrollbar :: VScrollbar, - timelineAdj :: Adjustment, - timelineVAdj :: Adjustment, - zoomInButton :: ToolButton, - zoomOutButton :: ToolButton, - zoomFitButton :: ToolButton, - firstButton :: ToolButton, - lastButton :: ToolButton, - centreButton :: ToolButton, - showLabelsToggle :: ToggleToolButton, - - timelinePrevView :: IORef (Maybe (ViewParameters, Surface)), - - -- Events view - eventsFontExtents :: IORef FontExtents, - eventsCursorIORef :: IORef (Maybe (Timestamp, Int)), - eventsVScrollbar :: VScrollbar, - eventsAdj :: Adjustment, - eventsDrawingArea :: DrawingArea, - eventsTextEntry :: Entry, - eventsFindButton :: ToolButton, - eventsFirstButton :: ToolButton, - eventsHomeButton :: ToolButton, - eventsLastButton :: ToolButton, - - -- sidebar - sidebarVBox :: VBox, - sidebarHBox :: HBox, - sidebarCombo :: ComboBox, - sidebarComboState :: IORef Int, - sidebarCloseButton :: Button, - - -- Bookmarks - bookmarkVBox :: VBox, - addBookmarkButton :: ToolButton, - deleteBookmarkButton :: ToolButton, - gotoBookmarkButton :: ToolButton, - bookmarkTreeView :: TreeView, - bookmarkStore :: ListStore Timestamp, - - -- Traces - tracesVBox :: VBox, - tracesTreeView :: TreeView, - tracesStore :: TreeStore (Trace,Bool) - } - --- all the data from a .eventlog file -data HECs = HECs { - hecCount :: Int, - hecTrees :: [(DurationTree,EventTree)], - hecEventArray :: Array Int GHCEvents.CapEvent, - hecLastEventTime :: Timestamp - } - -data Trace - = TraceHEC Int - | TraceThread ThreadId - | TraceGroup String - | TraceActivity - -- more later ... - deriving Eq - --- the parameters for a timeline render; used to figure out whether --- we're drawing the same thing twice. -data ViewParameters = ViewParameters { - width, height :: Int, - viewTraces :: [Trace], - hadjValue :: Double, - scaleValue :: Double, - detail :: Int, - bwMode, labelsMode :: Bool - } - deriving Eq - diff -Nru threadscope-0.1.3/TestEvents.hs threadscope-0.2.1/TestEvents.hs --- threadscope-0.1.3/TestEvents.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/TestEvents.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,332 +0,0 @@ -module TestEvents (testTrace) -where - -import GHC.RTS.Events -import Data.Word - -------------------------------------------------------------------------------- - - -testTrace :: String -> EventLog -testTrace name = eventLog (test name) - -------------------------------------------------------------------------------- - -eventLog :: [Event] -> EventLog -eventLog events - = EventLog (Header testEventTypes) (Data events) - -------------------------------------------------------------------------------- - -create :: Word16 -create = 0 - -------------------------------------------------------------------------------- - -runThread :: Word16 -runThread = 1 - -------------------------------------------------------------------------------- - -stop :: Word16 -stop = 2 - -------------------------------------------------------------------------------- - -runnable :: Word16 -runnable = 3 - -------------------------------------------------------------------------------- - -migrate :: Word16 -migrate = 4 - -------------------------------------------------------------------------------- - -runSpark :: Word16 -runSpark = 5 - -------------------------------------------------------------------------------- - -stealSpark :: Word16 -stealSpark = 6 - -------------------------------------------------------------------------------- - -shutdown :: Word16 -shutdown = 7 - -------------------------------------------------------------------------------- - -wakeup :: Word16 -wakeup = 8 - -------------------------------------------------------------------------------- - -startGC :: Word16 -startGC = 9 - ------------------------------------------------------------------------------- - -finishGC :: Word16 -finishGC = 10 - ------------------------------------------------------------------------------- - -reqSeqGC :: Word16 -reqSeqGC = 11 - ------------------------------------------------------------------------------- - -reqParGC :: Word16 -reqParGC = 12 - ------------------------------------------------------------------------------- - -createSparkThread :: Word16 -createSparkThread = 15 - ------------------------------------------------------------------------------- - -logMessage :: Word16 -logMessage = 16 - ------------------------------------------------------------------------------- - -startup :: Word16 -startup = 17 - ------------------------------------------------------------------------------- - -blockMarker :: Word16 -blockMarker = 18 - ------------------------------------------------------------------------------- - -testEventTypes :: [EventType] -testEventTypes - = [EventType create "Create thread" (Just 8), - EventType runThread "Run thread" (Just 8), - EventType stop "Stop thread" (Just 10), - EventType runnable "Thread runnable" (Just 8), - EventType migrate "Migrate thread" (Just 10), - EventType runSpark "Run spark" (Just 8), - EventType stealSpark "Steal spark" (Just 10), - EventType shutdown "Shutdown" (Just 0), - EventType wakeup "Wakeup thread" (Just 10), - EventType startGC "Start GC" (Just 0), - EventType finishGC "Finish GC" (Just 0), - EventType reqSeqGC "Request sequetial GC" (Just 0), - EventType reqParGC "Reqpargc parallel GC" (Just 0), - EventType createSparkThread "Create spark thread" (Just 8), - EventType logMessage "Log message" Nothing, - EventType startup "Startup" (Just 0), - EventType blockMarker "Block marker" (Just 14) - ] - -------------------------------------------------------------------------------- -test :: String -> [Event] -------------------------------------------------------------------------------- - -test "empty0" - = [ - Event 0 (Startup 1) - ] - -------------------------------------------------------------------------------- - - -test "empty1" - = [ - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000 0 [] - ] - -------------------------------------------------------------------------------- - -test "test0" - = [ - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000 0 [ - Event 4000000 Shutdown - ] - ] -------------------------------------------------------------------------------- - -test "small" - = [ - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000 0 [ - Event 1000000 (CreateThread 1), - Event 2000000 (RunThread 1), - Event 3000000 (StopThread 1 ThreadFinished), - Event 4000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick" - = [-- A thread from 2s to 3s - Event 0 (Startup 3), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 2000000000 (RunThread 1), - Event 3000000000 (StopThread 1 ThreadFinished), - Event 4000000000 (Shutdown) - ], - -- A thread from 0.2ms to 0.3ms - Event 0 $ EventBlock 4000000000 1 [ - Event 1000000 (CreateThread 2), - Event 2000000 (RunThread 2), - Event 3000000 (StopThread 2 ThreadFinished), - Event 4000000 (Shutdown) - ], - -- A thread from 0.2us to 0.3us - Event 0 $ EventBlock 4000000000 2 [ - Event 1000 (CreateThread 3), - Event 2000 (RunThread 3), - Event 3000 (StopThread 3 ThreadFinished), - Event 4000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick2" - = [-- A thread create but no run - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 4000000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick3" - = [-- A thread from 2s to 3s - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 2000000000 (RunThread 1), - Event 3000000000 (StopThread 1 ThreadFinished), - Event 4000000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick4" - = [-- A test for scale values close to 1.0 - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 100 (CreateThread 1), - Event 200 (RunThread 1), - Event 300 (StopThread 1 ThreadFinished), - Event 400 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- - -test "tick5" - = [-- A thread from 2s to 3s - Event 0 (Startup 1), - Event 0 $ EventBlock 4000000000 0 [ - Event 1000000000 (CreateThread 1), - Event 2000000000 (RunThread 1), - Event 3000000000 (StopThread 1 ThreadFinished), - Event 4000000000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- --- A long tick run to check small and large tick labels - -test "tick6" = chequered 2 100 10000000 - -------------------------------------------------------------------------------- - -test "overlap" - = [-- A thread from 2s to 3s - Event 0 (Startup 1), - Event 0 $ EventBlock 3000 0 [ - Event 1000 (CreateThread 1), - Event 1100 (RunThread 1), - Event 1200 (CreateThread 2), - Event 1300 (StopThread 1 ThreadFinished), - - Event 1400 (RunThread 2), - Event 1500 (CreateThread 3), - Event 1500 (CreateThread 4), - Event 1500 (StopThread 2 ThreadFinished), - - Event 1600 (RunThread 3), - Event 1600 (CreateThread 5), - Event 1600 (StopThread 3 ThreadFinished), - - Event 1700 (RunThread 4), - Event 1700 (CreateThread 6), - Event 1800 (StopThread 4 ThreadFinished), - - Event 3000 (Shutdown) - ] - ] - -------------------------------------------------------------------------------- --- These tests are for chequered patterns to help check for rendering --- problems and also to help test the performance of scrolling etc. --- Each line has a fixed frequency of a thread running and then performing GC. --- Each successive HEC runs thread at half the frequency of the previous HEC. - -test "ch1" = chequered 1 100 100000 -test "ch2" = chequered 2 100 100000 -test "ch3" = chequered 3 100 100000 -test "ch4" = chequered 4 100 100000 -test "ch5" = chequered 5 100 100000 -test "ch6" = chequered 6 100 100000 -test "ch7" = chequered 7 100 100000 -test "ch8" = chequered 8 100 100000 - - -------------------------------------------------------------------------------- - -test _ = [] - -------------------------------------------------------------------------------- - -chequered :: ThreadId -> Timestamp -> Timestamp -> [Event] -chequered numThreads basicDuration runLength - = Event 0 (Startup (fromIntegral numThreads)) : - makeChequered 1 numThreads basicDuration runLength - -------------------------------------------------------------------------------- - -makeChequered :: ThreadId -> ThreadId -> Timestamp -> Timestamp -> [Event] -makeChequered currentThread numThreads basicDuration runLength - | currentThread > numThreads = [] -- All threads rendered -makeChequered currentThread numThreads basicDuration runLength - = Event 0 eventBlock : - makeChequered (currentThread+1) numThreads (2*basicDuration) runLength - where - eventBlock :: EventTypeSpecificInfo - eventBlock = EventBlock runLength (fromIntegral (currentThread-1)) - (Event 0 (CreateThread currentThread) - : chequeredPattern currentThread 0 basicDuration runLength) - -------------------------------------------------------------------------------- - -chequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event] -chequeredPattern currentThread currentPos basicDuration runLength - = if currentPos + 2*basicDuration > runLength then - [Event runLength (Shutdown)] - else - [Event currentPos (RunThread currentThread), - Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding), - Event (currentPos+basicDuration) StartGC, - Event (currentPos+2*basicDuration) EndGC - ] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength - -------------------------------------------------------------------------------- - diff -Nru threadscope-0.1.3/threadscope.cabal threadscope-0.2.1/threadscope.cabal --- threadscope-0.1.3/threadscope.cabal 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/threadscope.cabal 2012-01-14 02:08:07.000000000 +0000 @@ -1,75 +1,95 @@ -Name: threadscope -Version: 0.1.3 -Description: A graphical viewer for GHC eventlog traces. -License: BSD3 -License-file: LICENSE -Copyright: Released under the GHC license -Author: Donnie Jones, Simon Marlow, Satnam Singh -Maintainer: Satnam Singh -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, - containers >= 0.2 && < 0.5 - extensions: RecordWildCards, BangPatterns, PatternGuards, - CPP - Other-Modules: About, - CairoDrawing, - EventDuration, - EventTree, - EventsWindow, - FileDialog, - Options, - ReadEvents, - SaveAsPDF, - SaveAsPNG, - Setup, - ShowEvents, - Sidebar, - State, - TestEvents, - Timeline, - Traces, - Utils, - ViewerColours, - Timeline.Activity, - Timeline.HEC, - Timeline.Key, - Timeline.Motion, - Timeline.Render, - Timeline.RenderBookmarks, - Timeline.Ticks, - Timeline.WithViewScale, - Timeline.Render.Constants - - ghc-options: -Wall -fno-warn-type-defaults -fno-warn-name-shadowing - - if impl(ghc >= 7.0) - -- GHC 7.0 and later require a flag to enable the options in ghcrts.c - ghc-options: -rtsopts -fno-warn-unused-do-bind - - if impl(ghc < 6.12) - -- GHC before 6.12 gave spurious warnings for RecordWildCards - ghc-options: -fno-warn-unused-matches - - if !os(windows) - build-depends: unix >= 2.3 && < 2.5 - --- Not yet: gtk2hs doesn't support -threaded at the moment. --- ghc-options: -threaded - - c-sources: ghcrts.c - -source-repository head - type: darcs - location: http://code.haskell.org/ThreadScope/ +Name: threadscope +Version: 0.2.1 +Category: Development, Profiling, Trace +Synopsis: A graphical tool for profiling parallel Haskell programs. +Description: ThreadScope is a graphical viewer for thread profile + information generated by the Glasgow Haskell compiler + (GHC). + . + The Threadscope program allows us to debug the parallel + performance of Haskell programs. Using Threadscope we can + check to see that work is well balanced across the + available processors and spot performance issues relating + to garbage collection or poor load balancing. +License: BSD3 +License-file: LICENSE +Copyright: 2009-2010 Satnam Singh, + 2009-2011 Simon Marlow, + 2009 Donnie Jones, + 2011 Duncan Coutts, + 2011 Mikolaj Konarski + 2011 Nicolas Wu + 2011 Eric Kow +Author: Satnam Singh , + Simon Marlow , + Donnie Jones , + Duncan Coutts , + Mikolaj Konarski , + Nicolas Wu , + Eric Kow +Maintainer: Satnam Singh +Homepage: http://www.haskell.org/haskellwiki/ThreadScope +Bug-reports: http://trac.haskell.org/ThreadScope/ +Build-Type: Simple +Cabal-version: >= 1.6 +Data-files: threadscope.ui, threadscope.png + +source-repository head + type: darcs + location: http://code.haskell.org/ThreadScope/ + +Executable threadscope + Main-is: Main.hs + Build-Depends: base >= 4.0 && < 5, + gtk >= 0.12, cairo, glib, pango, + binary, array, mtl, filepath, + ghc-events == 0.4.*, + containers >= 0.2 && < 0.5, + deepseq >= 1.1, + time >= 1.1 + Extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards + Other-Modules: Events.HECs, + Events.EventDuration, + Events.EventTree, + Events.ReadEvents, + Events.SparkStats, + Events.SparkTree, + Events.TestEvents, + GUI.Main, + GUI.MainWindow, + GUI.EventsView, + GUI.Dialogs, + GUI.SaveAs, + GUI.Timeline, + GUI.Histogram, + GUI.TraceView, + GUI.BookmarkView, + GUI.KeyView, + GUI.StartupInfoView, + GUI.SummaryView, + GUI.Types, + GUI.ConcurrencyControl, + GUI.ProgressView, + GUI.ViewerColours, + GUI.Timeline.Activity, + GUI.Timeline.CairoDrawing, + GUI.Timeline.HEC, + GUI.Timeline.Motion, + GUI.Timeline.Render, + GUI.Timeline.Sparks, + GUI.Timeline.Ticks, + GUI.Timeline.Types, + GUI.Timeline.Render.Constants, + GUI.GtkExtras + + ghc-options: -Wall -fwarn-tabs + -fno-warn-type-defaults -fno-warn-name-shadowing + -fno-warn-unused-do-bind + -- Note: we do not want to use -threaded with gtk2hs. + + if impl(ghc < 6.12) + -- GHC before 6.12 gave spurious warnings for RecordWildCards + ghc-options: -fno-warn-unused-matches + + if !os(windows) + build-depends: unix >= 2.3 && < 2.6 diff -Nru threadscope-0.1.3/threadscope.glade threadscope-0.2.1/threadscope.glade --- threadscope-0.1.3/threadscope.glade 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/threadscope.glade 1970-01-01 00:00:00.000000000 +0000 @@ -1,707 +0,0 @@ - - - - - - 600 - 400 - True - ThreadScope - 1280 - 600 - - - True - vertical - 4 - - - True - - - True - _File - True - - - - - gtk-open - True - True - True - - - - - Save as PDF - True - False - - - True - gtk-save-as - 1 - - - - - - - Save as PNG - True - False - - - True - gtk-save-as - 1 - - - - - - - True - - - - - True - _Quit - True - - - - - - - - - True - _View - True - - - - - True - Sidebar - True - True - - - - - - True - Black/white - True - - - - - - True - - - - - gtk-refresh - True - True - True - - - - - - - - - - True - _Help - True - - - - - True - _About - True - - - - - - - - - False - 0 - - - - - True - True - - - True - vertical - - - True - - - True - Traces -Bookmarks - - - - 0 - - - - - True - True - False - - - True - True - Hide the sidebar - gtk-close - - - - - False - False - 1 - - - - - False - 0 - - - - - True - vertical - - - True - both-horiz - False - - - True - Add bookmark - Bookmark - True - gtk-add - - - False - True - - - - - True - Delete bookmark - gtk-delete - - - False - True - - - - - True - Jump to bookmark - gtk-jump-to - - - False - True - - - - - False - False - 0 - - - - - True - True - automatic - automatic - - - True - True - - - - - 1 - - - - - 1 - - - - - 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 -Nru threadscope-0.1.3/ThreadScope.hs threadscope-0.2.1/ThreadScope.hs --- threadscope-0.1.3/ThreadScope.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/ThreadScope.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,271 +0,0 @@ -{-# LANGUAGE CPP #-} --- ThreadScope: a graphical viewer for Haskell event log information. --- Maintainer: satnams@microsoft.com, s.singh@ieee.org - -module Main where - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Glade -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C -import Graphics.UI.Gtk.ModelView as New - --- Imports from Haskell library -import System.Environment -import Control.Monad -import Data.IORef -import Data.Maybe -import qualified Data.Function -import Data.List -#ifndef mingw32_HOST_OS -import System.Posix -#endif -import Control.Concurrent -import Control.Exception - -import Paths_threadscope - --- Imports for ThreadScope -import State -import About -import FileDialog -import Options -import ReadEvents -import EventsWindow -import Timeline -import SaveAsPDF -import SaveAsPNG -import Sidebar -import Traces - -------------------------------------------------------------------------------- - -main :: IO () -main - = do -- Deal with command line argument processing. - -- This application accepts one optional argument specifying - -- the event log. - args <- getArgs - let options = parseOptions args - - unsafeInitGUIForThreadedRTS - state <- buildInitialState options - - startup options state - -startup :: [Option] -> ViewerState -> IO () -startup options state@ViewerState{..} - = do - let - filenames = [filename | Filename filename <- options] - tracenames = [name | TestTrace name <- options] - when (length filenames > 1) - (putStrLn "usage: threadscope [eventlog_filename]") - let filename = if filenames == [] then - "" - else - head filenames - traceName = if tracenames == [] then - "" - else - head tracenames - - writeIORef filenameIORef (if filename == "" then - Nothing - else - Just filename) - - widgetSetAppPaintable mainWindow True - logoPath <- getDataFileName "threadscope.png" - windowSetIconFromFile mainWindow logoPath - - ------------------------------------------------------------------------ - -- Status bar functionality - ctx <- statusbarGetContextId statusBar "state" - statusbarPush statusBar ctx "No eventlog loaded." - - ------------------------------------------------------------------------ - --- Get the label for the name of the event log - - -- B&W toggle button - bwToggle `onToggle` timelineParamsChanged state - - -- No Labels toggle button - showLabelsToggle `onToolButtonToggled` timelineParamsChanged state - - -- When a filename for an event log is specified open and - -- parse the event log file and update the IORefs for - -- the capabilities and event array. - when (filename /= "") $ registerEventsFromFile filename state - - -- Likewise for test traces - when (traceName /= "") $ registerEventsFromTrace traceName state - - -- B&W toggle button - - -- The File:Open menu option can be used to specify an - -- eventlog file. - openMenuItem `onActivateLeaf` do - filename <- openFileDialog mainWindow - when (isJust filename) $ - registerEventsFromFile (fromJust filename) state - - ------------------------------------------------------------------------ - -- Save as PDF functionality - saveAsPDFMenuItem `onActivateLeaf` saveAsPDF state - - ------------------------------------------------------------------------ - -- Save as PNG functionality - saveAsPNGMenuItem `onActivateLeaf` saveAsPNG state - - ------------------------------------------------------------------------ - -- Reload functionality - onActivateLeaf reloadMenuItem $ - do mb_filename <- readIORef filenameIORef - case mb_filename of - Nothing -> return () - Just filename -> registerEventsFromFile filename state - - ------------------------------------------------------------------------ - -- CPUs view - - setupTimelineView state - - ------------------------------------------------------------------------ - -- Event view - - setupEventsWindow state - - ------------------------------------------------------------------------ - -- Sidebar - - setupSideBar state - - ------------------------------------------------------------------------ - -- Quit - quitMenuItem `onActivateLeaf` mainQuit - - ------------------------------------------------------------------------ - -- About dialog - aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow - - ------------------------------------------------------------------------ - -- Quit behaviour - onDestroy mainWindow mainQuit - - ------------------------------------------------------------------------ - -- Show all windows - widgetShowAll mainWindow - -#ifndef mingw32_HOST_OS - main <- myThreadId - installHandler sigINT (Catch (postGUIAsync (throw UserInterrupt))) Nothing -#endif - - ------------------------------------------------------------------------ - -- Enter main event loop for GUI. - mainGUI - -------------------------------------------------------------------------------- - -buildInitialState :: [Option] -> IO ViewerState -buildInitialState options = do - - gladePath <- getDataFileName "threadscope.glade" - Just xml <- xmlNew gladePath - - let debug = Debug `elem` options - - - filenameIORef <- newIORef Nothing - - -- IORefs are used to communicate informaiton about the eventlog - -- to the callback functions for windows, buttons etc. - capabilitiesIORef <- newIORef Nothing - hecsIORef <- newIORef Nothing - lastTxIORef <- newIORef 0 - eventArrayIORef <- newIORef (error "eventArrayIORef") - scaleIORef <- newIORef defaultScaleValue - cursorIORef <- newIORef 0 - - mainWindow <- xmlGetWidget xml castToWindow "main_window" - statusBar <- xmlGetWidget xml castToStatusbar "statusbar" - hpaned <- xmlGetWidget xml castToHPaned "hpaned" - - bwToggle <- xmlGetWidget xml castToCheckMenuItem "black_and_white" - sidebarToggle <- xmlGetWidget xml castToCheckMenuItem "view_sidebar" - openMenuItem <- xmlGetWidget xml castToMenuItem "openMenuItem" - saveAsPDFMenuItem <- xmlGetWidget xml castToMenuItem "saveAsPDFMenuItem" - saveAsPNGMenuItem <- xmlGetWidget xml castToMenuItem "saveAsPNGMenuItem" - reloadMenuItem <- xmlGetWidget xml castToMenuItem "view_reload" - quitMenuItem <- xmlGetWidget xml castToMenuItem "quitMenuItem" - aboutMenuItem <- xmlGetWidget xml castToMenuItem "aboutMenuItem" - - timelineDrawingArea <- xmlGetWidget xml castToDrawingArea - "timeline_drawingarea" - timelineLabelDrawingArea <- xmlGetWidget xml castToDrawingArea - "timeline_labels_drawingarea" - timelineKeyDrawingArea <- xmlGetWidget xml castToDrawingArea - "timeline_key_drawingarea" - timelineHScrollbar <- xmlGetWidget xml castToHScrollbar - "timeline_hscroll" - timelineVScrollbar <- xmlGetWidget xml castToVScrollbar - "timeline_vscroll" - timelineAdj <- rangeGetAdjustment timelineHScrollbar - timelineVAdj <- rangeGetAdjustment timelineVScrollbar - - timelineTraces <- newIORef [] - timelinePrevView <- newIORef Nothing - - zoomInButton <- xmlGetWidget xml castToToolButton "cpus_zoomin" - zoomOutButton <- xmlGetWidget xml castToToolButton "cpus_zoomout" - zoomFitButton <- xmlGetWidget xml castToToolButton "cpus_zoomfit" - - showLabelsToggle <- xmlGetWidget xml castToToggleToolButton "cpus_showlabels" - firstButton <- xmlGetWidget xml castToToolButton "cpus_first" - lastButton <- xmlGetWidget xml castToToolButton "cpus_last" - centreButton <- xmlGetWidget xml castToToolButton "cpus_centre" - - eventsFontExtents <- newIORef (error "eventsFontExtents") - eventsCursorIORef <- newIORef Nothing - eventsVScrollbar <- xmlGetWidget xml castToVScrollbar "eventsVScroll" - eventsAdj <- rangeGetAdjustment eventsVScrollbar - eventsDrawingArea <- xmlGetWidget xml castToDrawingArea "eventsDrawingArea" - eventsTextEntry <- xmlGetWidget xml castToEntry "events_entry" - eventsFindButton <- xmlGetWidget xml castToToolButton "events_find" - eventsFirstButton <- xmlGetWidget xml castToToolButton "events_first" - eventsHomeButton <- xmlGetWidget xml castToToolButton "events_home" - eventsLastButton <- xmlGetWidget xml castToToolButton "events_last" - - sidebarVBox <- xmlGetWidget xml castToVBox "sidebar_vbox" - sidebarHBox <- xmlGetWidget xml castToHBox "sidebar_hbox" - sidebarCombo <- xmlGetWidget xml castToComboBox "sidebar_combobox" - sidebarComboState <- newIORef sidebarBookmarks - sidebarCloseButton <- xmlGetWidget xml castToButton "sidebar_close_button" - bookmarkVBox <- xmlGetWidget xml castToVBox "bookmarks_vbox" - bookmarkTreeView <- xmlGetWidget xml castToTreeView "bookmark_list" - - -- Bookmarks - addBookmarkButton <- xmlGetWidget xml castToToolButton "add_bookmark_button" - deleteBookmarkButton <- xmlGetWidget xml castToToolButton "delete_bookmark" - gotoBookmarkButton <- xmlGetWidget xml castToToolButton "goto_bookmark_button" - bookmarkStore <- New.listStoreNew [] - New.treeViewSetModel bookmarkTreeView bookmarkStore - New.treeViewSetHeadersVisible bookmarkTreeView True - bookmarkColumn <- New.treeViewColumnNew - New.treeViewColumnSetTitle bookmarkColumn "Time" - cell <- New.cellRendererTextNew - New.treeViewColumnPackStart bookmarkColumn cell True - New.cellLayoutSetAttributes bookmarkColumn cell bookmarkStore - (\record -> [New.cellText := show record ++ " ns"]) - New.treeViewAppendColumn bookmarkTreeView bookmarkColumn - - -- Trace view - tracesVBox <- vBoxNew False 0 - tracesTreeView <- treeViewNew - tracesStore <- treeStoreNew [] - treeViewSetModel tracesTreeView tracesStore - boxPackEnd tracesVBox tracesTreeView PackGrow 0 - - return ViewerState { .. } diff -Nru threadscope-0.1.3/threadscope.ui threadscope-0.2.1/threadscope.ui --- threadscope-0.1.3/threadscope.ui 1970-01-01 00:00:00.000000000 +0000 +++ threadscope-0.2.1/threadscope.ui 2012-01-14 02:08:07.000000000 +0000 @@ -0,0 +1,1158 @@ + + + + + + + True + False + gtk-refresh + + + True + False + + + True + False + gtk-save-as + + + True + False + gtk-goto-first + + + True + False + gtk-home + + + True + False + gtk-goto-last + + + True + False + gtk-zoom-in + + + True + False + gtk-zoom-out + + + True + False + gtk-zoom-fit + + + 600 + 400 + True + ThreadScope + 1200 + 600 + + + True + False + + + True + False + + + True + False + False + _File + True + + + True + False + + + gtk-open + True + False + False + True + True + + + + + + Export image... + True + False + False + image2 + False + + + + + True + False + + + + + gtk-quit + True + False + False + True + True + + + + + + + + + + True + False + False + _View + True + + + True + False + + + True + False + False + Sidebar + True + True + + + + + True + False + False + Information pane + True + True + + + + + True + False + False + Black & white + True + + + + + True + False + False + Event labels + True + + + + + True + False + + + + + _Reload + True + False + False + True + image1 + False + + + + + + + + + + True + False + False + _Move + True + + + True + False + + + Jump to start + True + False + False + True + image4 + False + + + + + Centre on cursor + True + False + False + True + image5 + False + + + + + Jump to end + True + False + False + True + image6 + False + + + + + True + False + + + + + Zoom in + True + False + False + True + image7 + False + + + + + Zoom out + True + False + False + True + image8 + False + + + + + Fit to window + True + False + False + True + image9 + False + + + + + + + + + True + False + False + Help + True + + + True + False + + + True + False + False + Online tutorial + True + + + + + True + False + False + Website + True + + + + + True + False + False + + + + + gtk-about + True + False + False + True + True + + + + + + + + + False + True + 0 + + + + + True + False + both-horiz + False + + + True + False + Open an eventlog + False + True + gtk-open + + + False + True + + + + + True + False + + + False + + + + + True + False + Jump to the start + False + True + gtk-goto-first + + + False + True + + + + + True + False + Centre view on the cursor + False + gtk-home + + + False + True + + + + + True + False + Jump to the end + False + True + gtk-goto-last + + + False + True + + + + + True + False + + + False + + + + + True + False + Zoom in + False + gtk-zoom-in + + + False + True + + + + + True + False + Zoom out + False + gtk-zoom-out + + + False + True + + + + + True + False + Fit view to the window + False + gtk-zoom-fit + + + False + True + + + + + False + False + 1 + + + + + True + True + + + True + True + + + True + True + automatic + automatic + + + True + False + False + False + + + + + + + True + False + Key + + + 2 + False + + + + + True + True + automatic + automatic + + + True + True + False + + + + + 1 + + + + + True + False + Traces + + + 1 + False + + + + + True + False + + + True + False + both-horiz + False + + + True + False + False + True + gtk-jump-to + + + False + True + + + + + True + False + False + Bookmark + True + gtk-add + + + False + True + + + + + True + False + False + gtk-remove + + + False + True + + + + + False + False + 0 + + + + + True + True + automatic + automatic + + + True + True + False + + + + + True + True + 1 + + + + + 2 + + + + + True + False + Bookmarks + + + 2 + False + + + + + False + True + + + + + True + True + + + True + False + + + True + False + 0 + 4 + 4 + <b>Timeline</b> + True + + + False + False + 0 + + + + + True + False + 2 + 2 + 3 + 3 + + + True + False + + + 1 + 2 + GTK_SHRINK | GTK_FILL + + + + + True + False + False + 0 + + + 1 + 2 + GTK_SHRINK + + + + + True + True + True + GDK_KEY_PRESS_MASK | GDK_KEY_RELEASE_MASK | GDK_STRUCTURE_MASK + queue + + + True + False + 2 + 2 + + + 110 + True + False + + + 1 + 2 + GTK_SHRINK + + + + + 38 + True + False + + + 1 + 2 + GTK_SHRINK + + + + + True + True + + + 1 + 2 + 1 + 2 + + + + + + + + + + + + + + + True + True + 1 + + + + + True + True + + + + + True + True + + + True + True + automatic + automatic + + + True + False + + + + + True + + + + + False + True + Summary stats + + + False + + + + + True + True + automatic + automatic + + + True + False + + + True + False + 4 + 5 + 2 + 8 + 4 + + + True + False + 0 + 0 + Executable: + + + GTK_FILL + GTK_FILL + + + + + True + False + 0 + 0 + Arguments: + + + 1 + 2 + GTK_FILL + GTK_FILL + + + + + True + False + 0 + 0 + Start time: + + + 2 + 3 + GTK_FILL + GTK_FILL + + + + + True + False + 0 + 0 + RTS Id: + + + 3 + 4 + GTK_FILL + GTK_FILL + + + + + True + False + 0 + 0 + Environment: + + + 4 + 5 + GTK_FILL + GTK_FILL + + + + + True + True + The name and path of the program's executable file + 0 + 0 + True + + + 1 + 2 + GTK_FILL + + + + + True + True + The time at which the program was started + 0 + 0 + True + + + 1 + 2 + 2 + 3 + GTK_FILL + + + + + True + True + automatic + automatic + + + True + True + The arguments supplied when the program was run + False + + + + + 1 + 2 + 1 + 2 + + + + + True + True + automatic + automatic + + + True + True + The environment variables available when the program was started + False + + + + + 1 + 2 + 4 + 5 + + + + + True + True + The name and version of the compiler/runtime used by the program + 0 + 0 + True + + + 1 + 2 + 3 + 4 + GTK_FILL + + + + + + + + + 1 + + + + + True + False + Startup info + + + 1 + False + + + + + True + False + 2 + + + 110 + True + False + + + 1 + 2 + GTK_SHRINK + + + + + True + True + + + 1 + 2 + 1 + 2 + + + + + + + + + + + 2 + True + + + + + True + False + Spark sizes + + + 2 + False + + + + + True + False + + + True + True + ● + 20 + gtk-find + False + False + True + True + Search for event + + + False + True + 1 + + + + + 120 + True + False + 3 + + + True + False + queue + + + True + True + + + + + True + True + 0 + + + + + True + False + adjustment1 + + + False + True + 1 + + + + + True + True + 2 + + + + + 3 + True + + + + + True + False + Raw events + + + 3 + False + + + + + False + True + + + + + True + True + + + + + True + True + 2 + + + + + True + False + + + False + True + 3 + + + + + + + + + + + + diff -Nru threadscope-0.1.3/Timeline/Activity.hs threadscope-0.2.1/Timeline/Activity.hs --- threadscope-0.1.3/Timeline/Activity.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/Activity.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,177 +0,0 @@ -module Timeline.Activity ( - renderActivity - ) where - -import Timeline.Render.Constants - -import State -import EventTree -import EventDuration -import ViewerColours -import CairoDrawing - -import GHC.RTS.Events hiding (Event, GCWork, GCIdle) - -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - -import Control.Monad -import Data.List -import Text.Printf -import Debug.Trace - --- ToDo: --- - we average over the slice, but the point is drawn at the beginning --- of the slice rather than in the middle. - ------------------------------------------------------------------------------ - -renderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp - -> Render () - -renderActivity param@ViewParameters{..} hecs start0 end0 = do - let - slice = round (fromIntegral activity_detail * scaleValue) - - -- round the start time down, and the end time up, to a slice boundary - start = (start0 `div` slice) * slice - end = ((end0 + slice) `div` slice) * slice - - hec_profs = map (actProfile slice start end) (map fst (hecTrees hecs)) - total_prof = map sum (transpose hec_profs) - -- --- liftIO $ printf "%s\n" (show (map length hec_profs)) --- liftIO $ printf "%s\n" (show (map (take 20) hec_profs)) - drawActivity hecs start end slice total_prof - -activity_detail :: Int -activity_detail = 4 -- in pixels - --- for each timeslice, the amount of time spent in the mutator --- during that period. -actProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp] -actProfile slice start0 end0 t - = {- trace (show flat) $ -} chopped - - where - -- do an extra slice at both ends - start = if start0 < slice then start0 else start0 - slice - end = end0 + slice - - flat = flatten start t [] - chopped0 = chop 0 start flat - - chopped | start0 < slice = 0 : chopped0 - | otherwise = chopped0 - - flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree] - flatten start DurationTreeEmpty rest = rest - flatten start t@(DurationSplit s split e l r run _) rest - | e <= start = rest - | end <= s = rest - | start >= split = flatten start r rest - | end <= split = flatten start l rest - | e - s > slice = flatten start l $ flatten start r rest - | otherwise = t : rest - flatten start t@(DurationTreeLeaf d) rest - = t : rest - - chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp] - chop sofar start ts - | start >= end = if sofar > 0 then [sofar] else [] - chop sofar start [] - = sofar : chop 0 (start+slice) [] - chop sofar start (t : ts) - | e <= start - = if sofar /= 0 - then error "chop" - else chop sofar start ts - | s >= start + slice - = sofar : chop 0 (start + slice) (t : ts) - | e > start + slice - = (sofar + time_in_this_slice) : chop 0 (start + slice) (t : ts) - | otherwise - = chop (sofar + time_in_this_slice) start ts - where - (s, e) - | DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev) - | DurationSplit s _ e _ _ run _ <- t = (s, e) - - duration = min (start+slice) e - max start s - - time_in_this_slice - | DurationTreeLeaf ThreadRun{} <- t = duration - | DurationTreeLeaf _ <- t = 0 - | DurationSplit _ _ _ _ _ run _ <- t = - round (fromIntegral (run * duration) / fromIntegral (e-s)) - - -drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp] - -> Render () -drawActivity hecs start end slice ts = do - case ts of - [] -> return () - t:ts -> do --- liftIO $ printf "ts: %s\n" (show (t:ts)) --- liftIO $ printf "off: %s\n" (show (map off (t:ts) :: [Double])) - let dstart = fromIntegral start - dend = fromIntegral end - dslice = fromIntegral slice - dheight = fromIntegral activityGraphHeight - --- funky gradients don't seem to work: --- withLinearPattern 0 0 0 dheight $ \pattern -> do --- patternAddColorStopRGB pattern 0 0.8 0.8 0.8 --- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0 --- rectangle dstart 0 dend dheight --- setSource pattern --- fill - - newPath - moveTo (dstart-dslice/2) (off t) - zipWithM_ lineTo (tail [dstart-dslice/2, dstart+dslice/2 ..]) (map off ts) - setSourceRGBAhex black 1.0 - save - identityMatrix - setLineWidth 1 - strokePreserve - restore - - lineTo dend dheight - lineTo dstart dheight - setSourceRGB 0 1 0 - fill - --- funky gradients don't seem to work: --- save --- withLinearPattern 0 0 0 dheight $ \pattern -> do --- patternAddColorStopRGB pattern 0 0 1.0 0 --- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0 --- setSource pattern --- -- identityMatrix --- -- setFillRule FillRuleEvenOdd --- fillPreserve --- restore - - save - forM_ [0 .. hecCount hecs - 1] $ \h -> do - let y = fromIntegral (floor (fromIntegral h * dheight / fromIntegral (hecCount hecs))) - 0.5 - setSourceRGBAhex black 0.3 - moveTo dstart y - lineTo dend y - dashedLine1 - restore - - where - off t = fromIntegral activityGraphHeight - - fromIntegral (t * fromIntegral activityGraphHeight) / - fromIntegral (fromIntegral (hecCount hecs) * slice) - -dashedLine1 = do - save - identityMatrix - setDash [10,10] 0.0 - setLineWidth 1 - stroke - restore - diff -Nru threadscope-0.1.3/Timeline/HEC.hs threadscope-0.2.1/Timeline/HEC.hs --- threadscope-0.1.3/Timeline/HEC.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/HEC.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,253 +0,0 @@ -module Timeline.HEC ( - renderHEC - ) where - -import Timeline.Render.Constants - -import EventTree -import EventDuration -import State -import CairoDrawing -import ViewerColours - -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C -import Graphics.UI.Gtk - -import qualified GHC.RTS.Events as GHC -import GHC.RTS.Events hiding (Event, GCWork, GCIdle) - -import Control.Monad - -renderHEC :: Int -> ViewParameters - -> Timestamp -> Timestamp -> (DurationTree,EventTree) - -> Render () -renderHEC cap params@ViewParameters{..} start end (dtree,etree) = do - renderDurations cap params start end dtree - when (scaleValue < detailThreshold) $ - case etree of - EventTree ltime etime tree -> - renderEvents cap params ltime etime start end tree - -detailThreshold :: Double -detailThreshold = 3000 - -------------------------------------------------------------------------------- --- hecView draws the trace for a single HEC - -renderDurations :: Int -> ViewParameters - -> Timestamp -> Timestamp -> DurationTree - -> Render () - -renderDurations _ _ _ _ DurationTreeEmpty = return () - -renderDurations c params@ViewParameters{..} startPos endPos (DurationTreeLeaf e) - | inView startPos endPos e = drawDuration c params e - | otherwise = return () - -renderDurations !c params@ViewParameters{..} !startPos !endPos - (DurationSplit s splitTime e lhs rhs runAv gcAv) - | startPos < splitTime && endPos >= splitTime && - (fromIntegral (e - s) / scaleValue) <= fromIntegral detail - = -- View spans both left and right sub-tree. - -- trace (printf "hecView (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $ - drawAverageDuration c params s e runAv gcAv - - | otherwise - = -- trace (printf "hecView: start:%d end:%d s:%d e:%d" startPos endPos s e) $ - do when (startPos < splitTime) $ - renderDurations c params startPos endPos lhs - when (endPos >= splitTime) $ - renderDurations c params startPos endPos rhs - -------------------------------------------------------------------------------- - -renderEvents :: Int -> ViewParameters - -> Timestamp -- start time of this tree node - -> Timestamp -- end time of this tree node - -> Timestamp -> Timestamp -> EventNode - -> Render () - -renderEvents !c params@ViewParameters{..} !s !e !startPos !endPos - (EventTreeLeaf es) - = sequence_ [ drawEvent c params e - | e <- es, let t = time e, t >= startPos && t < endPos ] -renderEvents !c params@ViewParameters{..} !s !e !startPos !endPos - (EventTreeOne ev) - | t >= startPos && t < endPos = drawEvent c params ev - | otherwise = return () - where t = time ev - -renderEvents !c params@ViewParameters{..} !s !e !startPos !endPos - (EventSplit splitTime lhs rhs) - | startPos < splitTime && endPos >= splitTime && - (fromIntegral (e - s) / scaleValue) <= fromIntegral detail - = drawTooManyEvents c params s e - - | otherwise - = do when (startPos < splitTime) $ - renderEvents c params s splitTime startPos endPos lhs - when (endPos >= splitTime) $ - renderEvents c params splitTime e startPos endPos rhs - -------------------------------------------------------------------------------- --- An event is in view if it is not outside the view. - -inView :: Timestamp -> Timestamp -> EventDuration -> Bool -inView viewStart viewEnd event - = not (eStart > viewEnd || eEnd <= viewStart) - where - eStart = startTimeOf event - eEnd = endTimeOf event - -------------------------------------------------------------------------------- - -drawAverageDuration :: Int -> ViewParameters - -> Timestamp -> Timestamp -> Timestamp -> Timestamp - -> Render () -drawAverageDuration c ViewParameters{..} startTime endTime runAv gcAv - = do setSourceRGBAhex (if not bwMode then runningColour else black) 1.0 - when (runAv > 0) $ - draw_rectangle startTime hecBarOff -- x, y - (endTime - startTime) -- w - hecBarHeight - setSourceRGBAhex black 1.0 - --move_to (oxs + startTime, 0) - --relMoveTo (4/scaleValue) 13 - --unscaledText scaleValue (show nrEvents) - setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio - draw_rectangle startTime -- x - (hecBarOff+hecBarHeight) -- y - (endTime - startTime) -- w - (hecBarHeight `div` 2) -- h - - where - duration = endTime - startTime --- runRatio :: Double --- runRatio = (fromIntegral runAv) / (fromIntegral duration) - gcRatio :: Double - gcRatio = (fromIntegral gcAv) / (fromIntegral duration) - -------------------------------------------------------------------------------- - -unscaledText :: String -> Render () -unscaledText text - = do m <- getMatrix - identityMatrix - textPath text - C.fill - setMatrix m - -------------------------------------------------------------------------------- - -textWidth :: Double -> String -> Render TextExtents -textWidth _scaleValue text - = do m <- getMatrix - identityMatrix - tExtent <- textExtents text - setMatrix m - return tExtent - -------------------------------------------------------------------------------- - -drawDuration :: Int -> ViewParameters -> EventDuration -> Render () - -drawDuration c ViewParameters{..} - (ThreadRun t s startTime endTime) - = do setSourceRGBAhex (if not bwMode then runningColour else black) 1.0 - setLineWidth (1/scaleValue) - draw_rectangle_opt False - startTime -- x - hecBarOff -- y - (endTime - startTime) -- w - hecBarHeight -- h - -- Optionally label the bar with the threadID if there is room - tExtent <- textWidth scaleValue tStr - let tw = textExtentsWidth tExtent - th = textExtentsHeight tExtent - when (tw + 6 < fromIntegral rectWidth) - $ do setSourceRGBAhex labelTextColour 1.0 - move_to (fromIntegral startTime + truncate (4*scaleValue), - hecBarOff + (hecBarHeight + round th) `quot` 2) - unscaledText tStr - - -- Optionally write the reason for the thread being stopped - -- depending on the zoom value - labelAt labelsMode endTime $ - show t ++ " " ++ showThreadStopStatus s - where - rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels - tStr = show t - -drawDuration c ViewParameters{..} (GCStart startTime endTime) - = gcBar (if bwMode then black else gcStartColour) startTime endTime - -drawDuration c ViewParameters{..} (GCWork startTime endTime) - = gcBar (if bwMode then black else gcWorkColour) startTime endTime - -drawDuration c ViewParameters{..} (GCIdle startTime endTime) - = gcBar (if bwMode then black else gcIdleColour) startTime endTime - -drawDuration c ViewParameters{..} (GCEnd startTime endTime) - = gcBar (if bwMode then black else gcEndColour) startTime endTime - -gcBar :: Color -> Timestamp -> Timestamp -> Render () -gcBar col !startTime !endTime - = do setSourceRGBAhex col 1.0 - draw_rectangle_opt False - startTime -- x - (hecBarOff+hecBarHeight) -- y - (endTime - startTime) -- w - (hecBarHeight `div` 2) -- h - -labelAt :: Bool -> Timestamp -> String -> Render () -labelAt labelsMode t str - | not labelsMode = return () - | otherwise = do - setSourceRGB 0.0 0.0 0.0 - move_to (t, hecBarOff+hecBarHeight+12) - save - identityMatrix - rotate (pi/4) - textPath str - C.fill - restore - -drawEvent :: Int -> ViewParameters -> GHC.Event -> Render () -drawEvent c params@ViewParameters{..} event - = case spec event of - CreateThread{} -> renderInstantEvent params event createThreadColour - RunSpark{} -> renderInstantEvent params event runSparkColour - StealSpark{} -> renderInstantEvent params event stealSparkColour - ThreadRunnable{} -> renderInstantEvent params event threadRunnableColour - RequestSeqGC{} -> renderInstantEvent params event seqGCReqColour - RequestParGC{} -> renderInstantEvent params event parGCReqColour - MigrateThread{} -> renderInstantEvent params event migrateThreadColour - WakeupThread{} -> renderInstantEvent params event threadRunnableColour - Shutdown{} -> renderInstantEvent params event shutdownColour - - RunThread{} -> return () - StopThread{} -> return () - StartGC{} -> return () - - _ -> return () - -renderInstantEvent :: ViewParameters -> GHC.Event -> Color -> Render () -renderInstantEvent ViewParameters{..} event color = do - setSourceRGBAhex color 1.0 - setLineWidth (3 * scaleValue) - let t = time event - draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4) - labelAt labelsMode t $ showEventTypeSpecificInfo (spec event) - - -drawTooManyEvents :: Int -> ViewParameters -> Timestamp -> Timestamp - -> Render () -drawTooManyEvents c params@ViewParameters{..} start end = do - return () --- setSourceRGBAhex grey 1.0 --- setLineWidth (3 * scaleValue) --- draw_rectangle start (hecBarOff-4) (end - start) 4 --- draw_rectangle start (hecBarOff+hecBarHeight) (end - start) 4 - -------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/Timeline/Key.hs threadscope-0.2.1/Timeline/Key.hs --- threadscope-0.1.3/Timeline/Key.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/Key.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -module Timeline.Key ( updateKeyDrawingArea ) where - -import Timeline.Render.Constants - --- Imports for GTK/Glade -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.Events -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - -import ViewerColours -import CairoDrawing - -------------------------------------------------------------------------------- - -updateKeyDrawingArea :: DrawingArea -> Event -> IO Bool -updateKeyDrawingArea canvas _ - = do win <- widgetGetDrawWindow canvas - renderWithDrawable win addKeyElements - return True - -------------------------------------------------------------------------------- - -data KeyStyle = Box | Vertical - -------------------------------------------------------------------------------- - -addKeyElements :: Render () -addKeyElements - = do clearWhite - selectFontFace "sans serif" FontSlantNormal FontWeightNormal - setFontSize 12 - addKeyElements' 10 [(Box, "running", runningColour), - (Box, "GC", gcColour), - (Vertical, "create thread", createThreadColour), - (Vertical, "run spark", runSparkColour), - (Vertical, "thread runnable", threadRunnableColour), - (Vertical, "seq GC req", seqGCReqColour), - (Vertical, "par GC req", parGCReqColour), - (Vertical, "migrate thread", migrateThreadColour), - (Vertical, "thread wakeup", threadWakeupColour), - (Vertical, "shutdown", shutdownColour)] - -------------------------------------------------------------------------------- - -addKeyElements' :: Double -> [(KeyStyle, String, Color)] -> Render () -addKeyElements' position [] = return () -addKeyElements' position ((Box, keyText, keyColour):rest) - = do setSourceRGBAhex keyColour 1.0 - rectangle position 0 50 (fromIntegral (hecBarHeight `div` 2)) - C.fill - setSourceRGBA 0.0 0.0 0.0 1.0 - moveTo (position+5) 22 - textPath keyText - C.fill - tExtent <- textExtents keyText - let textW = textExtentsWidth tExtent + 10 - addKeyElements' (position + (60 `max` textW)) rest -addKeyElements' position ((Vertical, keyText, keyColour):rest) - = do setSourceRGBAhex keyColour 1.0 - setLineWidth 3.0 - moveTo position 0 - relLineTo 0 25 - C.stroke - setSourceRGBA 0.0 0.0 0.0 1.0 - moveTo (position+5) 15 - textPath keyText - C.fill - tExtent <- textExtents keyText - addKeyElements' (position + 20 + textExtentsWidth tExtent) - rest - -------------------------------------------------------------------------------- - diff -Nru threadscope-0.1.3/Timeline/Motion.hs threadscope-0.2.1/Timeline/Motion.hs --- threadscope-0.1.3/Timeline/Motion.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/Motion.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,147 +0,0 @@ -module Timeline.Motion ( - zoomIn, zoomOut, zoomToFit, - scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, centreOnCursor, - vscrollDown, vscrollUp, - queueRedrawTimelines - ) where - -import Timeline.Render.Constants -import State - -import Graphics.UI.Gtk - -import Data.Maybe -import Data.IORef -import Control.Monad --- import Text.Printf --- import Debug.Trace - -------------------------------------------------------------------------------- --- Zoom in works by expanding the current view such that the --- left hand edge of the original view remains at the same --- position and the zoom in factor is 2. --- For example, zoom into the time range 1.0 3.0 --- produces a new view with the time range 1.0 2.0 - -zoomIn :: ViewerState -> IO () -zoomIn = zoom (/2) - -zoomOut :: ViewerState -> IO () -zoomOut = zoom (*2) - -zoom :: (Double->Double) -> ViewerState -> IO () -zoom factor state@ViewerState{..} = do - scaleValue <- readIORef scaleIORef - let clampedFactor = if factor scaleValue < 1 then - id - else - factor - let newScaleValue = clampedFactor scaleValue - writeIORef scaleIORef newScaleValue - - cursor <- readIORef cursorIORef - hadj_value <- adjustmentGetValue timelineAdj - hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar - - let newPageSize = clampedFactor hadj_pagesize - adjustmentSetPageSize timelineAdj newPageSize - - let cursord = fromIntegral cursor - when (cursord >= hadj_value && cursord < hadj_value + hadj_pagesize) $ - adjustmentSetValue timelineAdj $ - cursord - clampedFactor (cursord - hadj_value) - - let pageshift = 0.9 * newPageSize - let nudge = 0.1 * newPageSize - - rangeSetIncrements timelineHScrollbar nudge pageshift - - scaleUpdateStatus state newScaleValue - queueRedrawTimelines state - -------------------------------------------------------------------------------- - -zoomToFit :: ViewerState -> IO () -zoomToFit state@ViewerState{..} = do - mb_hecs <- readIORef hecsIORef - case mb_hecs of - Nothing -> writeIORef scaleIORef (-1.0) - Just hecs -> do - let lastTx = hecLastEventTime hecs - (w, _) <- widgetGetSize timelineDrawingArea - let newScaleValue = fromIntegral lastTx / fromIntegral (w - 2*ox) - -- leave a gap of ox pixels at each end - writeIORef scaleIORef newScaleValue - - -- Configure the horizontal scrollbar units to correspond to ns. - -- leave a gap of ox pixels on the left and right of the full trace - let gap = fromIntegral ox * newScaleValue - lower = -gap - upper = fromIntegral lastTx + gap - page = upper + gap - - adjustmentSetLower timelineAdj lower - adjustmentSetValue timelineAdj lower - adjustmentSetUpper timelineAdj upper - adjustmentSetPageSize timelineAdj page - rangeSetIncrements timelineHScrollbar 0 0 - - scaleUpdateStatus state newScaleValue - queueRedrawTimelines state - -------------------------------------------------------------------------------- - -scaleUpdateStatus :: ViewerState -> Double -> IO () -scaleUpdateStatus state@ViewerState{..} newScaleValue = do - when debug $ do - ctx <- statusbarGetContextId statusBar "debug" - statusbarPush statusBar ctx ("Scale " ++ show newScaleValue) - return () - -------------------------------------------------------------------------------- - -scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, centreOnCursor - :: ViewerState -> IO () - -scrollLeft = scroll (\val page l u -> l `max` (val - page/2)) -scrollRight = scroll (\val page l u -> (u - page) `min` (val + page/2)) -scrollToBeginning = scroll (\_ _ l u -> l) -scrollToEnd = scroll (\_ _ l u -> u) - -centreOnCursor state@ViewerState{..} = do - cursor <- readIORef cursorIORef - scroll (\_ page l u -> max l (fromIntegral cursor - page/2)) state - -scroll :: (Double -> Double -> Double -> Double -> Double) - -> ViewerState -> IO () -scroll adjust state@ViewerState{..} - = do hadj_value <- adjustmentGetValue timelineAdj - hadj_pagesize <- adjustmentGetPageSize timelineAdj - hadj_lower <- adjustmentGetLower timelineAdj - hadj_upper <- adjustmentGetUpper timelineAdj - let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper - adjustmentSetValue timelineAdj newValue - adjustmentValueChanged timelineAdj - -vscrollDown, vscrollUp :: ViewerState -> IO () -vscrollDown = vscroll (\val page l u -> (u - page) `min` (val + page/8)) -vscrollUp = vscroll (\val page l u -> l `max` (val - page/8)) - -vscroll :: (Double -> Double -> Double -> Double -> Double) - -> ViewerState -> IO () -vscroll adjust state@ViewerState{..} - = do hadj_value <- adjustmentGetValue timelineVAdj - hadj_pagesize <- adjustmentGetPageSize timelineVAdj - hadj_lower <- adjustmentGetLower timelineVAdj - hadj_upper <- adjustmentGetUpper timelineVAdj - let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper - adjustmentSetValue timelineVAdj newValue - adjustmentValueChanged timelineVAdj - --- ----------------------------------------------------------------------------- - -queueRedrawTimelines :: ViewerState -> IO () -queueRedrawTimelines state = do - widgetQueueDraw (timelineDrawingArea state) - widgetQueueDraw (timelineLabelDrawingArea state) - diff -Nru threadscope-0.1.3/Timeline/Render/Constants.hs threadscope-0.2.1/Timeline/Render/Constants.hs --- threadscope-0.1.3/Timeline/Render/Constants.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/Render/Constants.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -module Timeline.Render.Constants ( - ox, oy, firstTraceY, tracePad, - hecTraceHeight, hecBarOff, hecBarHeight, hecLabelExtra, - activityGraphHeight, - ticksHeight, ticksPad - ) where - -------------------------------------------------------------------------------- - --- Origin for graph - -ox :: Int -ox = 10 - -oy :: Int -oy = 30 - --- Origin for capability bars - -firstTraceY :: Int -firstTraceY = 60 - --- Gap betweem traces in the timeline view - -tracePad :: Int -tracePad = 20 - --- HEC bar height - -hecTraceHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int - -hecTraceHeight = 40 -hecBarHeight = 20 -hecBarOff = 10 - --- extra space to allow between HECs when labels are on. --- ToDo: should be calculated somehow -hecLabelExtra = 80 - --- Activity graph - -activityGraphHeight :: Int -activityGraphHeight = 100 - --- Ticks - -ticksHeight :: Int -ticksHeight = 20 - -ticksPad :: Int -ticksPad = 20 diff -Nru threadscope-0.1.3/Timeline/RenderBookmarks.hs threadscope-0.2.1/Timeline/RenderBookmarks.hs --- threadscope-0.1.3/Timeline/RenderBookmarks.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/RenderBookmarks.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -------------------------------------------------------------------------------- --- This module implements the drawing of bookmarks in the Cario timeline --- canvas. It obtains the list of bookmarks from the list view of bookmarks --- and then renders the bookmarks in view. -------------------------------------------------------------------------------- - -module Timeline.RenderBookmarks (renderBookmarks) -where - -import Timeline.WithViewScale - -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import State -import CairoDrawing -import ViewerColours - -import GHC.RTS.Events hiding (Event) - -------------------------------------------------------------------------------- - -renderBookmarks :: ViewerState -> ViewParameters -> Render () -renderBookmarks state@ViewerState{..} params@ViewParameters{..} - = withViewScale params $ do - -- Get the list of bookmarks - bookmarkList <- liftIO $ listStoreToList bookmarkStore - -- Render the bookmarks - -- First set the line width to one pixel and set the line colour - (onePixel, _) <- deviceToUserDistance 1 0 - setLineWidth onePixel - setSourceRGBAhex bookmarkColour 1.0 - mapM_ (drawBookmark height) bookmarkList - return () - -------------------------------------------------------------------------------- - -drawBookmark :: Int -> Timestamp -> Render () -drawBookmark height bookmarkTime - = draw_line (bookmarkTime, 0) (bookmarkTime, height) - -------------------------------------------------------------------------------- - diff -Nru threadscope-0.1.3/Timeline/Render.hs threadscope-0.2.1/Timeline/Render.hs --- threadscope-0.1.3/Timeline/Render.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/Render.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,355 +0,0 @@ -module Timeline.Render ( - exposeTraceView, - renderTraces, - updateLabelDrawingArea, - calculateTotalTimelineHeight, - toWholePixels - ) where - -import Timeline.Render.Constants -import Timeline.Motion -import Timeline.Ticks -import Timeline.HEC -import Timeline.Activity -import Timeline.RenderBookmarks -import Timeline.WithViewScale - -import State -import ViewerColours -import Traces -import CairoDrawing - -import GHC.RTS.Events hiding (Event) - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.Events as Old -import Graphics.Rendering.Cairo as C -import Graphics.UI.Gtk.Gdk.GC - -import Data.Maybe -import Data.IORef -import Control.Monad -import Text.Printf - -------------------------------------------------------------------------------- --- |The 'updateProfileDrawingArea' function is called when an expose event --- occurs. This function redraws the currently visible part of the --- main trace canvas plus related canvases. - -exposeTraceView :: ViewerState -> Region -> IO () -exposeTraceView state@ViewerState{..} exposeRegion = do - maybeEventArray <- readIORef hecsIORef - - -- Check to see if an event trace has been loaded - case maybeEventArray of - Nothing -> return () - Just hecs -> renderView state exposeRegion hecs - -renderView :: ViewerState -> Region -> HECs -> IO () -renderView state@ViewerState{..} exposeRegion hecs = do - - -- Get state information from user-interface components - bw_mode <- checkMenuItemGetActive bwToggle - labels_mode <- toggleToolButtonGetActive showLabelsToggle - (dAreaWidth,dAreaHeight) <- widgetGetSize timelineDrawingArea - when debug $ do - putStrLn ("\n=== updateCanvas") - putStrLn (show exposeRegion) - printf "width %d, height %d\n" dAreaWidth dAreaHeight - - scaleValue <- checkScaleValue state - - vadj_value <- adjustmentGetValue timelineVAdj - when debug $ liftIO $ printf "vadj_value: %f\n" vadj_value - - totalHeight <- calculateTotalTimelineHeight state - let timelineHeight = max totalHeight dAreaHeight - -- render either the whole height of the timeline, or the window, whichever - -- is larger (this just ensure we fill the background if the timeline is - -- smaller than the window). - - -- snap the view to whole pixels, to avoid blurring - hadj_value0 <- adjustmentGetValue timelineAdj - let hadj_value = toWholePixels scaleValue hadj_value0 - - when debug $ do - hadj_pagesize <- adjustmentGetPageSize timelineAdj - hadj_lower <- adjustmentGetLower timelineAdj - hadj_upper <- adjustmentGetUpper timelineAdj - ctx <- statusbarGetContextId statusBar "debug" - statusbarPush statusBar ctx $ - printf "scale=%f win=(%d,%d) hadj: (val=%f, page=%f, l=%f u=%f)" - scaleValue dAreaWidth dAreaHeight - hadj_value hadj_pagesize hadj_lower hadj_upper - return () - - traces <- getViewTraces state - - let params = ViewParameters { - width = dAreaWidth, - height = timelineHeight, - viewTraces = traces, - hadjValue = hadj_value, - scaleValue = scaleValue, - detail = 3, -- for now - bwMode = bw_mode, - labelsMode = labels_mode - } - - prev_view <- readIORef timelinePrevView - cursor_t <- readIORef cursorIORef - - rect <- regionGetClipbox exposeRegion - - win <- widgetGetDrawWindow timelineDrawingArea - renderWithDrawable win $ do - - let renderToNewSurface = do - new_surface <- withTargetSurface $ \surface -> - liftIO $ createSimilarSurface surface ContentColor - dAreaWidth timelineHeight - renderWith new_surface $ do - clearWhite - renderTraces state params traces hecs rect - return new_surface - - surface <- - case prev_view of - Nothing -> do - when debug $ liftIO $ putStrLn "no old surface" - renderToNewSurface - - Just (old_params, surface) - | old_params == params - -> do when debug $ liftIO $ putStrLn "using previously rendered view" - return surface - - | width old_params == width params && - height old_params == height params - -> do - if old_params { hadjValue = hadjValue params } == params - -- only the hadjValue changed - && abs (hadjValue params - hadjValue old_params) < - fromIntegral (width params) * scaleValue - -- and the views overlap... - then do - when debug $ liftIO $ putStrLn "scrolling" - scrollView state surface old_params params traces hecs - - else do - when debug $ liftIO $ putStrLn "using old surface" - renderWith surface $ do - clearWhite; renderTraces state params traces hecs rect - return surface - - | otherwise - -> do when debug $ liftIO $ putStrLn "old surface no good" - surfaceFinish surface - renderToNewSurface - - liftIO $ writeIORef timelinePrevView (Just (params, surface)) - - region exposeRegion - clip - setSourceSurface surface 0 (-vadj_value) - -- ^^ this is where we adjust for the vertical scrollbar - setOperator OperatorSource - paint - when (scaleValue > 0) $ do - renderBookmarks state params - drawCursor cursor_t params - -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- - -drawCursor :: Timestamp -> ViewParameters -> Render () -drawCursor cursor_t param@ViewParameters{..} = do - withViewScale param $ do - (threePixels, _) <- deviceToUserDistance 3 0 - setLineWidth threePixels - setOperator OperatorOver - setSourceRGBAhex blue 1.0 - moveTo (fromIntegral cursor_t) 0 - lineTo (fromIntegral cursor_t) (fromIntegral height) - stroke - - -------------------------------------------------------------------------------- --- This function draws the current view of all the HECs with Cario - -renderTraces :: ViewerState -> ViewParameters -> [Trace] -> HECs -> Rectangle - -> Render () - -renderTraces state@ViewerState{..} params@ViewParameters{..} - traces hecs (Rectangle rx ry rw rh) - = do - let - scale_rx = fromIntegral rx * scaleValue - scale_rw = fromIntegral rw * scaleValue - scale_width = fromIntegral width * scaleValue - - startPos :: Timestamp - startPos = fromIntegral (max 0 (truncate (scale_rx + hadjValue))) - -- hadj_value might be negative, as we leave a - -- small gap before the trace starts at the beginning - - endPos :: Timestamp - endPos = minimum [ - ceiling (max 0 (hadjValue + scale_width)), - ceiling (max 0 (hadjValue + scale_rx + scale_rw)), - hecLastEventTime hecs - ] - - when debug $ liftIO $ do - printf "rx = %d, scale_rx = %f, scale_rw = %f, hadjValue = %f, startPos = %d, endPos = %d scaleValue = %f\n" rx scale_rx scale_rw hadjValue startPos endPos scaleValue - - -- Now render the timeline drawing if we have a non-empty trace - when (scaleValue > 0) $ do - withViewScale params $ do - save - -- First render the ticks and tick times - renderTicks startPos endPos scaleValue height - restore - - -- This function helps to render a single HEC... - let - renderTrace trace y = do - save - translate 0 (fromIntegral y) - case trace of - TraceHEC c -> - renderHEC c params startPos endPos (hecTrees hecs !! c) - TraceActivity -> - renderActivity params hecs startPos endPos - _ -> - return () - restore - -- Now rennder all the HECs. - zipWithM_ renderTrace traces (traceYPositions labelsMode traces) - when debug $ liftIO $ putStrLn "renderTraces done\n" - -------------------------------------------------------------------------------- - --- parameters differ only in the hadjValue, we can scroll ... -scrollView :: ViewerState -> Surface - -> ViewParameters -> ViewParameters - -> [Trace] -> HECs - -> Render Surface - -scrollView state surface old new traces hecs = do - --- scrolling on the same surface seems not to work, I get garbled results. --- Not sure what the best way to do this is. --- let new_surface = surface - new_surface <- withTargetSurface $ \surface -> - liftIO $ createSimilarSurface surface ContentColor - (width new) (height new) - - renderWith new_surface $ do - - let - scale = scaleValue new - old_hadj = hadjValue old - new_hadj = hadjValue new - w = fromIntegral (width new) - h = fromIntegral (height new) - off = (old_hadj - new_hadj) / scale - --- liftIO $ printf "scrollView: old: %f, new %f, dist = %f (%f pixels)\n" --- old_hadj new_hadj (old_hadj - new_hadj) off - - -- copy the content from the old surface to the new surface, - -- shifted by the appropriate amount. - setSourceSurface surface off 0 - if old_hadj > new_hadj - then do rectangle off 0 (w - off) h -- scroll right. - else do rectangle 0 0 (w + off) h -- scroll left. - C.fill - - let rect | old_hadj > new_hadj - = Rectangle 0 0 (ceiling off) (height new) - | otherwise - = Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new) - - case rect of - Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y) - (fromIntegral w) (fromIntegral h) - setSourceRGBA 0xffff 0xffff 0xffff 0xffff - C.fill - - renderTraces state new traces hecs rect - - surfaceFinish surface - return new_surface - ------------------------------------------------------------------------------- - -toWholePixels :: Double -> Double -> Double -toWholePixels 0 x = 0 -toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale - -------------------------------------------------------------------------------- --- This function returns a value which can be used to scale --- Timestamp event log values to pixels. --- If the scale has previous been computed then it is resued. --- An "uncomputed" scale value is represetned as -1.0 (defaultScaleValue) --- We estimate the width of the vertical scrollbar at 20 pixels - -checkScaleValue :: ViewerState -> IO Double -checkScaleValue state@ViewerState{..} - = do scaleValue <- readIORef scaleIORef - if scaleValue < 0.0 - then do zoomToFit state - readIORef scaleIORef - else return scaleValue - -------------------------------------------------------------------------------- - -updateLabelDrawingArea :: ViewerState -> Event -> IO Bool -updateLabelDrawingArea state@ViewerState{..} (Expose { Old.eventArea=rect }) - = do traces <- getViewTraces state - labels_mode <- toggleToolButtonGetActive showLabelsToggle - win <- widgetGetDrawWindow timelineLabelDrawingArea - vadj_value <- adjustmentGetValue timelineVAdj - gc <- gcNew win - let ys = map (subtract (round vadj_value)) $ - traceYPositions labels_mode traces - zipWithM_ (drawLabel timelineLabelDrawingArea gc) traces ys - return True -updateLabelDrawingArea _ _ = error "updateLabelDrawingArea" - -drawLabel :: DrawingArea -> GC -> Trace -> Int -> IO () -drawLabel canvas gc trace y - = do win <- widgetGetDrawWindow canvas - txt <- canvas `widgetCreateLayout` (showTrace trace) - drawLayoutWithColors win gc 10 y txt (Just black) Nothing - --------------------------------------------------------------------------------- - -traceYPositions :: Bool -> [Trace] -> [Int] -traceYPositions labels_mode traces - = scanl (\a b -> a + (traceHeight b) + extra + tracePad) firstTraceY traces - where - extra = if labels_mode then hecLabelExtra else 0 - - traceHeight (TraceHEC _) = hecTraceHeight - traceHeight TraceActivity = activityGraphHeight - traceHeight _ = 0 - --------------------------------------------------------------------------------- - -showTrace :: Trace -> String -showTrace (TraceHEC n) = "HEC " ++ show n -showTrace TraceActivity = "Activity" -showTrace _ = "?" - --------------------------------------------------------------------------------- - -calculateTotalTimelineHeight :: ViewerState -> IO Int -calculateTotalTimelineHeight state@ViewerState{..} = do - traces <- getViewTraces state - labels_mode <- toggleToolButtonGetActive showLabelsToggle - return $ last (traceYPositions labels_mode traces) - --------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/Timeline/Ticks.hs threadscope-0.2.1/Timeline/Ticks.hs --- threadscope-0.1.3/Timeline/Ticks.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/Ticks.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,150 +0,0 @@ -module Timeline.Ticks ( - renderTicks - ) where - -import Timeline.Render.Constants -import CairoDrawing -import ViewerColours - -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo as C - --- Imports for GHC Events -import qualified GHC.RTS.Events as GHCEvents -import GHC.RTS.Events hiding (Event) - -import Control.Monad - ---import Debug.Trace ---import Text.Printf - -------------------------------------------------------------------------------- --- Minor, semi-major and major ticks are drawn and the absolute periods of --- the ticks is determined by the zoom level. --- There are ten minor ticks to a major tick and a semi-major tick --- occurs half way through a major tick (overlapping the corresponding --- minor tick). - --- The timestamp values are in nanos-seconds (1e-9) i.e. --- a timestamp value of 1000000000 represents 1s. --- The position on the drawing canvas is in milliseconds (ms) (1e-3). - --- scaleValue is used to divide a timestamp value to yield a pixel value. - --- NOTE: the code below will crash if the timestampFor100Pixels is 0. --- The zoom factor should be controlled to ensure that this never happens. - -------------------------------------------------------------------------------- - -renderTicks :: Timestamp -> Timestamp -> Double -> Int -> Render() -renderTicks startPos endPos scaleValue height - = do - selectFontFace "sans serif" FontSlantNormal FontWeightNormal - setFontSize 12 - setSourceRGBAhex blue 1.0 - setLineWidth 1.0 - -- trace (printf "startPos: %d, endPos: %d" startPos endPos) $ do - draw_line (startPos, oy) (endPos, oy) - let - timestampFor100Pixels = truncate (100 * scaleValue) -- ns time for 100 pixels - snappedTickDuration :: Timestamp - snappedTickDuration = 10 ^ truncate (logBase 10 (fromIntegral timestampFor100Pixels) :: Double) - tickWidthInPixels :: Int - tickWidthInPixels = truncate ((fromIntegral snappedTickDuration) / scaleValue) - firstTick :: Timestamp - firstTick = snappedTickDuration * (startPos `div` snappedTickDuration) - -- liftIO $ - -- do putStrLn ("timestampFor100Pixels = " ++ show timestampFor100Pixels) - -- putStrLn ("tickWidthInPixels = " ++ show tickWidthInPixels) - -- putStrLn ("snappedTickDuration = " ++ show snappedTickDuration) - drawTicks tickWidthInPixels height scaleValue firstTick - snappedTickDuration (10*snappedTickDuration) endPos - - -drawTicks :: Int -> Int -> Double -> Timestamp -> Timestamp -> - Timestamp -> Timestamp -> Render () -drawTicks tickWidthInPixels height scaleValue pos incr majorTick endPos - = if pos <= endPos then - do setLineWidth scaleValue - draw_line (x0, y0) (x1, y1) - when (atMajorTick || atMidTick || tickWidthInPixels > 30) $ do - move_to (pos - truncate (scaleValue * 4.0), oy - 10) - m <- getMatrix - identityMatrix - tExtent <- textExtents tickTimeText - (fourPixels, _) <- deviceToUserDistance 4 0 - when (textExtentsWidth tExtent + fourPixels < fromIntegral tickWidthInPixels || atMidTick || atMajorTick) $ do - textPath tickTimeText - C.fill - setMatrix m - setSourceRGBAhex blue 0.2 - draw_line (x1, y1) (x1, height) - setSourceRGBAhex blue 1.0 - - drawTicks tickWidthInPixels height scaleValue (pos+incr) incr majorTick endPos - else - return () - where - tickTimeText = showTickTime pos - atMidTick = pos `mod` (majorTick `div` 2) == 0 - atMajorTick = pos `mod` majorTick == 0 - (x0, y0, x1, y1) = if pos `mod` majorTick == 0 then - (pos, oy, pos, oy+16) - else - if pos `mod` (majorTick `div` 2) == 0 then - (pos, oy, pos, oy+12) - else - (pos, oy, pos, oy+8) - -------------------------------------------------------------------------------- --- This display the nano-second time unit with an appropriate suffix --- depending on the actual time value. --- For times < 1e-6 the time is shown in micro-seconds. --- For times >= 1e-6 and < 0.1 seconds the time is shown in ms --- For times >= 0.5 seconds the time is shown in seconds - -showTickTime :: Timestamp -> String -showTickTime pos - = if pos == 0 then - "0s" - else - if pos < 1000000 then -- Show time as micro-seconds for times < 1e-6 - reformatMS (posf / 1000) ++ (mu ++ "s") -- microsecond (1e-6s). - else - if pos < 100000000 then -- Show miliseonds for time < 0.1s - reformatMS (posf / 1000000) ++ "ms" -- miliseconds 1e-3 - else -- Show time in seconds - reformatMS (posf / 1000000000) ++ "s" - where - posf :: Double - posf = fromIntegral pos - mu :: String --- here we assume that cairo 0.12.1 will have proper Unicode support -#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1) - -- this version of cairo doesn't handle Unicode properly. Thus, we do the - -- encoding by hand: - mu = "\194\181" -#else - mu = "\x00b5" -#endif - - -------------------------------------------------------------------------------- - -reformatMS :: Num a => a -> String -reformatMS pos - = deZero (show pos) - -------------------------------------------------------------------------------- - -deZero :: String -> String -deZero str - = if length str >= 3 && take 2 revstr == "0." then - reverse (drop 2 revstr) - else - str - where - revstr = reverse str - -------------------------------------------------------------------------------- - diff -Nru threadscope-0.1.3/Timeline/WithViewScale.hs threadscope-0.2.1/Timeline/WithViewScale.hs --- threadscope-0.1.3/Timeline/WithViewScale.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline/WithViewScale.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -module Timeline.WithViewScale -where - -import State - -import Graphics.Rendering.Cairo - -------------------------------------------------------------------------------- - -withViewScale :: ViewParameters -> Render () -> Render () -withViewScale params@ViewParameters{..} inner = do - save - scale (1/scaleValue) 1.0 - translate (-hadjValue) 0 - inner - restore - -------------------------------------------------------------------------------- diff -Nru threadscope-0.1.3/Timeline.hs threadscope-0.2.1/Timeline.hs --- threadscope-0.1.3/Timeline.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Timeline.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,182 +0,0 @@ -module Timeline ( - setupTimelineView, - renderTraces, - timelineParamsChanged, - defaultScaleValue, - queueRedrawTimelines, - setCursorToTime - ) where - -import Timeline.Motion -import Timeline.Render -import Timeline.Key - -import State -import GHC.RTS.Events - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.Events as Old hiding (eventModifier) -import Graphics.UI.Gtk.Gdk.EventM as New -import Graphics.Rendering.Cairo as C - -import Data.Maybe -import Data.IORef -import Control.Monad -import Text.Printf --- import Debug.Trace - ------------------------------------------------------------------------------ --- The CPUs view - -setupTimelineView :: ViewerState -> IO () -setupTimelineView state@ViewerState{..} = do - - ------------------------------------------------------------------------ - -- Key presses - onKeyPress mainWindow $ \Key { Old.eventKeyName = key, eventKeyChar = mch } -> do - -- when debug $ putStrLn ("key " ++ key) - case key of - "Escape" -> mainQuit >> return True - "Right" -> do scrollRight state; return True - "Left" -> do scrollLeft state; return True - _ -> if isJust mch then - case fromJust mch of - '+' -> do zoomIn state; return True - '-' -> do zoomOut state; return True - _ -> return True - else - return True - - ------------------------------------------------------------------------ - -- Porgram the callback for the capability drawingArea - timelineLabelDrawingArea `onExpose` updateLabelDrawingArea state - - ------------------------------------------------------------------------ - -- Set-up the key timelineDrawingArea. - timelineKeyDrawingArea `onExpose` updateKeyDrawingArea timelineKeyDrawingArea - - ------------------------------------------------------------------------ - -- zoom buttons - - zoomInButton `onToolButtonClicked` zoomIn state - zoomOutButton `onToolButtonClicked` zoomOut state - zoomFitButton `onToolButtonClicked` zoomToFit state - - firstButton `onToolButtonClicked` scrollToBeginning state - lastButton `onToolButtonClicked` scrollToEnd state - centreButton `onToolButtonClicked` centreOnCursor state - - ------------------------------------------------------------------------ - -- Allow mouse wheel to be used for zoom in/out - on timelineDrawingArea scrollEvent $ tryEvent $ do - dir <- eventScrollDirection - mods <- eventModifier - liftIO $ do - case (dir,mods) of - (ScrollUp, [Control]) -> zoomIn state - (ScrollDown, [Control]) -> zoomOut state - (ScrollUp, []) -> vscrollUp state - (ScrollDown, []) -> vscrollDown state - _ -> return () - - ------------------------------------------------------------------------ - -- Mouse button - - onButtonPress timelineDrawingArea $ \button -> do - when debug $ putStrLn ("button pressed: " ++ show button) - case button of - Button{ Old.eventButton = LeftButton, Old.eventClick = SingleClick, - -- eventModifier = [], -- contains [Alt2] for me - eventX = x } -> do - setCursor state x - return True - _other -> do - return False - - onValueChanged timelineAdj $ queueRedrawTimelines state - onValueChanged timelineVAdj $ queueRedrawTimelines state - - on timelineDrawingArea exposeEvent $ do - exposeRegion <- New.eventRegion - liftIO $ exposeTraceView state exposeRegion - return True - - on timelineDrawingArea configureEvent $ do - liftIO $ configureTimelineDrawingArea state - return True - - return () - -------------------------------------------------------------------------------- --- Update the internal state and the timemline view after changing which --- traces are displayed, or the order of traces. - -timelineParamsChanged :: ViewerState -> IO () -timelineParamsChanged state = do - queueRedrawTimelines state - updateTimelineVScroll state - -configureTimelineDrawingArea :: ViewerState -> IO () -configureTimelineDrawingArea state = do - updateTimelineVScroll state - updateTimelineHPageSize state - -updateTimelineVScroll :: ViewerState -> IO () -updateTimelineVScroll state@ViewerState{..} = do - h <- calculateTotalTimelineHeight state - (_,winh) <- widgetGetSize timelineDrawingArea - let winh' = fromIntegral winh; h' = fromIntegral h - adjustmentSetLower timelineVAdj 0 - adjustmentSetUpper timelineVAdj h' - - val <- adjustmentGetValue timelineVAdj - when (val > h') $ adjustmentSetValue timelineVAdj h' - - adjustmentSetPageSize timelineVAdj winh' - rangeSetIncrements timelineVScrollbar (0.1 * winh') (0.9 * winh') - --- when the drawing area is resized, we update the page size of the --- adjustment. Everything else stays the same: we don't scale or move --- the view at all. -updateTimelineHPageSize :: ViewerState -> IO () -updateTimelineHPageSize state@ViewerState{..} = do - (winw,_) <- widgetGetSize timelineDrawingArea - scaleValue <- readIORef scaleIORef - adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue) - -------------------------------------------------------------------------------- --- Set the cursor to a new position - -setCursor :: ViewerState -> Double -> IO () -setCursor state@ViewerState{..} x = do - hadjValue <- adjustmentGetValue timelineAdj - scaleValue <- readIORef scaleIORef - let cursor = round (hadjValue + x * scaleValue) - when debug $ printf "cursor set to: %d\n" cursor - writeIORef cursorIORef cursor - queueRedrawTimelines state - -------------------------------------------------------------------------------- - -setCursorToTime :: ViewerState -> Timestamp -> IO () -setCursorToTime state@ViewerState{..} x - = do hadjValue <- adjustmentGetValue timelineAdj - scaleValue <- readIORef scaleIORef - -- let cursor = round (hadjValue + x * scaleValue) - -- when debug $ printf "cursor set to: %d\n" cursor - writeIORef cursorIORef x - pageSize <- adjustmentGetPageSize timelineAdj - adjustmentSetValue timelineAdj ((fromIntegral x - pageSize/2) `max` 0) - queueRedrawTimelines state - -------------------------------------------------------------------------------- - - --- This scale value is used to map a micro-second value to a pixel unit. --- To convert a timestamp value to a pixel value, multiply it by scale. --- To convert a pixel value to a micro-second value, divide it by scale. --- A negative value means the scale value to be computed to fit the --- trace to the display. - -defaultScaleValue :: Double -defaultScaleValue = -1.0 diff -Nru threadscope-0.1.3/Traces.hs threadscope-0.2.1/Traces.hs --- threadscope-0.1.3/Traces.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Traces.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -module Traces ( - newHECs, - getViewTraces - ) where - -import State - -import Graphics.UI.Gtk -import Data.Tree - --- Find the HEC traces in the treeStore and replace them -newHECs :: ViewerState -> HECs -> IO () -newHECs state@ViewerState{..} hecs = do - go 0 - treeStoreInsert tracesStore [] 0 (TraceActivity, True) - where - newt = Node { rootLabel = (TraceGroup "HECs", True), - subForest = [ Node { rootLabel = (TraceHEC n, True), - subForest = [] } - | n <- [ 0 .. hecCount hecs - 1 ] ] } - - go n = do - m <- treeStoreLookup tracesStore [n] - case m of - Nothing -> treeStoreInsertTree tracesStore [] 0 newt - Just t -> - case t of - Node { rootLabel = (TraceGroup "HECs", _) } -> do - treeStoreRemove tracesStore [n] - treeStoreInsertTree tracesStore [] n newt - Node { rootLabel = (TraceActivity, _) } -> do - treeStoreRemove tracesStore [n] - go (n+1) - _ -> - go (n+1) - -getViewTraces :: ViewerState -> IO [Trace] -getViewTraces state@ViewerState{..} = do - f <- getTracesStoreContents state - return [ t | (t, True) <- concatMap flatten f, notGroup t ] - where - notGroup (TraceGroup _) = False - notGroup other = True - -getTracesStoreContents :: ViewerState -> IO (Forest (Trace,Bool)) -getTracesStoreContents ViewerState{..} = go 0 - where - go !n = do - m <- treeStoreLookup tracesStore [n] - case m of - Nothing -> return [] - Just t -> do - ts <- go (n+1) - return (t:ts) - diff -Nru threadscope-0.1.3/Utils.hs threadscope-0.2.1/Utils.hs --- threadscope-0.1.3/Utils.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/Utils.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -module Utils ( withBackgroundProcessing ) where - -import Graphics.UI.Gtk -import Control.Exception -import Control.Concurrent - --- Causes the gtk main loop to yield to other Haskell threads whenever --- it is idle. This should be used only when there is --- compute-intensive activity going on in other threads. -withBackgroundProcessing :: IO a -> IO a -withBackgroundProcessing f = - bracket - (idleAdd (yield >> return True) priorityDefaultIdle) - idleRemove - (\_ -> f) diff -Nru threadscope-0.1.3/ViewerColours.hs threadscope-0.2.1/ViewerColours.hs --- threadscope-0.1.3/ViewerColours.hs 2011-04-04 16:25:04.000000000 +0000 +++ threadscope-0.2.1/ViewerColours.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,122 +0,0 @@ -------------------------------------------------------------------------------- ---- $Id: ViewerColours.hs#2 2009/07/18 22:48:30 REDMOND\\satnams $ ---- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $ -------------------------------------------------------------------------------- - -module ViewerColours where - -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo - -------------------------------------------------------------------------------- - --- Colours - -runningColour :: Color -runningColour = green - -gcColour :: Color -gcColour = orange - -gcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color -gcStartColour = orange -gcWorkColour = green -gcIdleColour = white -gcEndColour = orange - -createThreadColour :: Color -createThreadColour = lightBlue - -runSparkColour :: Color -runSparkColour = darkBlue - -stealSparkColour :: Color -stealSparkColour = magenta - -threadRunnableColour :: Color -threadRunnableColour = darkGreen - -seqGCReqColour :: Color -seqGCReqColour = cyan - -parGCReqColour :: Color -parGCReqColour = darkBlue - -migrateThreadColour :: Color -migrateThreadColour = darkRed - -threadWakeupColour :: Color -threadWakeupColour = purple - -shutdownColour :: Color -shutdownColour = darkBrown - -labelTextColour :: Color -labelTextColour = black - -bookmarkColour :: Color -bookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish - -------------------------------------------------------------------------------- - -black :: Color -black = Color 0 0 0 - -grey :: Color -grey = Color 0x8000 0x8000 0x8000 - -green :: Color -green = Color 0 0xFFFF 0 - -darkGreen :: Color -darkGreen = Color 0x0000 0x6600 0x0000 - -blue :: Color -blue = Color 0 0 0xFFFF - -cyan :: Color -cyan = Color 0 0xFFFF 0xFFFF - -magenta :: Color -magenta = Color 0xFFFF 0 0xFFFF - -lightBlue :: Color -lightBlue = Color 0x6600 0x9900 0xFF00 - -darkBlue :: Color -darkBlue = Color 0 0 0xBB00 - -purple :: Color -purple = Color 0x9900 0x0000 0xcc00 - -darkPurple :: Color -darkPurple = Color 0x6600 0 0x6600 - -darkRed :: Color -darkRed = Color 0xcc00 0x0000 0x0000 - -orange :: Color -orange = Color 0xFFFF 0x9900 0x0000 -- orange - -profileBackground :: Color -profileBackground = Color 0xFFFF 0xFFFF 0xFFFF - -tickColour :: Color -tickColour = Color 0x3333 0x3333 0xFFFF - -darkBrown :: Color -darkBrown = Color 0x6600 0 0 - -yellow :: Color -yellow = Color 0xff00 0xff00 0x3300 - -white :: Color -white = Color 0xffff 0xffff 0xffff - -------------------------------------------------------------------------------- -setSourceRGBAhex :: Color -> Double -> Render () -setSourceRGBAhex (Color r g b) t - = setSourceRGBA (fromIntegral r/0xFFFF) (fromIntegral g/0xFFFF) - (fromIntegral b/0xFFFF) t - --------------------------------------------------------------------------------