diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for threadscope +## 2021-01-09 - v0.2.14 + +* Print times with more sensible units [#111](https://github.com/haskell/ThreadScope/pull/111) +* EventDuration: Make it more robust to truncated eventlogs [#110](https://github.com/haskell/ThreadScope/pull/110) +* Use GitHub Actions for CI [#113](https://github.com/haskell/ThreadScope/pull/113) +* Relax upper version bounds for ghc-events, time, bytestring, and template-haskell + ## 2020-04-06 - v0.2.13 * Add changelog to extra-source-files ([#105](https://github.com/haskell/ThreadScope/pull/105)) diff --git a/Events/EventDuration.hs b/Events/EventDuration.hs --- a/Events/EventDuration.hs +++ b/Events/EventDuration.hs @@ -9,6 +9,9 @@ isDiscreteEvent ) where +import System.IO +import System.IO.Unsafe + -- Imports for GHC Events import GHC.RTS.Events hiding (Event, GCIdle, GCWork) import qualified GHC.RTS.Events as GHC @@ -87,7 +90,9 @@ eventsToDurations [] = [] eventsToDurations (event : events) = case evSpec event of - RunThread{thread=t} -> runDuration t : rest + RunThread{thread=t} + | Just ev <- runDuration t -> ev : rest + | otherwise -> rest StopThread{} -> rest StartGC -> gcStart (evTime event) events EndGC{} -> rest @@ -95,10 +100,10 @@ where rest = eventsToDurations events - runDuration t = ThreadRun t s (evTime event) endTime - where (endTime, s) = case findRunThreadTime events of - Nothing -> error $ "findRunThreadTime for " ++ (show event) - Just x -> x + runDuration :: ThreadId -> Maybe EventDuration + runDuration t = do + (endTime, s) <- findRunThreadTime events + return $ ThreadRun t s (evTime event) endTime isDiscreteEvent :: GHC.Event -> Bool isDiscreteEvent e = @@ -172,6 +177,11 @@ findRunThreadTime (e : es) = case evSpec e of StopThread{status=s} -> Just (evTime e, s) - _ -> findRunThreadTime es + _ | [] <- es -> unsafePerformIO $ do + hPutStrLn stderr "warning: failed to find stop event for thread; eventlog truncated?" + return $ Just (evTime e, NoStatus) + -- the eventlog abruptly ended; presumably the + -- thread was still running. + | otherwise -> findRunThreadTime es ------------------------------------------------------------------------------- diff --git a/GUI/Main.hs b/GUI/Main.hs --- a/GUI/Main.hs +++ b/GUI/Main.hs @@ -86,7 +86,6 @@ | EventFileReload | EventFileExport FilePath FileExportFormat --- | EventStateClear | EventSetState HECs (Maybe FilePath) String Int Double | EventShowSidebar Bool diff --git a/GUI/SummaryView.hs b/GUI/SummaryView.hs --- a/GUI/SummaryView.hs +++ b/GUI/SummaryView.hs @@ -186,9 +186,9 @@ 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") + [ (labelTimeTotal , showTimeWithUnit timeTotal) + , (labelTimeMutator , showTimeWithUnit timeMutator) + , (labelTimeGC , showTimeWithUnit timeGC) , (labelTimeProductivity, showFFloat (Just 1) (timeProductivity * 100) "% of mutator vs total") ] @@ -562,6 +562,17 @@ ------------------------------------------------------------------------------ + +showTimeWithUnit :: Integral a => a -> String +showTimeWithUnit t = + showFFloat (Just 3) t'' unit + where + (t'', unit) = + case timeToSecondsDbl t of + t' | t' < 1e-6 -> (t' / 1e-9, "ns") + | t' < 1e-3 -> (t' / 1e-6, "μs") + | t' < 1 -> (t' / 1e-3, "ms") + | otherwise -> (t', "s") timeToSecondsDbl :: Integral a => a -> Double timeToSecondsDbl t = timeToSeconds $ fromIntegral t diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -133,7 +133,7 @@ ----------------------------------------------------------------------------- timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView -timelineViewNew builder actions@TimelineViewActions{..} = do +timelineViewNew builder actions = do let getWidget cast = builderGetObject builder cast timelineViewport <- getWidget castToWidget "timeline_viewport" @@ -218,15 +218,15 @@ mouseStateVar <- newIORef None let withMouseState action = liftIO $ do - st <- readIORef mouseStateVar - st' <- action st - writeIORef mouseStateVar st' + 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) + withMouseState (\st -> mousePress timelineWin st button x) return False on timelineDrawingArea buttonReleaseEvent $ do @@ -396,9 +396,9 @@ | DragLeft !Double -- dragging with left mouse button | DragMiddle !Double !Double -- dragging with middle mouse button -mousePress :: TimelineView -> TimelineViewActions +mousePress :: TimelineView -> MouseState -> MouseButton -> Double -> IO MouseState -mousePress view@TimelineView{..} TimelineViewActions{..} state button x = +mousePress view@TimelineView{..} state button x = case (state, button) of (None, LeftButton) -> do xv <- viewPointToTime view x -- update the view without notifying the client diff --git a/GUI/Timeline/HEC.hs b/GUI/Timeline/HEC.hs --- a/GUI/Timeline/HEC.hs +++ b/GUI/Timeline/HEC.hs @@ -43,7 +43,7 @@ renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp -> IM.IntMap Text -> EventTree -> Render () -renderInstantHEC params@ViewParameters{..} start end +renderInstantHEC params start end perfNames (EventTree ltime etime tree) = do let instantDetail = 1 renderEvents params ltime etime start end instantDetail perfNames tree @@ -61,7 +61,7 @@ renderDurations _ _ _ DurationTreeEmpty = return () -renderDurations params@ViewParameters{..} startPos endPos (DurationTreeLeaf e) +renderDurations params startPos endPos (DurationTreeLeaf e) | inView startPos endPos e = drawDuration params e | otherwise = return () @@ -89,7 +89,7 @@ -> IM.IntMap Text -> EventNode -> Render Bool -renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth +renderEvents params !_s !_e !startPos !endPos ewidth perfNames (EventTreeLeaf es) = let within = [ e | e <- es, let t = evTime e, t >= startPos && t < endPos ] untilTrue _ [] = return False @@ -98,7 +98,7 @@ if b then return b else untilTrue f xs in untilTrue (drawEvent params ewidth perfNames) within -renderEvents params@ViewParameters{..} !_s !_e !startPos !endPos ewidth +renderEvents params !_s !_e !startPos !endPos ewidth perfNames (EventTreeOne ev) | t >= startPos && t < endPos = drawEvent params ewidth perfNames ev | otherwise = return False @@ -248,7 +248,7 @@ drawEvent :: ViewParameters -> Double -> IM.IntMap Text -> GHC.Event -> Render Bool -drawEvent params@ViewParameters{..} ewidth perfNames event = +drawEvent params ewidth perfNames event = let renderI = renderInstantEvent params perfNames event ewidth in case evSpec event of CreateThread{} -> renderI createThreadColour diff --git a/GUI/Timeline/Render.hs b/GUI/Timeline/Render.hs --- a/GUI/Timeline/Render.hs +++ b/GUI/Timeline/Render.hs @@ -76,51 +76,51 @@ 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 + 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 + surface <- + case prev_view of + Nothing -> renderToNewSurface - Just (old_params, surface) - | old_params == params - -> return surface + 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 + | 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 + | otherwise + -> do surfaceFinish surface + renderToNewSurface - liftIO $ writeIORef timelinePrevView (Just (params, surface)) + 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 + 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 ------------------------------------------------------------------------------- @@ -250,7 +250,7 @@ renderSparkConversion params slice start end (prof !! c) TracePoolHEC c -> let maxP = maxSparkPool hecs - in renderSparkPool params slice start end (prof !! c) maxP + in renderSparkPool slice start end (prof !! c) maxP TraceHistogram -> renderSparkHistogram params hecs TraceGroup _ -> error "renderTrace" diff --git a/GUI/Timeline/Sparks.hs b/GUI/Timeline/Sparks.hs --- a/GUI/Timeline/Sparks.hs +++ b/GUI/Timeline/Sparks.hs @@ -67,10 +67,10 @@ renderSpark params slice start end prof f1 createdConvertedColour f2 fizzledDudsColour f3 gcColour -renderSparkPool :: ViewParameters -> Timestamp -> Timestamp -> Timestamp +renderSparkPool :: Timestamp -> Timestamp -> Timestamp -> [SparkStats.SparkStats] -> Double -> Render () -renderSparkPool ViewParameters{..} !slice !start !end prof !maxSparkPool = do +renderSparkPool !slice !start !end prof !maxSparkPool = do let f1 c = SparkStats.minPool c f2 c = SparkStats.meanPool c f3 c = SparkStats.maxPool c diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -38,14 +38,15 @@ Then you can build threadscope using cabal: ```sh -cabal v2-build +cabal v2-build # to only build the project, or +cabal v2-install # to build and install the binary ``` Or using stack: ```sh -stack setup -stack install +stack build # to only build the project, or +stack install # to build and install the binary ``` ### OS X @@ -59,14 +60,15 @@ Then you can build threadscope using cabal: ```sh -cabal v2-build --project-file=cabal.project.osx +cabal --project-file=cabal.project.osx v2-build # to only build the project, or +cabal --project-file=cabal.project.osx v2-install # to build and install the binary ``` Or using stack: ```sh -stack setup -stack install --flag gtk:have-quartz-gtk +stack --stack-yaml=stack.osx.yaml build # to only build the project, or +stack --stack-yaml=stack.osx.yaml install # to install the binary ``` ### Windows diff --git a/threadscope.cabal b/threadscope.cabal --- a/threadscope.cabal +++ b/threadscope.cabal @@ -1,5 +1,6 @@ +Cabal-version: 1.24 Name: threadscope -Version: 0.2.13 +Version: 0.2.14 Category: Development, Profiling, Trace Synopsis: A graphical tool for profiling parallel Haskell programs. Description: ThreadScope is a graphical viewer for thread profile @@ -31,7 +32,6 @@ 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 Extra-source-files: include/windows_cconv.h README.md @@ -39,7 +39,8 @@ Tested-with: GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.5 - GHC == 8.8.2 + GHC == 8.8.4 + GHC == 8.10.3 source-repository head type: git @@ -56,18 +57,18 @@ array < 0.6, mtl < 2.3, filepath < 1.5, - ghc-events >= 0.13 && < 0.14, + ghc-events >= 0.13 && < 0.16, containers >= 0.2 && < 0.7, deepseq >= 1.1, text < 1.3, - time >= 1.1 && < 1.11, - bytestring < 0.11, + time >= 1.1 && < 1.12, + bytestring < 0.12, file-embed < 0.1, - template-haskell < 2.16, + template-haskell < 2.17, temporary >= 1.1 && < 1.4 include-dirs: include - Extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards + default-extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards Other-Modules: Events.HECs, Events.EventDuration, Events.EventTree, @@ -117,3 +118,5 @@ if !os(windows) build-depends: unix >= 2.3 && < 2.8 + + default-language: Haskell2010