diff -Nru threadscope-0.2.1/Events/HECs.hs threadscope-0.2.2/Events/HECs.hs --- threadscope-0.2.1/Events/HECs.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/Events/HECs.hs 2012-11-02 04:57:16.000000000 +0000 @@ -7,7 +7,7 @@ eventIndexToTimestamp, timestampToEventIndex, - extractUserMessages, + extractUserMarkers, histogram, histogramCounts, ) where @@ -32,7 +32,8 @@ minXHistogram :: Int, maxXHistogram :: Int, maxYHistogram :: Timestamp, - durHistogram :: [(Timestamp, Int, Timestamp)] + durHistogram :: [(Timestamp, Int, Timestamp)], + perfNames :: IM.IntMap String } ----------------------------------------------------------------------------- @@ -55,10 +56,10 @@ mid = l + (r - l) `quot` 2 tmid = time (ce_event (arr!mid)) -extractUserMessages :: HECs -> [(Timestamp, String)] -extractUserMessages hecs = - [ (ts, msg) - | CapEvent _ (Event ts (UserMessage msg)) <- elems (hecEventArray hecs) ] +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)] diff -Nru threadscope-0.2.1/Events/ReadEvents.hs threadscope-0.2.2/Events/ReadEvents.hs --- threadscope-0.2.1/Events/ReadEvents.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/Events/ReadEvents.hs 2012-11-02 04:57:16.000000000 +0000 @@ -10,25 +10,30 @@ import qualified GUI.ProgressView as ProgressView import GUI.ProgressView (ProgressView) -import qualified GHC.RTS.Events as GHCEvents -import GHC.RTS.Events hiding (Event) +import GHC.RTS.Events -- 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) +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] @@ -46,13 +51,14 @@ ------------------------------------------------------------------------------- -rawEventsToHECs :: [(Maybe Int, [GHCEvents.Event])] -> Timestamp +rawEventsToHECs :: [CapEvent] -> Timestamp -> [(Double, (DurationTree, EventTree, SparkTree))] -rawEventsToHECs eventList endTime - = map (toTree . flip lookup heclists) - [0 .. maximum (minBound : map fst heclists)] +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 = [ (h, events) | (Just h, events) <- eventList ] + heclists = + L.groupBy ((==) `on` ce_cap) $ L.sortBy (compare `on` ce_cap) evs toTree Nothing = (0, (DurationTreeEmpty, EventTree 0 0 (EventTreeLeaf []), @@ -62,7 +68,8 @@ (mkDurationTree (eventsToDurations nondiscrete) endTime, mkEventTree discrete endTime, mkSparkTree sparkD endTime)) - where (discrete, nondiscrete) = L.partition isDiscreteEvent evs + where es = map ce_event evs + (discrete, nondiscrete) = L.partition isDiscreteEvent es (maxSparkPool, sparkD) = eventsToSparkDurations nondiscrete ------------------------------------------------------------------------------- @@ -124,13 +131,36 @@ -- 1, to avoid graph scale 0 and division by 0 later on lastTx = maximum (1 : map eventBlockEnd eventsBy) - groups = groupEvents eventsBy - maxTrees = rawEventsToHECs groups lastTx + -- 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 - -- sort the events by time and put them in an array - sorted = sortGroups groups + -- put events in an array n_events = length sorted event_arr = listArray (0, n_events-1) sorted hec_count = length trees @@ -145,6 +175,10 @@ 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), @@ -161,16 +195,15 @@ sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp) -> [(ThreadId, (SparkThreadState, Timestamp, Timestamp))] -> [Maybe (Timestamp, Int, Timestamp)] - sparkSummary _ [] = [] + 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 (sparkId, timeStarted, timeElapsed) -> + Just el@(sparkId, timeStarted, timeElapsed) -> if sparkId == sparkId' then let value = (sparkId, timeStarted, timeElapsed + timeElapsed') in sparkSummary (M.insert threadId value m) xs - else let times = (timeStarted, ilog timeElapsed, timeElapsed) - in Just times : newSummary sparkId' xs + else times el : newSummary sparkId' xs Nothing -> newSummary sparkId' xs _ -> sparkSummary m xs where @@ -191,16 +224,26 @@ -- 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 = maxSparkPool, - minXHistogram = minXHistogram, - maxXHistogram = maxXHistogram, - maxYHistogram = maxYHistogram, - durHistogram = durHistogram + maxSparkPool, + minXHistogram, + maxXHistogram, + maxYHistogram, + durHistogram, + perfNames } treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO () @@ -211,13 +254,13 @@ evaluate tree1 evaluate (eventTreeMaxDepth tree2) evaluate (sparkTreeMaxDepth tree3) - when (length trees == 1 || hec == 1) -- eval only with 2nd HEC + 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 othewise the last + -- 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) diff -Nru threadscope-0.2.1/Events/SparkTree.hs threadscope-0.2.2/Events/SparkTree.hs --- threadscope-0.2.1/Events/SparkTree.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/Events/SparkTree.hs 2012-11-02 04:57:16.000000000 +0000 @@ -40,10 +40,8 @@ newMaxSparkPool = SparkStats.maxPool delta sd = SparkDuration { startT = startTime, deltaC = delta } - (oldMaxSparkPool, l) = - aux endTime endCounters events - in ( max oldMaxSparkPool newMaxSparkPool, - sd : l) + (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 diff -Nru threadscope-0.2.1/GUI/GtkExtras.hs threadscope-0.2.2/GUI/GtkExtras.hs --- threadscope-0.2.1/GUI/GtkExtras.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/GtkExtras.hs 2012-11-02 04:57:16.000000000 +0000 @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface, CPP #-} module GUI.GtkExtras where -- This is all stuff that should be bound in the gtk package but is not yet @@ -78,11 +78,35 @@ 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 ------------------------------------------------------------------------------- diff -Nru threadscope-0.2.1/GUI/Histogram.hs threadscope-0.2.2/GUI/Histogram.hs --- threadscope-0.2.1/GUI/Histogram.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/Histogram.hs 2012-11-02 04:57:16.000000000 +0000 @@ -27,6 +27,7 @@ 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 diff -Nru threadscope-0.2.1/GUI/KeyView.hs threadscope-0.2.2/GUI/KeyView.hs --- threadscope-0.2.1/GUI/KeyView.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/KeyView.hs 2012-11-02 04:57:16.000000000 +0000 @@ -77,6 +77,10 @@ "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 " ++ diff -Nru threadscope-0.2.1/GUI/Main.hs threadscope-0.2.2/GUI/Main.hs --- threadscope-0.2.1/GUI/Main.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/Main.hs 2012-11-02 04:57:16.000000000 +0000 @@ -46,7 +46,7 @@ mainWin :: MainWindow.MainWindow, eventsView :: EventsView, startupView :: StartupInfoView, - summaryView :: InfoView, + summaryView :: SummaryView, histogramView :: HistogramView, timelineWin :: TimelineView, traceView :: TraceView, @@ -227,7 +227,12 @@ -- dispatch EventClearState _ - dispatch (EventSetState hecs mfilename name nevents timespan) _ = do + 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 $ @@ -243,16 +248,12 @@ timelineWindowSetHECs timelineWin (Just hecs) timelineWindowSetTraces timelineWin traces' - -- TODO: disabled for now, until it's configurable (see the TODO file) - -- We set user 'traceEvent' messages as initial bookmarks. - -- This is somewhat of an experiment. If users use lots of trace events - -- then it will not be appropriate and we'll want a separate 'traceMark'. - --let usrMsgs = extractUserMessages hecs - --sequence_ [ bookmarkViewAdd bookmarkView ts label - -- | (ts, label) <- usrMsgs ] - -- timelineWindowSetBookmarks timelineWin (map fst usrMsgs) + -- We set user 'traceMarker' events as initial bookmarks. + let usrMarkers = extractUserMarkers hecs bookmarkViewClear bookmarkView - timelineWindowSetBookmarks timelineWin [] + sequence_ [ bookmarkViewAdd bookmarkView ts label + | (ts, label) <- usrMarkers ] + timelineWindowSetBookmarks timelineWin (map fst usrMarkers) if nevents == 0 then continueWith NoEventlogLoaded @@ -362,6 +363,7 @@ timelineSetSelection timelineWin selection' eventsViewSetCursor eventsView cursorPos' Nothing histogramViewSetInterval histogramView Nothing + summaryViewSetInterval summaryView Nothing continueWith eventlogState { selection = selection', cursorPos = cursorPos' @@ -374,6 +376,7 @@ timelineSetSelection timelineWin selection' eventsViewSetCursor eventsView cursorPos' mrange histogramViewSetInterval histogramView (Just (start, end)) + summaryViewSetInterval summaryView (Just (start, end)) continueWith eventlogState { selection = selection', cursorPos = cursorPos' @@ -421,8 +424,11 @@ -- This is a desperate hack to avoid the "segfault on reload" bug -- http://trac.haskell.org/ThreadScope/ticket/1 -- It should be enough to let other threads finish and so avoid - -- re-entering gtk C code (see ticket for the dirty details) - threadDelay 100000 -- 1/10th of a second + -- 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 () diff -Nru threadscope-0.2.1/GUI/MainWindow.hs threadscope-0.2.2/GUI/MainWindow.hs --- threadscope-0.2.1/GUI/MainWindow.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/MainWindow.hs 2012-11-02 04:57:16.000000000 +0000 @@ -106,7 +106,6 @@ eventsBox <- getWidget castToWidget "eventsbox" bwToggle <- getWidget castToCheckMenuItem "black_and_white" --- TODO: tie in the button and the menu toggle and then re-enable: labModeToggle <- getWidget castToCheckMenuItem "view_labels_mode" sidebarToggle <- getWidget castToCheckMenuItem "view_sidebar" eventsToggle <- getWidget castToCheckMenuItem "view_events" diff -Nru threadscope-0.2.1/GUI/SaveAs.hs threadscope-0.2.2/GUI/SaveAs.hs --- threadscope-0.2.1/GUI/SaveAs.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/SaveAs.hs 2012-11-02 04:57:16.000000000 +0000 @@ -14,11 +14,11 @@ saveAs :: HECs -> ViewParameters -> Double -> DrawingArea -> (Int, Int, Render ()) saveAs hecs params' @ViewParameters{xScaleAreaHeight, width, - height = oldHeight, histogramHeight} + height = oldHeight {-, histogramHeight-}} yScaleAreaWidth yScaleArea = - let histTotalHeight = histogramHeight + histXScaleHeight + let histTotalHeight = histXScaleHeight -- + histogramHeight params@ViewParameters{height} = - params'{ viewTraces = viewTraces params' ++ [TraceHistogram] + params'{ viewTraces = viewTraces params' -- ++ [TraceHistogram] , height = oldHeight + histTotalHeight + tracePad } w = ceiling yScaleAreaWidth + width diff -Nru threadscope-0.2.1/GUI/SummaryView.hs threadscope-0.2.2/GUI/SummaryView.hs --- threadscope-0.2.1/GUI/SummaryView.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/SummaryView.hs 2012-11-02 04:57:16.000000000 +0000 @@ -1,80 +1,895 @@ module GUI.SummaryView ( - InfoView, + SummaryView, summaryViewNew, summaryViewSetEvents, + summaryViewSetInterval, ) where import GHC.RTS.Events -import GUI.Timeline.Render.Constants +import GUI.Types import Graphics.UI.Gtk -import Graphics.Rendering.Cairo import Data.Array import Data.IORef +import Data.Maybe +import Data.Word (Word64) +import Data.List as L +import qualified Data.IntMap as IM +import Control.Monad +import Control.Exception (assert) +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) ] + addGcColumn "Avg pause" $ \(GcStatsEntry _ _ _ _ avgpause _) -> + [ cellText := printf "%3.4fs" avgpause ] + addGcColumn "Max pause" $ \(GcStatsEntry _ _ _ _ _ maxpause) -> + [ cellText := printf "%3.4fs" maxpause ] + + 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 ]) $ + [ 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, 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 -data InfoView = InfoView - { gtkLayout :: !Layout - , stateRef :: !(IORef InfoState) - } - -data InfoState - = InfoEmpty - | InfoLoaded - { infoState :: String - } - -------------------------------------------------------------------------------- - -infoViewNew :: String -> Builder -> IO InfoView -infoViewNew widgetName builder = do - - stateRef <- newIORef undefined - let getWidget cast = builderGetObject builder cast - gtkLayout <- getWidget castToLayout widgetName - writeIORef stateRef InfoEmpty - let infoView = InfoView{..} - - -- Drawing - on gtkLayout exposeEvent $ liftIO $ do - drawInfo infoView =<< readIORef stateRef - return True - - return infoView - -summaryViewNew :: Builder -> IO InfoView -summaryViewNew = infoViewNew "eventsLayoutSummary" - -------------------------------------------------------------------------------- - -infoViewSetEvents :: (Array Int CapEvent -> InfoState) - -> InfoView -> Maybe (Array Int CapEvent) -> IO () -infoViewSetEvents f InfoView{gtkLayout, stateRef} mevents = do - let infoState = case mevents of - Nothing -> InfoEmpty - Just events -> f events - writeIORef stateRef infoState - widgetQueueDraw gtkLayout - -summaryViewProcessEvents :: Array Int CapEvent -> InfoState -summaryViewProcessEvents _events = InfoLoaded "TODO" - -summaryViewSetEvents :: InfoView -> Maybe (Array Int CapEvent) -> IO () -summaryViewSetEvents = infoViewSetEvents summaryViewProcessEvents - -------------------------------------------------------------------------------- - -drawInfo :: InfoView -> InfoState -> IO () -drawInfo _ InfoEmpty = return () -drawInfo InfoView{gtkLayout} InfoLoaded{..} = do - win <- layoutGetDrawWindow gtkLayout - pangoCtx <- widgetGetPangoContext gtkLayout - layout <- layoutText pangoCtx infoState - (_, Rectangle _ _ width height) <- layoutGetPixelExtents layout - layoutSetSize gtkLayout (width + 30) (height + 30) - renderWithDrawable win $ do - moveTo (fromIntegral ox / 2) (fromIntegral ox / 3) - showLayout layout + 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" + ModeStart -> error "scanEvents: GCStatsGHC ModeStart" + ModeGHC{} -> error "scanEvents: GCStatsGHC ModeGHC" + ModeEnd -> error "scanEvents: GCStatsGHC ModeEnd" + 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 (fromJust mcap) statsAccum ev diff -Nru threadscope-0.2.1/GUI/Timeline/HEC.hs threadscope-0.2.2/GUI/Timeline/HEC.hs --- threadscope-0.2.1/GUI/Timeline/HEC.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/Timeline/HEC.hs 2012-11-02 04:57:16.000000000 +0000 @@ -16,30 +16,36 @@ 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 -> (DurationTree,EventTree) +renderHEC :: ViewParameters -> Timestamp -> Timestamp + -> IM.IntMap String -> (DurationTree,EventTree) -> Render () -renderHEC params@ViewParameters{..} start end (dtree,etree) = do +renderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do renderDurations params start end dtree when (scaleValue < detailThreshold) $ case etree of - EventTree ltime etime tree -> - renderEvents params ltime etime start end tree + EventTree ltime etime tree -> do + renderEvents params ltime etime start end (fromIntegral detail) + perfNames tree + return () renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp - -> EventTree + -> IM.IntMap String -> EventTree -> Render () renderInstantHEC params@ViewParameters{..} start end - (EventTree ltime etime tree) = - renderEvents params ltime etime start end tree + perfNames (EventTree ltime etime tree) = do + let instantDetail = 1 + renderEvents params ltime etime start end instantDetail perfNames tree + return () detailThreshold :: Double detailThreshold = 3 ------------------------------------------------------------------------------- --- hecView draws the trace for a single HEC +-- draws the trace for a single HEC renderDurations :: ViewParameters -> Timestamp -> Timestamp -> DurationTree @@ -56,11 +62,11 @@ | startPos < splitTime && endPos >= splitTime && (fromIntegral (e - s) / scaleValue) <= fromIntegral detail = -- View spans both left and right sub-tree. - -- trace (printf "hecView (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $ + -- 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 "hecView: start:%d end:%d s:%d e:%d" startPos endPos s e) $ + = -- 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) $ @@ -71,32 +77,47 @@ renderEvents :: ViewParameters -> Timestamp -- start time of this tree node -> Timestamp -- end time of this tree node - -> Timestamp -> Timestamp -> EventNode - -> Render () - -renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos - (EventTreeLeaf es) - = sequence_ [ drawEvent params e - | e <- es, let t = time e, t >= startPos && t < endPos ] -renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos - (EventTreeOne ev) - | t >= startPos && t < endPos = drawEvent params ev - | otherwise = return () + -> 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 - (EventSplit splitTime lhs rhs) +renderEvents params@ViewParameters{..} !s !e !startPos !endPos ewidth + perfNames (EventSplit splitTime lhs rhs) | startPos < splitTime && endPos >= splitTime && - (fromIntegral (e - s) / scaleValue) <= fromIntegral detail - -- was: = drawTooManyEvents params s e - -- is: draw only the right hand side (let's say it overwrites LHS) - = renderEvents params splitTime e startPos endPos rhs - + (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 when (startPos < splitTime) $ - renderEvents params s splitTime startPos endPos lhs - when (endPos >= splitTime) $ - renderEvents params splitTime e startPos endPos rhs + = 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. @@ -217,48 +238,56 @@ showText str restore -drawEvent :: ViewParameters -> GHC.Event -> Render () -drawEvent params@ViewParameters{..} event - = case spec event of - CreateThread{} -> renderInstantEvent params event createThreadColour - RequestSeqGC{} -> renderInstantEvent params event seqGCReqColour - RequestParGC{} -> renderInstantEvent params event parGCReqColour - MigrateThread{} -> renderInstantEvent params event migrateThreadColour - WakeupThread{} -> renderInstantEvent params event threadWakeupColour - Shutdown{} -> renderInstantEvent params event shutdownColour - - SparkCreate{} -> renderInstantEvent params event createdConvertedColour - SparkDud{} -> renderInstantEvent params event fizzledDudsColour - SparkOverflow{} -> renderInstantEvent params event overflowedColour - SparkRun{} -> renderInstantEvent params event createdConvertedColour - SparkSteal{} -> renderInstantEvent params event createdConvertedColour - SparkFizzle{} -> renderInstantEvent params event fizzledDudsColour - SparkGC{} -> renderInstantEvent params event gcColour - - UserMessage{} -> renderInstantEvent params event userMessageColour - - RunThread{} -> return () - StopThread{} -> return () - StartGC{} -> return () - - _ -> return () - -renderInstantEvent :: ViewParameters -> GHC.Event -> Color -> Render () -renderInstantEvent ViewParameters{..} event color = do +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 (3 * scaleValue) + setLineWidth (ewidth * scaleValue) let t = time event draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4) - labelAt labelsMode t $ showEventInfo (spec event) - - -_drawTooManyEvents :: ViewParameters -> Timestamp -> Timestamp - -> Render () -_drawTooManyEvents _params@ViewParameters{..} _start _end = do - return () --- setSourceRGBAhex grey 1.0 --- setLineWidth (3 * scaleValue) --- draw_rectangle start (hecBarOff-4) (end - start) 4 --- draw_rectangle start (hecBarOff+hecBarHeight) (end - start) 4 + 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 ------------------------------------------------------------------------------- diff -Nru threadscope-0.2.1/GUI/Timeline/Render.hs threadscope-0.2.2/GUI/Timeline/Render.hs --- threadscope-0.2.1/GUI/Timeline/Render.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/Timeline/Render.hs 2012-11-02 04:57:16.000000000 +0000 @@ -211,10 +211,12 @@ case trace of TraceHEC c -> let (dtree, etree, _) = hecTrees hecs !! c - in renderHEC params startPos endPos (dtree, etree) + in renderHEC params startPos endPos + (perfNames hecs) (dtree, etree) TraceInstantHEC c -> let (_, etree, _) = hecTrees hecs !! c - in renderInstantHEC params startPos endPos etree + in renderInstantHEC params startPos endPos + (perfNames hecs) etree TraceCreationHEC c -> renderSparkCreation params slice start end (prof !! c) TraceConversionHEC c -> diff -Nru threadscope-0.2.1/GUI/Timeline/Ticks.hs threadscope-0.2.2/GUI/Timeline/Ticks.hs --- threadscope-0.2.1/GUI/Timeline/Ticks.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/Timeline/Ticks.hs 2012-11-02 04:57:16.000000000 +0000 @@ -61,12 +61,15 @@ drawVRulers tickWidthInPixels scaleValue pos incr endPos height i = if floor pos <= endPos then do when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do - draw_line (round pos, 0) (round pos, height) + 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 @@ -91,19 +94,22 @@ renderXScale scaleValue hadjValue lastTx width off xScaleMode = do let scale_width = fromIntegral width * scaleValue startPos :: Timestamp - startPos = truncate hadjValue + 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 - scale (1/scaleValue) 1.0 - translate (-hadjValue) 0 + 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 -- TODO: it's not really 1 pixel, due to the scale - -- TODO: snap to pixels, currently looks semi-transparent - draw_line (startPos, off 16) (endPos, off 16) + setLineWidth 1.0 + draw_line (startLine, off 16) (endLine, off 16) let tFor100Pixels = truncate (100 * scaleValue) snappedTickDuration :: Timestamp snappedTickDuration = @@ -113,7 +119,6 @@ tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue firstTick :: Timestamp firstTick = snappedTickDuration * (startPos `div` snappedTickDuration) - setLineWidth scaleValue -- TODO: should be 0.5 pixels (when we rewrite stuff) case xScaleMode of XScaleTime -> drawXTicks tickWidthInPixels scaleValue (fromIntegral firstTick) @@ -129,19 +134,16 @@ -> Render () drawXTicks tickWidthInPixels scaleValue pos incr endPos off xScaleMode i = if floor pos <= endPos then do - -- TODO: snap to pixels, currently looks semi-transparent when (pos /= 0 || xScaleMode == XScaleTime) $ - draw_line (x1, off 16) (x1, off (16 - tickLength)) + 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 textPos - m <- getMatrix - identityMatrix + move_to (floor $ fromIntegral textPosX / scaleValue, textPosY) when (floor (pos + incr) <= endPos && (tExtentWidth + tExtentWidth / 3 < width || atMajorTick)) $ showText tickTimeText - setMatrix m drawXTicks tickWidthInPixels scaleValue (pos + incr) incr endPos off xScaleMode (i+1) else @@ -149,7 +151,7 @@ where atMidTick = xScaleMode == XScaleTime && i `mod` 5 == 0 atMajorTick = xScaleMode == XScaleTime && i `mod` 10 == 0 - textPos = + (textPosX, textPosY) = if xScaleMode == XScaleTime then (x1 + ceiling (scaleValue * 3), off (-3)) else (x1 + ceiling (scaleValue * 2), tickLength + 13) @@ -157,7 +159,7 @@ | atMidTick = 10 | otherwise = if xScaleMode == XScaleTime then 6 else 8 posTime = case xScaleMode of - XScaleTime -> round pos + XScaleTime -> round pos XScaleLog minX _ -> round $ 2 ** (minX + pos / incr) tickTimeText = showMultiTime posTime width = if atMidTick then 5 * tickWidthInPixels @@ -257,11 +259,14 @@ | atMidTick = 9 | otherwise = 6 reformatV :: Double -> String - reformatV v = deZero (printf "%.2f" v) + reformatV v = + if v < 0.01 && v > 0 + then eps + else deZero (printf "%.2f" v) ------------------------------------------------------------------------------- --- | The 'micro' symbol. +-- | 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. @@ -272,6 +277,18 @@ 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 diff -Nru threadscope-0.2.1/GUI/ViewerColours.hs threadscope-0.2.2/GUI/ViewerColours.hs --- threadscope-0.2.1/GUI/ViewerColours.hs 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/GUI/ViewerColours.hs 2012-11-02 04:57:16.000000000 +0000 @@ -43,7 +43,7 @@ shutdownColour = darkBrown labelTextColour :: Color -labelTextColour = black +labelTextColour = white bookmarkColour :: Color bookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish diff -Nru threadscope-0.2.1/LICENSE threadscope-0.2.2/LICENSE --- threadscope-0.2.1/LICENSE 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/LICENSE 2012-11-02 04:57:16.000000000 +0000 @@ -1,31 +1,31 @@ -The Glasgow Haskell Compiler License - -Copyright 2002, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. +The Glasgow Haskell Compiler License + +Copyright 2002-2012, The University Court of the University of Glasgow +and others. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff -Nru threadscope-0.2.1/debian/changelog threadscope-0.2.2/debian/changelog --- threadscope-0.2.1/debian/changelog 2012-03-13 19:14:19.000000000 +0000 +++ threadscope-0.2.2/debian/changelog 2013-05-24 10:52:49.000000000 +0000 @@ -1,3 +1,18 @@ +threadscope (0.2.2-2) unstable; urgency=low + + * Enable compat level 9 + + -- Joachim Breitner Fri, 24 May 2013 12:52:49 +0200 + +threadscope (0.2.2-1) experimental; urgency=low + + * Depend on haskell-devscripts 0.8.13 to ensure this packages is built + against experimental + * Bump standards version, no change + * New upstream release + + -- Joachim Breitner Thu, 08 Nov 2012 19:36:10 +0100 + threadscope (0.2.1-1) unstable; urgency=low * New upstream release diff -Nru threadscope-0.2.1/debian/compat threadscope-0.2.2/debian/compat --- threadscope-0.2.1/debian/compat 2012-03-13 14:40:45.000000000 +0000 +++ threadscope-0.2.2/debian/compat 2013-05-24 07:55:49.000000000 +0000 @@ -1 +1 @@ -7 +9 diff -Nru threadscope-0.2.1/debian/control threadscope-0.2.2/debian/control --- threadscope-0.2.1/debian/control 2012-03-13 14:42:30.000000000 +0000 +++ threadscope-0.2.2/debian/control 2013-05-24 08:21:21.000000000 +0000 @@ -3,20 +3,19 @@ Priority: extra Maintainer: Debian Haskell Group Uploaders: Ernesto Hernández-Novich (USB) -Build-Depends: debhelper (>= 7), cdbs, haskell-devscripts (>= 0.7), +Build-Depends: debhelper (>= 9), cdbs, haskell-devscripts (>= 0.8.13), ghc, libghc-mtl-dev, - libghc-ghc-events-dev (>= 0.4), - libghc-ghc-events-dev (<< 0.5), + libghc-ghc-events-dev (>= 0.4.2), libghc-cairo-dev, libghc-gtk-dev (>= 0.12), libghc-cairo-dev, libghc-glib-dev, libghc-pango-dev -Standards-Version: 3.9.2 +Standards-Version: 3.9.4 Homepage: http://hackage.haskell.org/package/threadscope -Vcs-Darcs: http://darcs.debian.org/pkg-haskell/haskell-threadscope -Vcs-Browser: http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=haskell/haskell-threadscope +Vcs-Darcs: http://darcs.debian.org/pkg-haskell/threadscope +Vcs-Browser: http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/threadscope Package: threadscope Architecture: any diff -Nru threadscope-0.2.1/debian/rules threadscope-0.2.2/debian/rules --- threadscope-0.2.1/debian/rules 2012-03-13 19:09:46.000000000 +0000 +++ threadscope-0.2.2/debian/rules 2012-10-13 11:46:04.000000000 +0000 @@ -9,6 +9,4 @@ install/$(CABAL_PACKAGE) :: build/$(CABAL_PACKAGE) $(DEB_SETUP_BIN_NAME) copy --builddir=dist-ghc --destdir=debian/$(CABAL_PACKAGE) - rm -rf debian/threadscope/usr/share/doc - - + rm -rf debian/$(CABAL_PACKAGE)/usr/share/doc diff -Nru threadscope-0.2.1/threadscope.cabal threadscope-0.2.2/threadscope.cabal --- threadscope-0.2.1/threadscope.cabal 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/threadscope.cabal 2012-11-02 04:57:16.000000000 +0000 @@ -1,5 +1,5 @@ Name: threadscope -Version: 0.2.1 +Version: 0.2.2 Category: Development, Profiling, Trace Synopsis: A graphical tool for profiling parallel Haskell programs. Description: ThreadScope is a graphical viewer for thread profile @@ -16,9 +16,9 @@ Copyright: 2009-2010 Satnam Singh, 2009-2011 Simon Marlow, 2009 Donnie Jones, - 2011 Duncan Coutts, - 2011 Mikolaj Konarski - 2011 Nicolas Wu + 2011-2012 Duncan Coutts, + 2011-2012 Mikolaj Konarski, + 2011 Nicolas Wu, 2011 Eric Kow Author: Satnam Singh , Simon Marlow , @@ -27,7 +27,7 @@ Mikolaj Konarski , Nicolas Wu , Eric Kow -Maintainer: Satnam Singh +Maintainer: Simon Marlow Homepage: http://www.haskell.org/haskellwiki/ThreadScope Bug-reports: http://trac.haskell.org/ThreadScope/ Build-Type: Simple @@ -43,8 +43,8 @@ Build-Depends: base >= 4.0 && < 5, gtk >= 0.12, cairo, glib, pango, binary, array, mtl, filepath, - ghc-events == 0.4.*, - containers >= 0.2 && < 0.5, + ghc-events >= 0.4.2, + containers >= 0.2 && < 0.6, deepseq >= 1.1, time >= 1.1 Extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards @@ -92,4 +92,4 @@ ghc-options: -fno-warn-unused-matches if !os(windows) - build-depends: unix >= 2.3 && < 2.6 + build-depends: unix >= 2.3 && < 2.7 diff -Nru threadscope-0.2.1/threadscope.ui threadscope-0.2.2/threadscope.ui --- threadscope-0.2.1/threadscope.ui 2012-01-14 02:08:07.000000000 +0000 +++ threadscope-0.2.2/threadscope.ui 2012-11-02 04:57:16.000000000 +0000 @@ -1,50 +1,37 @@ - True - False gtk-refresh True - False - - - True - False gtk-save-as True - False gtk-goto-first True - False gtk-home True - False gtk-goto-last True - False gtk-zoom-in True - False gtk-zoom-out True - False gtk-zoom-fit @@ -57,28 +44,21 @@ True - False True - False True - False - False _File True True - False gtk-open True - False - False True True @@ -88,8 +68,6 @@ Export image... True - False - False image2 False @@ -97,15 +75,12 @@ True - False gtk-quit True - False - False True True @@ -118,19 +93,14 @@ True - False - False _View True True - False True - False - False Sidebar True True @@ -139,8 +109,6 @@ True - False - False Information pane True True @@ -149,8 +117,6 @@ True - False - False Black & white True @@ -158,8 +124,6 @@ True - False - False Event labels True @@ -167,15 +131,12 @@ True - False _Reload True - False - False True image1 False @@ -189,20 +150,15 @@ True - False - False _Move True True - False Jump to start True - False - False True image4 False @@ -212,8 +168,6 @@ Centre on cursor True - False - False True image5 False @@ -223,8 +177,6 @@ Jump to end True - False - False True image6 False @@ -233,15 +185,12 @@ True - False Zoom in True - False - False True image7 False @@ -251,8 +200,6 @@ Zoom out True - False - False True image8 False @@ -262,8 +209,6 @@ Fit to window True - False - False True image9 False @@ -276,19 +221,14 @@ True - False - False Help True True - False True - False - False Online tutorial True @@ -296,8 +236,6 @@ True - False - False Website True @@ -305,16 +243,12 @@ True - False - False gtk-about True - False - False True True @@ -333,15 +267,12 @@ True - False both-horiz False True - False Open an eventlog - False True gtk-open @@ -353,7 +284,6 @@ True - False False @@ -362,9 +292,7 @@ True - False Jump to the start - False True gtk-goto-first @@ -376,9 +304,7 @@ True - False Centre view on the cursor - False gtk-home @@ -389,9 +315,7 @@ True - False Jump to the end - False True gtk-goto-last @@ -403,7 +327,6 @@ True - False False @@ -412,9 +335,7 @@ True - False Zoom in - False gtk-zoom-in @@ -425,9 +346,7 @@ True - False Zoom out - False gtk-zoom-out @@ -438,9 +357,7 @@ True - False Fit view to the window - False gtk-zoom-fit @@ -463,6 +380,7 @@ True True + sidepane True @@ -472,17 +390,18 @@ True - False False False + + True + True - False Key @@ -506,12 +425,12 @@ 1 + True True - False Traces @@ -522,18 +441,14 @@ True - False True - False both-horiz False True - False - False True gtk-jump-to @@ -545,8 +460,6 @@ True - False - False Bookmark True gtk-add @@ -559,8 +472,6 @@ True - False - False gtk-remove @@ -598,12 +509,12 @@ 2 + True True - False Bookmarks @@ -624,11 +535,9 @@ True - False True - False 0 4 4 @@ -644,7 +553,6 @@ True - False 2 2 3 @@ -652,7 +560,6 @@ True - False 1 @@ -663,7 +570,6 @@ True - False False 0 @@ -683,14 +589,12 @@ True - False 2 2 110 True - False 1 @@ -702,7 +606,6 @@ 38 True - False 1 @@ -749,16 +652,143 @@ True True + infopane - + + True True - True automatic automatic - + True - False + 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 + + + + @@ -767,41 +797,40 @@ - - False - True - Summary stats + + 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 - False + queue - + True - False - 4 + 8 5 - 2 + 5 8 4 - + True - False 0 0 - Executable: + Maximum heap size: GTK_FILL @@ -809,12 +838,11 @@ - + True - False 0 0 - Arguments: + Maximum heap residency: 1 @@ -824,12 +852,11 @@ - + True - False 0 0 - Start time: + Total allocated: 2 @@ -839,142 +866,375 @@ - + True - False - 0 + True + 1 0 - RTS Id: + True + 6 - 3 - 4 + 1 + 2 GTK_FILL GTK_FILL - + True - False - 0 + True + 1 0 - Environment: + True + 6 - 4 - 5 + 1 + 2 + 2 + 3 GTK_FILL GTK_FILL - + True True - The name and path of the program's executable file - 0 + 1 0 True + 6 1 2 + 1 + 2 + GTK_FILL GTK_FILL - + True - True - The time at which the program was started 0 0 - True + Allocation rate: - 1 - 2 - 2 - 3 + 3 + 4 + GTK_FILL GTK_FILL - + True True - automatic - automatic - - - True - True - The arguments supplied when the program was run - False - - + 1 + 0 + True + 6 1 2 - 1 - 2 + 3 + 4 + GTK_FILL + GTK_FILL - + True - True - automatic - automatic - - - True - True - The environment variables available when the program was started - False - - + 0 + 0 + Maximum slop: - 1 - 2 4 5 + GTK_FILL + GTK_FILL - + True True - The name and version of the compiler/runtime used by the program - 0 + 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 - False - Startup info + Summary statistics about the heap +(for the full run or the selected time period) + Heap 1 @@ -982,15 +1242,211 @@ + + 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 - False 2 110 True - False 1 @@ -1018,25 +1474,224 @@ - 2 + 4 True - + True - False + A histogram of how long each spark took to evaluate, +either for the whole program or the selected time period. Spark sizes - 2 + 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 - False True @@ -1044,10 +1699,6 @@ ● 20 gtk-find - False - False - True - True Search for event @@ -1060,12 +1711,10 @@ 120 True - False 3 True - False queue @@ -1083,7 +1732,6 @@ True - False adjustment1 @@ -1101,18 +1749,19 @@ - 3 + 6 True True - False + The raw events from the eventlog. +The selection is synchronised with the timeline. Raw events - 3 + 6 False @@ -1138,7 +1787,6 @@ True - False False @@ -1149,10 +1797,4 @@ - - - - - -