threadscope-0.2.6/0000755000000000000000000000000012435266473012222 5ustar0000000000000000threadscope-0.2.6/Main.hs0000644000000000000000000000452312435266473013446 0ustar0000000000000000module 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 threadscope-0.2.6/threadscope.png0000644000000000000000000001235612435266473015240 0ustar0000000000000000PNG  IHDR:ߗ pHYs.#.#x?vtEXtSoftwareAdobe ImageReadyqe<{IDATx]=r8"|:P:`r.;94XN91Tc9¾y%#L qq^DžJk/_?_|=_ |]F|؟9MڌN/B2~`O1*#lKrJ! W(ÁsJJWJ,9w`@إ J \E#?'B2 Wc1=5р\0RaK*mWvj1xr$mtmҧ$Kg IGzl ɐި6{OUgFYA:u(>uR:$Ռ1jZ"^L޳8ʚc {9kIOP{Q2]0 *ш J4b`@ F=JA04!ƞAzQ+eإzkX ⤡Fh.l{"0gu@\E25TUk褪HX` 줋HY` .oAX2 Õ) %#:'58)%״Qd5#\dW " AV#BeZ]7$ؒ ҕ0ZE/wÒdhagA {=HMń`hLS8b-v,RӒ <ҳ|U$,3>5@=!'}ߡ=)ɰBܰ5|ȉXX[X3o Hzs$JȕD=llZb=q#Fة|9!Q\91T(5m[ζ?GرW6{^6m:OgN؛7H{ƾy;R3؋]$sMY;{1ҭ>béDcdd> Q0=}1f1W78둪no~&}t>XRC|IDuV5&٥:zv5Gr\9c8Y_cC4dž Hs6$C]]U{r6#6=wԝd`8R/8 t\ G"vduOG&R2v΁zcCF@~-Xս2$yσbPԓ.ٙ"6odjֻݙd)SUj5oEά/lę GLZ;Թa t4ӡE|v=G\I0 ?3lXGG0m#[1bwm#o8 'lUA{ЅGXL6(-खX8`Uqw1J~VRƐ)mwLB =܀!/~˚dP̖$g(b2{HF^b‡KMu+DNLA lȉ\E!v־ n-L&vn-[ y.{A=U7r"S4$lq:`gv{q:즯=a^qdʄ7ԃmM}inG)l5P/m1E!:Z娮= (K?c_ZOIK@GpZa!ZWYP{~žhKb\V>#ۂ= V)sGM=:[أ'ٞ'pb A,'>o=Q:vL KkrE^mZ\S!}MR )1{?xk|sMH .ݺ#ckg_b4LXE>x~o$%zsGn~:Q$p5XM`, m^G3 Q{N ۣI'äl^x*.Z4e( Lg5آDcQ+Ð+([rwG1TU 5c'z7Y(zx&qw^:th-vG|Hኝd\iNj \ǎdCjQǨyd  #cص1A1R"4G$dD+) 2䨓!v$!!šhV&S;6Q?;. pCmV0qgC[&"1X6}dA U ȶKc8"|ľa9_&%DPD\6D".]=N*(]ZbA>k];^@ Mjb'Ei2 v D~7ld/ rs*'^Tm], Simon Marlow , Donnie Jones , Duncan Coutts , Mikolaj Konarski , Nicolas Wu , Eric Kow Maintainer: Simon Marlow Homepage: http://www.haskell.org/haskellwiki/ThreadScope Bug-reports: https://github.com/haskell/ThreadScope/issues Build-Type: Simple Cabal-version: >= 1.6 Data-files: threadscope.ui, threadscope.png source-repository head type: git location: git@github.com:haskell/ThreadScope.git 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.2, containers >= 0.2 && < 0.6, deepseq >= 1.1, text, 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 -rtsopts -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.8 threadscope-0.2.6/Setup.hs0000644000000000000000000000005512435266473013656 0ustar0000000000000000import Distribution.Simple main = defaultMainthreadscope-0.2.6/threadscope.ui0000644000000000000000000031675212435266473015100 0ustar0000000000000000 True gtk-refresh True gtk-save-as True gtk-goto-first True gtk-home True gtk-goto-last True gtk-zoom-in True gtk-zoom-out True gtk-zoom-fit 600 400 True ThreadScope 1200 600 True True True _File True True gtk-open True True True Export image... True image2 False True gtk-quit True True True True _View True True True Sidebar True True True Information pane True True True Black & white True True Event labels True True _Reload True True image1 False True _Move True True Jump to start True True image4 False Centre on cursor True True image5 False Jump to end True True image6 False True Zoom in True True image7 False Zoom out True True image8 False Fit to window True True image9 False True Help True True True Online tutorial True True Website True True gtk-about True True True False True 0 True both-horiz False True Open an eventlog True gtk-open False True True False True Jump to the start True gtk-goto-first False True True Centre view on the cursor gtk-home False True True Jump to the end True gtk-goto-last False True True False True Zoom in gtk-zoom-in False True True Zoom out gtk-zoom-out False True True Fit view to the window gtk-zoom-fit False True False False 1 True True True True sidepane True True automatic automatic True False False True True Key 2 False True True automatic automatic True True False 1 True True Traces 1 False True True both-horiz False True True gtk-jump-to False True True Bookmark True gtk-add False True True gtk-remove False True False False 0 True True automatic automatic True True False True True 1 2 True True Bookmarks 2 False False True True True True True 0 4 4 <b>Timeline</b> True False False 0 True 2 2 3 3 True 1 2 GTK_SHRINK | GTK_FILL True False 0 1 2 GTK_SHRINK True True True GDK_KEY_PRESS_MASK | GDK_KEY_RELEASE_MASK | GDK_STRUCTURE_MASK queue True 2 2 110 True 1 2 GTK_SHRINK 38 True 1 2 GTK_SHRINK True True 1 2 1 2 True True 1 True True True True infopane True True automatic automatic True queue True 8 4 2 8 4 True 0 0 Total time: GTK_FILL GTK_FILL True 0 0 Mutator time: 1 2 GTK_FILL GTK_FILL True 0 0 GC time: 2 3 GTK_FILL GTK_FILL True True 0 0 True 1 2 GTK_FILL True True 0 0 True 1 2 2 3 GTK_FILL True True 0 0 True 1 2 1 2 GTK_FILL True 0 0 Productivity: 3 4 GTK_FILL GTK_FILL True True 0 0 True 1 2 3 4 GTK_FILL True True The time spent executing code vs doing GC (for the full run or the selected time period) Time False True True automatic automatic True queue True 8 5 5 8 4 True 0 0 Maximum heap size: GTK_FILL GTK_FILL True 0 0 Maximum heap residency: 1 2 GTK_FILL GTK_FILL True 0 0 Total allocated: 2 3 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 2 3 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 1 2 GTK_FILL GTK_FILL True 0 0 Allocation rate: 3 4 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 3 4 GTK_FILL GTK_FILL True 0 0 Maximum slop: 4 5 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 4 5 GTK_FILL GTK_FILL True 0 0 3 2 3 GTK_FILL GTK_FILL True 0 0 3 2 3 1 2 GTK_FILL GTK_FILL True 0 0 3 2 3 2 3 GTK_FILL GTK_FILL True 0 0 5 2 3 3 4 GTK_FILL GTK_FILL True 0 0 3 2 3 4 5 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 1 2 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 2 3 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 3 4 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 4 5 GTK_FILL GTK_FILL True 0 0 4 5 GTK_FILL True 0 0 4 5 1 2 GTK_FILL GTK_FILL True 0 0 4 5 4 5 GTK_FILL GTK_FILL True 0 0 4 5 3 4 GTK_FILL GTK_FILL True 0 0 4 5 2 3 GTK_FILL GTK_FILL 1 True True Summary statistics about the heap (for the full run or the selected time period) Heap 1 False True True automatic automatic True queue True 8 3 2 8 4 True 0 0 Copied during GC: GTK_FILL GTK_FILL True 0 0 Parallel GC work balance: 1 2 GTK_FILL GTK_FILL True True 0 0 True 1 2 1 2 GTK_FILL True True automatic automatic True True False 2 2 3 True 4 True True 0 0 True False True 0 True True 0 0 False True 1 True True 1 0 True 18 False True 2 True True 0 0 False True 3 1 2 GTK_FILL 2 True True Garbage collector statistics (for the full run or the selected time period) GC 2 False True True automatic automatic True True 3 True True Counts of how many sparks were created, converted etc (for the full run or the selected time period) Spark stats 3 False True 2 110 True 1 2 GTK_SHRINK True True 1 2 1 2 4 True True A histogram of how long each spark took to evaluate, either for the whole program or the selected time period. Spark sizes 4 False True True automatic automatic True True 8 5 2 8 4 True 0 0 Executable: GTK_FILL GTK_FILL True 0 0 Arguments: 1 2 GTK_FILL GTK_FILL True 0 0 Start time: 2 3 GTK_FILL GTK_FILL True 0 0 RTS Id: 3 4 GTK_FILL GTK_FILL True 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 5 True True Information about the program run including program name and command line arguments. Process info 5 False True True True ● 20 gtk-find Search for event False True 1 120 True 3 True queue True True True True 0 True adjustment1 False True 1 True True 2 6 True True The raw events from the eventlog. The selection is synchronised with the timeline. Raw events 6 False False True True True True True 2 True False True 3 threadscope-0.2.6/GUI/0000755000000000000000000000000012435266473012646 5ustar0000000000000000threadscope-0.2.6/GUI/ViewerColours.hs0000644000000000000000000000573312435266473016022 0ustar0000000000000000------------------------------------------------------------------------------- --- $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 = white 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 ------------------------------------------------------------------------------- threadscope-0.2.6/GUI/Types.hs0000644000000000000000000000167112435266473014313 0ustar0000000000000000module 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 threadscope-0.2.6/GUI/Timeline.hs0000644000000000000000000004613112435266473014755 0ustar0000000000000000{-# 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 ( liftIO ) import Data.IORef import Control.Monad import qualified Data.Text as T ----------------------------------------------------------------------------- -- 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 #if MIN_VERSION_gtk(0,13,0) case (T.unpack keyName, keyToChar keyVal, keyVal) of #else case (keyName, keyToChar keyVal, keyVal) of #endif ("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 threadscope-0.2.6/GUI/EventsView.hs0000644000000000000000000003006212435266473015302 0ustar0000000000000000{-# LANGUAGE CPP #-} 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 qualified Data.Text as T 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 #if MIN_VERSION_gtk(0,13,0) case T.unpack key of #else case key of #endif "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 threadscope-0.2.6/GUI/Dialogs.hs0000644000000000000000000001316612435266473014573 0ustar0000000000000000module 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 threadscope-0.2.6/GUI/Main.hs0000644000000000000000000003652412435266473014100 0ustar0000000000000000{-# 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 :: SummaryView, 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) _ = -- We have to draw this ASAP, before the user manages to move -- the mouse away from the window, or the window is left -- in a partially drawn state. ConcurrencyControl.fullSpeed concCtl $ 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' -- We set user 'traceMarker' events as initial bookmarks. let usrMarkers = extractUserMarkers hecs bookmarkViewClear bookmarkView sequence_ [ bookmarkViewAdd bookmarkView ts label | (ts, label) <- usrMarkers ] timelineWindowSetBookmarks timelineWin (map fst usrMarkers) 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 summaryViewSetInterval summaryView 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)) summaryViewSetInterval summaryView (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). -- -- Unfortunately it halts drawing of the loaded events if the user -- manages to move the mouse away from the window during the delay. -- 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 threadscope-0.2.6/GUI/Histogram.hs0000644000000000000000000001106712435266473015144 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} 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 qualified Graphics.Rendering.Cairo as C import Graphics.UI.Gtk 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 writeIORef mintervalIORef Nothing -- the old interval may make no sense 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 (_ :: String) <- 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{..} threadscope-0.2.6/GUI/BookmarkView.hs0000644000000000000000000001044112435266473015602 0ustar0000000000000000module 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{..} threadscope-0.2.6/GUI/SummaryView.hs0000644000000000000000000011531212435266473015475 0ustar0000000000000000module GUI.SummaryView ( SummaryView, summaryViewNew, summaryViewSetEvents, summaryViewSetInterval, ) where import GHC.RTS.Events import GUI.Types import Graphics.UI.Gtk import Control.Exception (assert) import Control.Monad import Data.Array import qualified Data.IntMap as IM import Data.IORef import Data.List as L import Data.Maybe import Data.Word (Word64) import Numeric (showFFloat) import Text.Printf ------------------------------------------------------------------------------ type Events = Array Int CapEvent data SummaryView = SummaryView { -- we cache the stats for the whole interval cacheEventsStats :: !(IORef (Maybe (Events, SummaryStats, Bool))) -- widgets for time stuff , labelTimeTotal :: Label , labelTimeMutator :: Label , labelTimeGC :: Label , labelTimeProductivity :: Label -- widgets for heap stuff , labelHeapMaxSize , labelHeapMaxResidency , labelHeapAllocTotal , labelHeapAllocRate , labelHeapMaxSlop :: (Label, Label, Label, Label) , tableHeap :: Widget -- widgets for GC stuff , labelGcCopied :: (Label, Label, Label, Label) , labelGcParWorkBalance :: Label , storeGcStats :: ListStore GcStatsEntry , tableGc :: Widget -- widgets for sparks stuff , storeSparkStats :: ListStore (Cap, SparkCounts) } ------------------------------------------------------------------------------ summaryViewNew :: Builder -> IO SummaryView summaryViewNew builder = do cacheEventsStats <- newIORef Nothing let getWidget cast = builderGetObject builder cast getLabel = getWidget castToLabel getHeapLabels w1 w2 w3 w4 = liftM4 (,,,) (getLabel w1) (getLabel w2) (getLabel w3) (getLabel w4) labelTimeTotal <- getWidget castToLabel "labelTimeTotal" labelTimeMutator <- getWidget castToLabel "labelTimeMutator" labelTimeGC <- getWidget castToLabel "labelTimeGC" labelTimeProductivity <- getWidget castToLabel "labelTimeProductivity" labelHeapMaxSize <- getHeapLabels "labelHeapMaxSize" "labelHeapMaxSizeUnit" "labelHeapMaxSizeBytes" "labelHeapMaxSizeUnit1" labelHeapMaxResidency <- getHeapLabels "labelHeapMaxResidency" "labelHeapMaxResidencyUnit" "labelHeapMaxResidencyBytes" "labelHeapMaxResidencyUnit1" labelHeapAllocTotal <- getHeapLabels "labelHeapAllocTotal" "labelHeapAllocTotalUnit" "labelHeapAllocTotalBytes" "labelHeapAllocTotalUnit1" labelHeapAllocRate <- getHeapLabels "labelHeapAllocRate" "labelHeapAllocRateUnit" "labelHeapAllocRateBytes" "labelHeapAllocRateUnit1" labelHeapMaxSlop <- getHeapLabels "labelHeapMaxSlop" "labelHeapMaxSlopUnit" "labelHeapMaxSlopBytes" "labelHeapMaxSlopUnit1" tableHeap <- getWidget castToWidget "tableHeap" labelGcCopied <- getHeapLabels "labelGcCopied" "labelGcCopiedUnit" "labelGcCopiedBytes" "labelGcCopiedUnit1" labelGcParWorkBalance <- getWidget castToLabel "labelGcParWorkBalance" storeGcStats <- listStoreNew [] tableGc <- getWidget castToWidget "tableGC" storeSparkStats <- listStoreNew [] let summaryView = SummaryView{..} treeviewGcStats <- getWidget castToTreeView "treeviewGcStats" treeViewSetModel treeviewGcStats storeGcStats let addGcColumn = addColumn treeviewGcStats storeGcStats addGcColumn "Generation" $ \(GcStatsEntry gen _ _ _ _ _) -> [ cellText := if gen == -1 then "GC Total" else "Gen " ++ show gen ] addGcColumn "Collections" $ \(GcStatsEntry _ colls _ _ _ _) -> [ cellText := show colls ] addGcColumn "Par collections" $ \(GcStatsEntry _ _ pcolls _ _ _) -> [ cellText := show pcolls ] addGcColumn "Elapsed time" $ \(GcStatsEntry _ _ _ time _ _) -> [ cellText := (printf "%5.2fs" (timeToSecondsDbl time) :: String) ] addGcColumn "Avg pause" $ \(GcStatsEntry _ _ _ _ avgpause _) -> [ cellText := (printf "%3.4fs" avgpause :: String) ] addGcColumn "Max pause" $ \(GcStatsEntry _ _ _ _ _ maxpause) -> [ cellText := (printf "%3.4fs" maxpause :: String) ] treeviewSparkStats <- getWidget castToTreeView "treeviewSparkStats" treeViewSetModel treeviewSparkStats storeSparkStats let addSparksColumn = addColumn treeviewSparkStats storeSparkStats addSparksColumn "HEC" $ \(hec, _) -> [ cellText := if hec == -1 then "Total" else "HEC " ++ show hec ] addSparksColumn "Total" $ \(_, SparkCounts total _ _ _ _ _) -> [ cellText := show total ] addSparksColumn "Converted" $ \(_, SparkCounts _ conv _ _ _ _) -> [ cellText := show conv ] addSparksColumn "Overflowed" $ \(_, SparkCounts _ _ ovf _ _ _) -> [ cellText := show ovf ] addSparksColumn "Dud" $ \(_, SparkCounts _ _ _ dud _ _) -> [ cellText := show dud ] addSparksColumn "GC'd" $ \(_, SparkCounts _ _ _ _ gc _) -> [ cellText := show gc ] addSparksColumn "Fizzled" $ \(_, SparkCounts _ _ _ _ _ fiz) -> [ cellText := show fiz ] return summaryView where addColumn view store title mkAttrs = do col <- treeViewColumnNew cell <- cellRendererTextNew treeViewColumnSetTitle col title treeViewColumnPackStart col cell False treeViewAppendColumn view col cellLayoutSetAttributes col cell store mkAttrs ------------------------------------------------------------------------------ summaryViewSetEvents :: SummaryView -> Maybe (Array Int CapEvent) -> IO () summaryViewSetEvents view@SummaryView{cacheEventsStats} Nothing = do writeIORef cacheEventsStats Nothing setSummaryStatsEmpty view summaryViewSetEvents view@SummaryView{cacheEventsStats} (Just events) = do let stats = summaryStats events Nothing -- this is an almost certain indicator that there -- are no heap events in the eventlog: hasHeapEvents = heapMaxSize (summHeapStats stats) /= Just 0 writeIORef cacheEventsStats (Just (events, stats, hasHeapEvents)) setSummaryStats view stats hasHeapEvents summaryViewSetInterval :: SummaryView -> Maybe Interval -> IO () summaryViewSetInterval view@SummaryView{cacheEventsStats} Nothing = do cache <- readIORef cacheEventsStats case cache of Nothing -> return () Just (_, stats, hasHeap) -> setSummaryStats view stats hasHeap summaryViewSetInterval view@SummaryView{cacheEventsStats} (Just interval) = do cache <- readIORef cacheEventsStats case cache of Nothing -> return () Just (events, _, hasHeap) -> setSummaryStats view stats hasHeap where stats = summaryStats events (Just interval) ------------------------------------------------------------------------------ setSummaryStats :: SummaryView -> SummaryStats -> Bool -> IO () setSummaryStats view SummaryStats{..} hasHeapEvents = do setTimeStats view summTimeStats if hasHeapEvents then do setHeapStatsAvailable view True setHeapStats view summHeapStats setGcStats view summGcStats else setHeapStatsAvailable view False setSparkStats view summSparkStats setTimeStats :: SummaryView -> TimeStats -> IO () setTimeStats SummaryView{..} TimeStats{..} = mapM_ (\(label, text) -> set label [ labelText := text ]) [ (labelTimeTotal , showFFloat (Just 2) (timeToSecondsDbl timeTotal) "s") , (labelTimeMutator , showFFloat (Just 2) (timeToSecondsDbl timeMutator) "s") , (labelTimeGC , showFFloat (Just 2) (timeToSecondsDbl timeGC) "s") , (labelTimeProductivity, showFFloat (Just 1) (timeProductivity * 100) "% of mutator vs total") ] setHeapStats :: SummaryView -> HeapStats -> IO () setHeapStats SummaryView{..} HeapStats{..} = do setHeapStatLabels labelHeapMaxSize heapMaxSize "" "" setHeapStatLabels labelHeapMaxResidency heapMaxResidency "" "" setHeapStatLabels labelHeapAllocTotal heapTotalAlloc "" "" setHeapStatLabels labelHeapAllocRate heapAllocRate "/s" " per second (of mutator time)" setHeapStatLabels labelHeapMaxSlop heapMaxSlop "" "" setHeapStatLabels labelGcCopied heapCopiedDuringGc "" "" where setHeapStatLabels labels stat unitSuffix unitSuffixLong = let texts = case stat of Nothing -> ("N/A", "", "", "") Just b -> ( formatBytesInUnit b u, formatUnit u ++ unitSuffix , formatBytes b, "bytes" ++ unitSuffixLong) where u = getByteUnit b in setLabels labels texts setLabels (short,shortunit,long,longunit) (short', shortunit', long', longunit') = do mapM_ (\(label, text) -> set label [ labelText := text ]) [ (short, short'), (shortunit, shortunit') , (long, long'), (longunit, longunit') ] setGcStats :: SummaryView -> GcStats -> IO () setGcStats SummaryView{..} GcStats{..} = do let balText = maybe "N/A" (printf "%.2f%% (serial 0%%, perfect 100%%)") gcParWorkBalance set labelGcParWorkBalance [ labelText := balText ] listStoreClear storeGcStats mapM_ (listStoreAppend storeGcStats) (gcTotalStats:gcGenStats) setSparkStats :: SummaryView -> SparkStats -> IO () setSparkStats SummaryView{..} SparkStats{..} = do listStoreClear storeSparkStats mapM_ (listStoreAppend storeSparkStats) ((-1,totalSparkStats):capSparkStats) data ByteUnit = TiB | GiB | MiB | KiB | B deriving Show byteUnitVal :: ByteUnit -> Word64 byteUnitVal TiB = 2^40 byteUnitVal GiB = 2^30 byteUnitVal MiB = 2^20 byteUnitVal KiB = 2^10 byteUnitVal B = 1 getByteUnit :: Word64 -> ByteUnit getByteUnit b | b >= 2^40 = TiB | b >= 2^30 = GiB | b >= 2^20 = MiB | b >= 2^10 = KiB | otherwise = B formatBytesInUnit :: Word64 -> ByteUnit -> String formatBytesInUnit n u = formatFixed (fromIntegral n / fromIntegral (byteUnitVal u)) where formatFixed x = showFFloat (Just 1) x "" formatUnit :: ByteUnit -> String formatUnit = show formatBytes :: Word64 -> String formatBytes b = ppWithCommas b ppWithCommas :: Word64 -> String ppWithCommas = let spl [] = [] spl l = let (c3, cs) = L.splitAt 3 l in c3 : spl cs in L.reverse . L.intercalate "," . spl . L.reverse . show setSummaryStatsEmpty :: SummaryView -> IO () setSummaryStatsEmpty SummaryView{..} = do mapM_ (\label -> set label [ labelText := "" , widgetTooltipText := (Nothing :: Maybe String) ]) $ [ labelTimeTotal, labelTimeMutator , labelTimeGC, labelTimeProductivity ] ++ [ w | (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency , labelHeapAllocTotal, labelHeapAllocRate , labelHeapMaxSlop, labelGcCopied ] , w <- [ a,b,c,d] ] listStoreClear storeGcStats listStoreClear storeSparkStats setHeapStatsAvailable :: SummaryView -> Bool -> IO () setHeapStatsAvailable SummaryView{..} available | available = do forM_ unavailableWidgets $ \widget -> set widget [ widgetTooltipText := (Nothing :: Maybe String) , widgetSensitive := True ] | otherwise = do forM_ allLabels $ \label -> set label [ labelText := "" ] listStoreClear storeGcStats forM_ unavailableLabels $ \label -> set label [ labelText := "(unavailable)" ] forM_ unavailableWidgets $ \widget -> set widget [ widgetTooltipText := Just msgInfoUnavailable, widgetSensitive := False ] where allLabels = [ labelTimeMutator, labelTimeGC , labelTimeProductivity, labelGcParWorkBalance ] ++ [ w | (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency , labelHeapAllocTotal, labelHeapAllocRate , labelHeapMaxSlop, labelGcCopied ] , w <- [ a,b,c,d] ] unavailableLabels = [ labelTimeMutator, labelTimeGC , labelTimeProductivity, labelGcParWorkBalance , case labelGcCopied of (w,_,_,_) -> w ] ++ [ c | (_,_,c,_) <- [ labelHeapMaxSize, labelHeapMaxResidency , labelHeapAllocTotal, labelHeapAllocRate , labelHeapMaxSlop ] ] unavailableWidgets = [ toWidget labelTimeMutator, toWidget labelTimeGC , toWidget labelTimeProductivity , tableHeap, tableGc ] msgInfoUnavailable = "This eventlog does not contain heap or GC information." ------------------------------------------------------------------------------ -- Calculating the stats we want to display -- data SummaryStats = SummaryStats { summTimeStats :: TimeStats, summHeapStats :: HeapStats, summGcStats :: GcStats, summSparkStats :: SparkStats } data TimeStats = TimeStats { timeTotal :: !Word64, -- we really should have a better type for elapsed time timeGC :: !Word64, timeMutator :: !Word64, timeProductivity :: !Double } data HeapStats = HeapStats { heapMaxSize :: Maybe Word64, heapMaxResidency :: Maybe Word64, heapMaxSlop :: Maybe Word64, heapTotalAlloc :: Maybe Word64, heapAllocRate :: Maybe Word64, heapCopiedDuringGc :: Maybe Word64 } data GcStats = GcStats { gcNumThreads :: !Int, gcParWorkBalance :: !(Maybe Double), gcGenStats :: [GcStatsEntry], gcTotalStats :: !GcStatsEntry } data GcStatsEntry = GcStatsEntry !Int !Int !Int !Word64 !Double !Double data SparkStats = SparkStats { capSparkStats :: [(Cap, SparkCounts)], totalSparkStats :: !SparkCounts } data SparkCounts = SparkCounts !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 -- | Take the events, and optionally some sub-range, and generate the summary -- stats for that range. -- -- We take a two-step approach: -- * a single pass over the events, accumulating into an intermediate -- 'StatsAccum' record, -- * then look at that 'StatsAccum' record and construct the various final -- stats that we want to present. -- summaryStats :: Array Int CapEvent -> Maybe Interval -> SummaryStats summaryStats events minterval = SummaryStats { summHeapStats = hs, summGcStats = gs, summSparkStats = ss, summTimeStats = ts } where !statsAccum = accumStats events minterval gs = gcStats statsAccum ss = sparkStats statsAccum ts = timeStats events minterval gs hs = heapStats statsAccum ts -- | Linearly accumulate the stats from the events array, -- either the full thing or some sub-range. accumStats :: Array Int CapEvent -> Maybe Interval -> StatsAccum accumStats events minterval = foldl' accumEvent start [ events ! i | i <- range eventsRange ] where eventsRange = selectEventRange events minterval -- If we're starting from time zero then we know many of the stats -- also start at from, where as from other points it's just unknown start | fst eventsRange == 0 = zeroStatsAccum | otherwise = emptyStatsAccum -- | Given the event array and a time interval, return the range of array -- indicies containing that interval. The Nothing interval means to select -- the whole array range. -- selectEventRange :: Array Int CapEvent -> Maybe Interval -> (Int, Int) selectEventRange arr Nothing = bounds arr selectEventRange arr (Just (start, end)) = (lbound, ubound) where !lbound = either snd id $ findArrayRange cmp arr start !ubound = either fst id $ findArrayRange cmp arr end cmp ts (CapEvent _ (Event ts' _)) = compare ts ts' findArrayRange :: (key -> val -> Ordering) -> Array Int val -> key -> Either (Int,Int) Int findArrayRange cmp arr key = binarySearch a0 b0 key where (a0,b0) = bounds arr binarySearch a b key | a > b = Left (b,a) | otherwise = case cmp key (arr ! mid) of LT -> binarySearch a (mid-1) key EQ -> Right mid GT -> binarySearch (mid+1) b key where mid = (a + b) `div` 2 ------------------------------------------------------------------------------ -- Final step where we convert from StatsAccum to various presentation forms timeStats :: Array Int CapEvent -> Maybe Interval -> GcStats -> TimeStats timeStats events minterval GcStats { gcTotalStats = GcStatsEntry _ _ _ timeGC _ _ } = TimeStats {..} where timeTotal = intervalEnd - intervalStart timeMutator = timeTotal - timeGC timeProductivity = timeToSecondsDbl timeMutator / timeToSecondsDbl timeTotal (intervalStart, intervalEnd) = case minterval of Just (s,e) -> (s, e) Nothing -> (0, timeOf (events ! ub)) where (_lb, ub) = bounds events timeOf (CapEvent _ (Event t _)) = t heapStats :: StatsAccum -> TimeStats -> HeapStats heapStats StatsAccum{..} TimeStats{timeMutator} = HeapStats { heapMaxSize = dmaxMemory, heapMaxResidency = dmaxResidency, heapMaxSlop = dmaxSlop, heapTotalAlloc = if totalAlloc == 0 then Nothing else Just totalAlloc, heapAllocRate = if timeMutator == 0 || totalAlloc == 0 then Nothing else Just $ truncate (fromIntegral totalAlloc / timeToSecondsDbl timeMutator), heapCopiedDuringGc = if dcopied == Just 0 then Nothing else dcopied } where totalAlloc = sum [ end - start | (end,start) <- IM.elems dallocTable ] gcStats :: StatsAccum -> GcStats gcStats StatsAccum{..} = GcStats { gcNumThreads = nThreads, gcParWorkBalance, gcGenStats = [ mkGcStatsEntry gen (gcGather gen) | gen <- gens ], gcTotalStats = mkGcStatsEntry gcGenTot (gcGather gcGenTot) } where nThreads = fromMaybe 1 dmaxParNThreads gcParWorkBalance | nThreads <= 1 || fromMaybe 0 dparMaxCopied <= 0 = Nothing | otherwise = Just $ 100 * ((maybe 0 fromIntegral dparTotCopied / maybe 0 fromIntegral dparMaxCopied) - 1) / (fromIntegral nThreads - 1) gens = [0..maxGeneration] where -- Does not work for generationless GCs, but works reasonably -- for > 2 gens and perfectly for 2 gens. maxGeneration = maximum $ 1 : [ maxGen | RtsGC { gcGenStat } <- IM.elems dGCTable , not (IM.null gcGenStat) , let (maxGen, _) = IM.findMax gcGenStat ] gcGather :: Gen -> GenStat gcGather gen = gcSum gen $ map gcGenStat $ IM.elems dGCTable -- TODO: Consider per-HEC display of GC stats and then use -- the values summed over all generations at key gcGenTot at each cap. gcSum :: Gen -> [IM.IntMap GenStat] -> GenStat gcSum gen l = GenStat (sumPr gcAll) (sumPr gcPar) (gcElapsed mainGen) (gcMaxPause mainGen) where l_genGC = map (IM.findWithDefault emptyGenStat gen) l sumPr proj = sum $ map proj l_genGC _maxPr proj = L.maximum $ map proj l_genGC _minPr proj = L.minimum $ filter (> 0) $ map proj l_genGC -- This would be the most balanced way of aggregating gcElapsed, -- if only the event times were accurate. _avgPr proj = let vs = filter (> 0) $ map proj l_genGC in sum vs `div` fromIntegral (length vs) -- But since the times include scheduling noise, -- we only use the times from the main cap for each GC -- and so get readings almost identical to +RTS -s. mainGen = IM.findWithDefault emptyGenStat gen mainStat mainStat = gcGenStat (fromMaybe (defaultGC 0) dGCMain) mkGcStatsEntry :: Gen -> GenStat -> GcStatsEntry mkGcStatsEntry gen GenStat{..} = GcStatsEntry gen gcAll gcPar gcElapsedS gcAvgPauseS gcMaxPauseS where gcElapsedS = gcElapsed gcMaxPauseS = timeToSecondsDbl gcMaxPause gcAvgPauseS | gcAll == 0 = 0 | otherwise = timeToSeconds $ fromIntegral gcElapsed / fromIntegral gcAll sparkStats :: StatsAccum -> SparkStats sparkStats StatsAccum{dsparkTable} = SparkStats { capSparkStats = [ (cap, mkSparkStats sparkCounts) | (cap, sparkCounts) <- capsSparkCounts ], totalSparkStats = mkSparkStats $ foldl' (binopSparks (+)) zeroSparks [ sparkCounts | (_cap, sparkCounts) <- capsSparkCounts ] } where capsSparkCounts = [ (cap, sparkCounts) | (cap, (countsEnd, countsStart)) <- IM.assocs dsparkTable , let sparkCounts = binopSparks (-) countsEnd countsStart ] mkSparkStats RtsSpark {sparkCreated, sparkDud, sparkOverflowed, sparkConverted, sparkFizzled, sparkGCd} = -- in our final presentation we show the total created, -- and the breakdown of that into outcomes: SparkCounts (sparkCreated + sparkDud + sparkOverflowed) sparkConverted sparkOverflowed sparkDud sparkGCd sparkFizzled ------------------------------------------------------------------------------ timeToSecondsDbl :: Integral a => a -> Double timeToSecondsDbl t = timeToSeconds $ fromIntegral t timeToSeconds :: Double -> Double timeToSeconds t = t / tIME_RESOLUTION where tIME_RESOLUTION = 1000000 ------------------------------------------------------------------------------ -- The single-pass stats accumulation stuff -- -- | Data collected and computed gradually while events are scanned. data StatsAccum = StatsAccum { dallocTable :: !(IM.IntMap (Word64, Word64)) -- indexed by caps , dcopied :: !(Maybe Word64) , dmaxResidency :: !(Maybe Word64) , dmaxSlop :: !(Maybe Word64) , dmaxMemory :: !(Maybe Word64) --, dmaxFrag :: Maybe Word64 -- not important enough , dGCTable :: !(IM.IntMap RtsGC) -- indexed by caps -- Here we store the official +RTS -s timings of GCs, -- that is times aggregated from the main caps of all GCs. -- For now only gcElapsed and gcMaxPause are needed, so the rest -- of the fields stays at default values. , dGCMain :: !(Maybe RtsGC) , dparMaxCopied :: !(Maybe Word64) , dparTotCopied :: !(Maybe Word64) , dmaxParNThreads :: !(Maybe Int) --, dtaskTable -- of questionable usefulness, hard to get , dsparkTable :: !(IM.IntMap (RtsSpark, RtsSpark)) -- indexed by caps --, dInitExitT -- TODO. At least init time can be included in the total -- time registered in the eventlog. Can we measure this -- as the time between some initial events? --, dGCTime -- Is better computed after all events are scanned, -- e.g., because the same info can be used to calculate -- per-cap GCTime and other per-cap stats. --, dtotalTime -- TODO: can we measure this excluding INIT or EXIT times? } data RtsSpark = RtsSpark { sparkCreated, sparkDud, sparkOverflowed , sparkConverted, sparkFizzled, sparkGCd :: !Word64 } zeroSparks :: RtsSpark zeroSparks = RtsSpark 0 0 0 0 0 0 binopSparks :: (Word64 -> Word64 -> Word64) -> RtsSpark -> RtsSpark -> RtsSpark binopSparks op (RtsSpark crt1 dud1 ovf1 cnv1 fiz1 gcd1) (RtsSpark crt2 dud2 ovf2 cnv2 fiz2 gcd2) = RtsSpark (crt1 `op` crt2) (dud1 `op` dud2) (ovf1 `op` ovf2) (cnv1 `op` cnv2) (fiz1 `op` fiz2) (gcd1 `op` gcd2) type Gen = Int type Cap = Int data GcMode = ModeInit | ModeStart | ModeSync Cap | ModeGHC Cap Gen | ModeEnd | ModeIdle deriving Eq data RtsGC = RtsGC { gcMode :: !GcMode , gcStartTime :: !Timestamp , gcGenStat :: !(IM.IntMap GenStat) -- indexed by generations } -- Index at the @gcGenStat@ map at which we store the sum of stats over all -- generations, or the single set of stats for non-genenerational GC models. gcGenTot :: Gen gcGenTot = -1 data GenStat = GenStat { -- Sum over all seqential and pararell GC invocations. gcAll :: !Int , -- Only parallel GCs. For GC models without stop-the-world par, always 0. gcPar :: !Int , gcElapsed :: !Timestamp , gcMaxPause :: !Timestamp } emptyStatsAccum :: StatsAccum emptyStatsAccum = StatsAccum { dallocTable = IM.empty , dcopied = Nothing , dmaxResidency = Nothing , dmaxSlop = Nothing , dmaxMemory = Nothing , dGCTable = IM.empty , dGCMain = Nothing , dparMaxCopied = Nothing , dparTotCopied = Nothing , dmaxParNThreads = Nothing , dsparkTable = IM.empty } -- | At the beginning of a program run, we know for sure several of the -- stats start at zero: zeroStatsAccum :: StatsAccum zeroStatsAccum = emptyStatsAccum { dcopied = Just 0, dmaxResidency = Just 0, dmaxSlop = Just 0, dmaxMemory = Just 0, dallocTable = -- a hack: we assume no more than 999 caps IM.fromDistinctAscList $ zip [0..999] $ repeat (0, 0) -- FIXME: but also, we should have a way to init to 0 for all caps. } defaultGC :: Timestamp -> RtsGC defaultGC time = RtsGC { gcMode = ModeInit , gcStartTime = time , gcGenStat = IM.empty } emptyGenStat :: GenStat emptyGenStat = GenStat { gcAll = 0 , gcPar = 0 , gcElapsed = 0 , gcMaxPause = 0 } accumEvent :: StatsAccum -> CapEvent -> StatsAccum accumEvent !statsAccum (CapEvent mcap ev) = let -- For events that contain a counter with a running sum. -- Eventually we'll subtract the last found -- event from the first. Intervals beginning at time 0 -- are a special case, because morally the first event should have -- value 0, but it may be absent, so we start with @Just (0, 0)@. alterCounter n Nothing = Just (n, n) alterCounter n (Just (_previous, first)) = Just (n, first) -- For events that contain discrete increments. We assume the event -- is emitted close to the end of the process it measures, -- so we ignore the first found event, because most of the process -- could have happened before the start of the current inverval. -- This is consistent with @alterCounter@. For interval beginning -- at time 0, we start with @Just 0@. alterIncrement _ Nothing = Just 0 alterIncrement n (Just k) = Just (k + n) -- For events that contain sampled values, where a max is sought. alterMax n Nothing = Just n alterMax n (Just k) | n > k = Just n alterMax _ jk = jk -- Scan events, updating summary data. scan cap !sd@StatsAccum{..} Event{time, spec} = let capGC = IM.findWithDefault (defaultGC time) cap dGCTable in case spec of -- TODO: check EventBlock elsewhere; define {map,fold}EventBlock EventBlock{cap = bcap, block_events} -> L.foldl' (scan bcap) sd block_events HeapAllocated{allocBytes} -> sd { dallocTable = IM.alter (alterCounter allocBytes) cap dallocTable } HeapLive{liveBytes} -> sd { dmaxResidency = alterMax liveBytes dmaxResidency} HeapSize{sizeBytes} -> sd { dmaxMemory = alterMax sizeBytes dmaxMemory} StartGC -> assert (gcMode capGC `elem` [ModeInit, ModeEnd, ModeIdle]) $ let newGC = capGC { gcMode = ModeStart , gcStartTime = time } -- TODO: Index with generations, not caps? in sd { dGCTable = IM.insert cap newGC dGCTable } GlobalSyncGC -> -- All caps must be stopped. Those that take part in the GC -- are in ModeInit or ModeStart, those that do not -- are in ModeInit, ModeEnd or ModeIdle. assert (L.all (notModeGHCEtc . gcMode) (IM.elems dGCTable)) $ sd { dGCTable = IM.mapWithKey setSync dGCTable } where notModeGHCEtc ModeGHC{} = False notModeGHCEtc ModeSync{} = False notModeGHCEtc _ = True someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable) setSync capKey dGC@RtsGC{gcGenStat} | someInit = -- If even one cap could possibly have started GC before -- the start of the selected interval, skip the GC on all caps. -- We don't verify the overwritten modes in this case. -- TODO: we could be smarter and defer the decision to EndGC, -- when we can deduce if the suspect caps take part in GC -- or not at all. dGC { gcMode = ModeInit } | otherwise = let totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat in case gcMode dGC of -- Cap takes part in the GC (not known if seq or par). -- Here is the moment where all caps taking place in the GC -- are identified and we can aggregate all their data -- at once (currently we just increment a counter for each). -- The EndGC events can come much later for some caps and at -- that time other caps are already inside their new GC. ModeStart -> dGC { gcMode = ModeSync cap , gcGenStat = if capKey == cap then IM.insert gcGenTot totGC{ gcAll = gcAll totGC + 1 } gcGenStat else gcGenStat } -- Cap is not in the GC. Mark it as idle to complete -- the identification of caps that take part -- in the current GC. Without overwritin the mode, -- the cap could be processed later on as if -- it took part in the GC, giving wrong results. ModeEnd -> dGC { gcMode = ModeIdle } ModeIdle -> dGC -- Impossible. ModeInit -> error "scanEvents: GlobalSyncGC ModeInit" ModeSync{} -> error "scanEvents: GlobalSyncGC ModeSync" ModeGHC{} -> error "scanEvents: GlobalSyncGC ModeGHC" GCStatsGHC{..} -> -- All caps must be stopped. Those that take part in the GC -- are in ModeInit or ModeSync, those that do not -- are in ModeInit or ModeIdle. assert (L.all (notModeStartEtc . gcMode) (IM.elems dGCTable)) $ sd { dcopied = alterIncrement copied dcopied -- sum over caps , dmaxSlop = alterMax slop dmaxSlop -- max over all caps , dGCTable = IM.mapWithKey setParSeq dGCTable , dparMaxCopied = alterIncrement parMaxCopied dparMaxCopied , dparTotCopied = alterIncrement parTotCopied dparTotCopied , dmaxParNThreads = alterMax parNThreads dmaxParNThreads } where notModeStartEtc ModeStart = False notModeStartEtc ModeGHC{} = False notModeStartEtc ModeEnd = False notModeStartEtc _ = True someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable) setParSeq capKey dGC@RtsGC{gcGenStat} | someInit = -- Just starting the selected interval, so skip the GC. dGC | otherwise = let genGC = IM.findWithDefault emptyGenStat gen gcGenStat totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat in case gcMode dGC of -- Cap takes part in seq GC. ModeSync capSync | parNThreads == 1 -> assert (cap == capSync) $ dGC { gcMode = ModeGHC cap gen , gcGenStat = -- Already inserted into gcGenTot in GlobalSyncGC, -- so only inserting into gen. if capKey == cap then IM.insert gen genGC{ gcAll = gcAll genGC + 1 } gcGenStat else gcGenStat } -- Cap takes part in par GC. ModeSync capSync -> assert (cap == capSync) $ assert (parNThreads > 1) $ dGC { gcMode = ModeGHC cap gen , gcGenStat = if capKey == cap then IM.insert gen genGC{ gcAll = gcAll genGC + 1 , gcPar = gcPar genGC + 1 } (IM.insert gcGenTot -- Already incremented gcAll in SyncGC. totGC{ gcPar = gcPar totGC + 1 } gcGenStat) else gcGenStat } -- Cap not in the current GC, leave it alone. ModeIdle -> dGC -- Impossible. ModeInit -> error "scanEvents: GCStatsGHC ModeInit" ModeGHC{} -> error "scanEvents: GCStatsGHC ModeGHC" -- The last two cases are copied from case @GlobalSyncGC@ -- to work around low-resolution timestamps (#35). -- Normally, these states would be impossible here, because -- @GlobalSyncGC@ would already transition away from these -- states. But if @GlobalSyncGC@ comes too early, the states -- can appear here. The computed stats are usually only -- slightly different than if @GlobalSyncGC@ made the state -- transitions, because the timestamps of @GCStatsGHC@ -- and @GlobalSyncGC@ are normally only slightly different. -- -- Cap takes part in the GC (not known if seq or par). -- Here is the moment where all caps taking place in the GC -- are identified and we can aggregate all their data -- at once (currently we just increment a counter for each). -- The EndGC events can come much later for some caps and at -- that time other caps are already inside their new GC. ModeStart -> dGC { gcMode = ModeSync cap , gcGenStat = if capKey == cap then IM.insert gcGenTot totGC{ gcAll = gcAll totGC + 1 } gcGenStat else gcGenStat } -- Cap is not in the GC. Mark it as idle to complete -- the identification of caps that take part -- in the current GC. Without overwritin the mode, -- the cap could be processed later on as if -- it took part in the GC, giving wrong results. ModeEnd -> dGC { gcMode = ModeIdle } EndGC -> assert (gcMode capGC `notElem` [ModeEnd, ModeIdle]) $ let endedGC = capGC { gcMode = ModeEnd } duration = time - gcStartTime capGC timeGC gen gstat = let genGC = IM.findWithDefault emptyGenStat gen (gcGenStat gstat) newGenGC = genGC { gcElapsed = gcElapsed genGC + duration , gcMaxPause = max (gcMaxPause genGC) duration } in gstat { gcGenStat = IM.insert gen newGenGC (gcGenStat gstat) } timeGenTot = timeGC gcGenTot endedGC updateMainCap mainCap _ dgm | mainCap /= cap = dgm updateMainCap _ currentGen dgm = -- We are at the EndGC event of the main cap of current GC. -- The timings from this cap are the only that +RTS -s uses. -- We will record them in the dGCMain field to be able -- to display a look-alike of +RTS -s. timeGC currentGen dgm in case gcMode capGC of -- We don't know the exact timing of this GC started before -- the selected interval, so we skip it and clear its mode. ModeInit -> sd { dGCTable = IM.insert cap endedGC dGCTable } -- There is no GlobalSyncGC nor GCStatsGHC for this GC. -- Consequently, we can't determine the main cap, -- so skip it and and clear its mode. ModeStart -> sd { dGCTable = IM.insert cap endedGC dGCTable } -- There is no GCStatsGHC for this GC. Gather partial data. ModeSync mainCap -> let dgm = fromMaybe (defaultGC time) dGCMain mainGenTot = updateMainCap mainCap gcGenTot dgm in sd { dGCTable = IM.insert cap timeGenTot dGCTable , dGCMain = Just mainGenTot } -- All is known, so we update the times. ModeGHC mainCap gen -> let newTime = timeGC gen timeGenTot dgm = fromMaybe (defaultGC time) dGCMain mainGenTot = updateMainCap mainCap gcGenTot dgm newMain = updateMainCap mainCap gen mainGenTot in sd { dGCTable = IM.insert cap newTime dGCTable , dGCMain = Just newMain } ModeEnd -> error "scanEvents: EndGC ModeEnd" ModeIdle -> error "scanEvents: EndGC ModeIdle" SparkCounters crt dud ovf cnv fiz gcd _rem -> -- We are guranteed the first spark counters event has all zeroes, -- do we don't need to rig the counters for maximal interval. let current = RtsSpark crt dud ovf cnv fiz gcd in sd { dsparkTable = IM.alter (alterCounter current) cap dsparkTable } _ -> sd in scan (fromMaybe (error "Error: missing cap; use 'ghc-events validate' to verify the eventlog") mcap) statsAccum ev threadscope-0.2.6/GUI/TraceView.hs0000644000000000000000000001616212435266473015101 0ustar0000000000000000module 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) threadscope-0.2.6/GUI/ConcurrencyControl.hs0000644000000000000000000000423012435266473017034 0ustar0000000000000000 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 threadscope-0.2.6/GUI/GtkExtras.hs0000644000000000000000000001061712435266473015123 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, CPP #-} 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 #if mingw32_HOST_OS || mingw32_TARGET_OS launchProgramForURI uri = do withCString "open" $ \verbPtr -> withCString uri $ \filePtr -> c_ShellExecuteA nullPtr verbPtr filePtr nullPtr nullPtr 1 -- SW_SHOWNORMAL return True foreign import stdcall unsafe "shlobj.h ShellExecuteA" c_ShellExecuteA :: Ptr () -- HWND hwnd -> CString -- LPCTSTR lpOperation -> CString -- LPCTSTR lpFile -> CString -- LPCTSTR lpParameters -> CString -- LPCTSTR lpDirectory -> CInt -- INT nShowCmd -> IO CInt -- HINSTANCE return #else launchProgramForURI uri = propagateGError $ \errPtrPtr -> withCString uri $ \uriStrPtr -> do timestamp <- gtk_get_current_event_time liftM toBool $ gtk_show_uri nullPtr uriStrPtr timestamp errPtrPtr #endif ------------------------------------------------------------------------------- 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 threadscope-0.2.6/GUI/StartupInfoView.hs0000644000000000000000000001235012435266473016314 0ustar0000000000000000module 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 threadscope-0.2.6/GUI/SaveAs.hs0000644000000000000000000000535412435266473014373 0ustar0000000000000000module 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 hiding (rectangle) import Graphics.Rendering.Cairo ( Render , Operator(..) , Format(..) , rectangle , getOperator , setOperator , fill , translate , liftIO , withPDFSurface , renderWith , withImageSurface , surfaceWriteToPNG ) saveAs :: HECs -> ViewParameters -> Double -> DrawingArea -> (Int, Int, Render ()) saveAs hecs params' @ViewParameters{xScaleAreaHeight, width, height = oldHeight {-, histogramHeight-}} yScaleAreaWidth yScaleArea = let histTotalHeight = histXScaleHeight -- + histogramHeight 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 threadscope-0.2.6/GUI/MainWindow.hs0000644000000000000000000001665112435266473015267 0ustar0000000000000000module 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" 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 {..} threadscope-0.2.6/GUI/KeyView.hs0000644000000000000000000001521712435266473014573 0ustar0000000000000000module 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)") , ("perf counter", KEvent, createdConvertedColour, "Indicates an update of a perf counter") , ("perf tracepoint", KEvent, shutdownColour, "Indicates that a perf tracepoint was reached") , ("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 ------------------------------------------------------------------------------- threadscope-0.2.6/GUI/ProgressView.hs0000644000000000000000000000647512435266473015655 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module GUI.ProgressView ( ProgressView, withProgress, setText, setTitle, setProgress, startPulse, ) where import Graphics.Rendering.Cairo import Graphics.UI.Gtk as Gtk import GUI.GtkExtras import qualified Control.Concurrent as Concurrent import Control.Exception import Data.Typeable import Prelude hiding (catch) data ProgressView = ProgressView { progressWindow :: Gtk.Window, progressLabel :: Gtk.Label, progressBar :: Gtk.ProgressBar } -- | Perform a long-running operation and display a progress window. The -- operation has access to the progress window and it is expected to update it -- using 'setText' and 'setProgress' -- -- The user may cancel the operation at any time. -- withProgress :: WindowClass win => win -> (ProgressView -> IO a) -> IO (Maybe a) withProgress parent action = do self <- Concurrent.myThreadId let cancel = throwTo self OperationInterrupted bracket (new parent cancel) close $ \progress -> fmap Just (action progress) `catch` \OperationInterrupted -> return Nothing data OperationInterrupted = OperationInterrupted deriving (Typeable, Show) instance Exception OperationInterrupted setText :: ProgressView -> String -> IO () setText view msg = set (progressBar view) [ progressBarText := msg ] setTitle :: ProgressView -> String -> IO () setTitle view msg = do set (progressWindow view) [ windowTitle := msg ] set (progressLabel view) [ labelLabel := "" ++ 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 :: Maybe String) 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 } threadscope-0.2.6/GUI/Timeline/0000755000000000000000000000000012435266473014414 5ustar0000000000000000threadscope-0.2.6/GUI/Timeline/Types.hs0000644000000000000000000000222312435266473016053 0ustar0000000000000000module 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 ----------------------------------------------------------------------------- threadscope-0.2.6/GUI/Timeline/HEC.hs0000644000000000000000000002525112435266473015354 0ustar0000000000000000module 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 qualified Data.IntMap as IM import Data.Maybe import Control.Monad renderHEC :: ViewParameters -> Timestamp -> Timestamp -> IM.IntMap String -> (DurationTree,EventTree) -> Render () renderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do renderDurations params start end dtree when (scaleValue < detailThreshold) $ case etree of EventTree ltime etime tree -> do renderEvents params ltime etime start end (fromIntegral detail) perfNames tree return () renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp -> IM.IntMap String -> EventTree -> Render () renderInstantHEC params@ViewParameters{..} start end perfNames (EventTree ltime etime tree) = do let instantDetail = 1 renderEvents params ltime etime start end instantDetail perfNames tree return () detailThreshold :: Double detailThreshold = 3 ------------------------------------------------------------------------------- -- 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 "renderDurations (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $ drawAverageDuration params s e runAv gcAv | otherwise = -- trace (printf "renderDurations: 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 -> Double -> IM.IntMap String -> EventNode -> Render Bool renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth perfNames (EventTreeLeaf es) = let within = [ e | e <- es, let t = time e, t >= startPos && t < endPos ] untilTrue _ [] = return False untilTrue f (x : xs) = do b <- f x if b then return b else untilTrue f xs in untilTrue (drawEvent params ewidth perfNames) within renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth perfNames (EventTreeOne ev) | t >= startPos && t < endPos = drawEvent params ewidth perfNames ev | otherwise = return False where t = time ev renderEvents params@ViewParameters{..} !s !e !startPos !endPos ewidth perfNames (EventSplit splitTime lhs rhs) | startPos < splitTime && endPos >= splitTime && (fromIntegral (e - s) / scaleValue) <= ewidth = do drawnLhs <- renderEvents params s splitTime startPos endPos ewidth perfNames lhs if not drawnLhs then renderEvents params splitTime e startPos endPos ewidth perfNames rhs else return True | otherwise = do drawnLhs <- if startPos < splitTime then renderEvents params s splitTime startPos endPos ewidth perfNames lhs else return False drawnRhs <- if endPos >= splitTime then renderEvents params splitTime e startPos endPos ewidth perfNames rhs else return False return $ drawnLhs || drawnRhs ------------------------------------------------------------------------------- -- 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 -> Double -> IM.IntMap String -> GHC.Event -> Render Bool drawEvent params@ViewParameters{..} ewidth perfNames event = let renderI = renderInstantEvent params perfNames event ewidth in case spec event of CreateThread{} -> renderI createThreadColour RequestSeqGC{} -> renderI seqGCReqColour RequestParGC{} -> renderI parGCReqColour MigrateThread{} -> renderI migrateThreadColour WakeupThread{} -> renderI threadWakeupColour Shutdown{} -> renderI shutdownColour SparkCreate{} -> renderI createdConvertedColour SparkDud{} -> renderI fizzledDudsColour SparkOverflow{} -> renderI overflowedColour SparkRun{} -> renderI createdConvertedColour SparkSteal{} -> renderI createdConvertedColour SparkFizzle{} -> renderI fizzledDudsColour SparkGC{} -> renderI gcColour UserMessage{} -> renderI userMessageColour PerfCounter{} -> renderI createdConvertedColour PerfTracepoint{} -> renderI shutdownColour PerfName{} -> return False RunThread{} -> return False StopThread{} -> return False StartGC{} -> return False _ -> return False renderInstantEvent :: ViewParameters -> IM.IntMap String -> GHC.Event -> Double -> Color -> Render Bool renderInstantEvent ViewParameters{..} perfNames event ewidth color = do setSourceRGBAhex color 1.0 setLineWidth (ewidth * scaleValue) let t = time event draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4) let numToLabel PerfCounter{perfNum, period} | period == 0 = IM.lookup (fromIntegral perfNum) perfNames numToLabel PerfCounter{perfNum, period} = fmap (++ " <" ++ show (period + 1) ++ " times>") $ IM.lookup (fromIntegral perfNum) perfNames numToLabel PerfTracepoint{perfNum} = fmap ("tracepoint: " ++) $ IM.lookup (fromIntegral perfNum) perfNames numToLabel _ = Nothing showLabel espec = fromMaybe (showEventInfo espec) (numToLabel espec) labelAt labelsMode t $ showLabel (spec event) return True ------------------------------------------------------------------------------- threadscope-0.2.6/GUI/Timeline/Activity.hs0000644000000000000000000001274312435266473016553 0ustar0000000000000000module 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 threadscope-0.2.6/GUI/Timeline/Motion.hs0000644000000000000000000001211312435266473016213 0ustar0000000000000000module 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 -- ----------------------------------------------------------------------------- threadscope-0.2.6/GUI/Timeline/Sparks.hs0000644000000000000000000002251412435266473016217 0ustar0000000000000000module 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 threadscope-0.2.6/GUI/Timeline/Render.hs0000644000000000000000000004122512435266473016173 0ustar0000000000000000{-# LANGUAGE CPP #-} 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 hiding (rectangle) import Graphics.Rendering.Cairo ( Render , Content(..) , Operator(..) , Surface , liftIO , withTargetSurface , createSimilarSurface , renderWith , surfaceFinish , clip , setSourceSurface , setOperator , paint , setLineWidth , moveTo , lineTo , stroke , rectangle , fill , save , scale , translate , restore , setSourceRGBA ) import Data.IORef import Control.Monad import qualified Data.Text as T ------------------------------------------------------------------------------- -- | 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 (perfNames hecs) (dtree, etree) TraceInstantHEC c -> let (_, etree, _) = hecTrees hecs !! c in renderInstantHEC params startPos endPos (perfNames hecs) 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 #if MIN_VERSION_gtk(0,13,0) (T.pack "sans serif")] #else "sans serif"] #endif 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 threadscope-0.2.6/GUI/Timeline/Ticks.hs0000644000000000000000000002652212435266473016034 0ustar0000000000000000{-# 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 (veryRoundedPos, 0) (veryRoundedPos, height) drawVRulers tickWidthInPixels scaleValue (pos + incr) incr endPos height (i + 1) else return () where -- Hack to sync with drawXTicks. veryRoundedPos = round $ scaleValue * fromIntegral (floor (fromIntegral (round pos) / scaleValue)) 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 = floor hadjValue startLine :: Timestamp startLine = floor $ hadjValue / scaleValue endPos :: Timestamp endPos = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx) endLine :: Timestamp endLine = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx) / scaleValue save translate (- fromIntegral startLine) 0 selectFontFace "sans serif" FontSlantNormal FontWeightNormal setFontSize 12 setSourceRGBAhex black 1.0 -- setLineCap LineCapRound -- TODO: breaks rendering currently (see BrokenX.png) setLineWidth 1.0 draw_line (startLine, off 16) (endLine, 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) 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 when (pos /= 0 || xScaleMode == XScaleTime) $ draw_line (floor $ fromIntegral x1 / scaleValue, off 16) (floor $ fromIntegral x1 / scaleValue, off (16 - tickLength)) when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do tExtent <- textExtents tickTimeText let tExtentWidth = textExtentsWidth tExtent move_to (floor $ fromIntegral textPosX / scaleValue, textPosY) when (floor (pos + incr) <= endPos && (tExtentWidth + tExtentWidth / 3 < width || atMajorTick)) $ showText tickTimeText 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 (textPosX, textPosY) = 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 = if v < 0.01 && v > 0 then eps else 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 -- | The \'epsilon\' symbol. eps :: 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: eps = "\206\181" #else -- Haskell cairo bindings 0.12.1 have proper Unicode support eps = "\x03b5" #endif -- | Remove all meaningless trailing zeroes. deZero :: String -> String deZero s | '.' `elem` s = reverse . dropWhile (=='.') . dropWhile (=='0') . reverse $ s | otherwise = s threadscope-0.2.6/GUI/Timeline/CairoDrawing.hs0000644000000000000000000000626212435266473017327 0ustar0000000000000000------------------------------------------------------------------------------- --- $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 threadscope-0.2.6/GUI/Timeline/Render/0000755000000000000000000000000012435266473015633 5ustar0000000000000000threadscope-0.2.6/GUI/Timeline/Render/Constants.hs0000644000000000000000000000260712435266473020150 0ustar0000000000000000module 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 threadscope-0.2.6/Events/0000755000000000000000000000000012435266473013466 5ustar0000000000000000threadscope-0.2.6/Events/SparkStats.hs0000644000000000000000000001032612435266473016123 0ustar0000000000000000module 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) threadscope-0.2.6/Events/EventTree.hs0000644000000000000000000002255512435266473015734 0ustar0000000000000000module 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 threadscope-0.2.6/Events/HECs.hs0000644000000000000000000000503612435266473014610 0ustar0000000000000000{-# LANGUAGE CPP #-} module Events.HECs ( HECs(..), Event, CapEvent, Timestamp, eventIndexToTimestamp, timestampToEventIndex, extractUserMarkers, 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)], perfNames :: IM.IntMap String } ----------------------------------------------------------------------------- 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)) extractUserMarkers :: HECs -> [(Timestamp, String)] extractUserMarkers hecs = [ (ts, mark) | CapEvent _ (Event ts (UserMarker mark)) <- 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 threadscope-0.2.6/Events/ReadEvents.hs0000644000000000000000000002477012435266473016074 0ustar0000000000000000module 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 GHC.RTS.Events -- hiding (Event) import GHC.RTS.Events.Analysis import GHC.RTS.Events.Analysis.SparkThread import GHC.RTS.Events.Analysis.Capability import Data.Array import qualified Data.List as L import Data.Map (Map) import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Set (Set) import Data.Maybe (catMaybes, fromMaybe) import Text.Printf import System.FilePath import Control.Monad import Control.Exception import qualified Control.DeepSeq as DeepSeq import Data.Function import Data.Either ------------------------------------------------------------------------------- -- import qualified GHC.RTS.Events as GHCEvents -- -- 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 :: [CapEvent] -> Timestamp -> [(Double, (DurationTree, EventTree, SparkTree))] rawEventsToHECs evs endTime = map (\ cap -> toTree $ L.find ((Just cap ==) . ce_cap . head) heclists) [0 .. maximum (0 : map (fromMaybe 0 . ce_cap) evs)] where heclists = L.groupBy ((==) `on` ce_cap) $ L.sortBy (compare `on` ce_cap) evs toTree Nothing = (0, (DurationTreeEmpty, EventTree 0 0 (EventTreeLeaf []), emptySparkTree)) toTree (Just evs) = (maxSparkPool, (mkDurationTree (eventsToDurations nondiscrete) endTime, mkEventTree discrete endTime, mkSparkTree sparkD endTime)) where es = map ce_event evs (discrete, nondiscrete) = L.partition isDiscreteEvent es (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) -- Add caps to perf events, using the OS thread numbers -- obtained from task validation data. -- Only the perf events with a cap are displayed in the timeline. -- TODO: it may make sense to move this code to ghc-events -- and run after to-eventlog and ghc-events merge, but it requires -- one more step in the 'perf to TS' workflow and is a bit slower -- (yet another event sorting and loading eventlog chunks -- into the CPU cache). steps :: [CapEvent] -> [(Map KernelThreadId Int, CapEvent)] steps evs = zip (map fst $ rights $ validates capabilityTaskOSMachine evs) evs addC :: (Map KernelThreadId Int, CapEvent) -> CapEvent addC (state, ev@CapEvent{ce_event=Event{spec=PerfTracepoint{tid}}}) = case M.lookup tid state of Nothing -> ev -- unknown task's OS thread ce_cap -> ev {ce_cap} addC (state, ev@CapEvent{ce_event=Event{spec=PerfCounter{tid}}}) = case M.lookup tid state of Nothing -> ev -- unknown task's OS thread ce_cap -> ev {ce_cap} addC (_, ev) = ev addCaps evs = map addC (steps evs) -- sort the events by time, add extra caps and put them in an array sorted = addCaps $ sortEvents eventsBy maxTrees = rawEventsToHECs sorted lastTx maxSparkPool = maximum (0 : map fst maxTrees) trees = map snd maxTrees -- put events in an array 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) times :: (Int, Timestamp, Timestamp) -> Maybe (Timestamp, Int, Timestamp) times (_, timeStarted, timeElapsed) = Just (timeStarted, ilog timeElapsed, timeElapsed) 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 m [] = map times $ M.elems m sparkSummary m ((threadId, (state, timeStarted', timeElapsed')):xs) = case state of SparkThreadRunning sparkId' -> case M.lookup threadId m of Just el@(sparkId, timeStarted, timeElapsed) -> if sparkId == sparkId' then let value = (sparkId, timeStarted, timeElapsed + timeElapsed') in sparkSummary (M.insert threadId value m) xs else times el : 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) getPerfNames nmap ev = case spec ev of EventBlock{block_events} -> L.foldl' getPerfNames nmap block_events PerfName{perfNum, name} -> IM.insert (fromIntegral perfNum) name nmap _ -> nmap perfNames = L.foldl' getPerfNames IM.empty eventsBy hecs = HECs { hecCount = hec_count, hecTrees = trees, hecEventArray = event_arr, hecLastEventTime = lastTx, maxSparkPool, minXHistogram, maxXHistogram, maxYHistogram, durHistogram, perfNames } 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 (hec_count == 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 otherwise the last -- bit of work gets done after the progress window has been closed. return (hecs, name, n_events, fromIntegral lastTx / 1000000) threadscope-0.2.6/Events/EventDuration.hs0000644000000000000000000001327512435266473016621 0ustar0000000000000000-- 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 ------------------------------------------------------------------------------- threadscope-0.2.6/Events/SparkTree.hs0000644000000000000000000002414212435266473015725 0ustar0000000000000000module 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] threadscope-0.2.6/Events/TestEvents.hs0000644000000000000000000002406512435266473016135 0ustar0000000000000000module 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 -------------------------------------------------------------------------------