threadscope 0.2.13 → 0.2.14
raw patch · 10 files changed
+110/−78 lines, 10 filesdep ~bytestringdep ~ghc-eventsdep ~template-haskell
Dependency ranges changed: bytestring, ghc-events, template-haskell, time
Files
- CHANGELOG.md +7/−0
- Events/EventDuration.hs +16/−6
- GUI/Main.hs +0/−1
- GUI/SummaryView.hs +14/−3
- GUI/Timeline.hs +7/−7
- GUI/Timeline/HEC.hs +5/−5
- GUI/Timeline/Render.hs +40/−40
- GUI/Timeline/Sparks.hs +2/−2
- README.md +8/−6
- threadscope.cabal +11/−8
CHANGELOG.md view
@@ -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))
Events/EventDuration.hs view
@@ -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 -------------------------------------------------------------------------------
GUI/Main.hs view
@@ -86,7 +86,6 @@ | EventFileReload | EventFileExport FilePath FileExportFormat --- | EventStateClear | EventSetState HECs (Maybe FilePath) String Int Double | EventShowSidebar Bool
GUI/SummaryView.hs view
@@ -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
GUI/Timeline.hs view
@@ -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
GUI/Timeline/HEC.hs view
@@ -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
GUI/Timeline/Render.hs view
@@ -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"
GUI/Timeline/Sparks.hs view
@@ -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
README.md view
@@ -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
threadscope.cabal view
@@ -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