Showing preview only (571K chars total). Download the full file or copy to clipboard to get everything.
Repository: haskell/ThreadScope
Branch: master
Commit: 5682975d3816
Files: 81
Total size: 543.7 KB
Directory structure:
gitextract_n4vjqfzb/
├── .github/
│ └── workflows/
│ └── ci.yml
├── .gitignore
├── CHANGELOG.md
├── Events/
│ ├── EventDuration.hs
│ ├── EventTree.hs
│ ├── HECs.hs
│ ├── ReadEvents.hs
│ ├── SparkStats.hs
│ ├── SparkTree.hs
│ └── TestEvents.hs
├── GUI/
│ ├── App.hs
│ ├── BookmarkView.hs
│ ├── ConcurrencyControl.hs
│ ├── DataFiles.hs
│ ├── Dialogs.hs
│ ├── EventsView.hs
│ ├── GtkExtras.hs
│ ├── Histogram.hs
│ ├── KeyView.hs
│ ├── Main.hs
│ ├── MainWindow.hs
│ ├── ProgressView.hs
│ ├── SaveAs.hs
│ ├── StartupInfoView.hs
│ ├── SummaryView.hs
│ ├── Timeline/
│ │ ├── Activity.hs
│ │ ├── CairoDrawing.hs
│ │ ├── HEC.hs
│ │ ├── Motion.hs
│ │ ├── Render/
│ │ │ └── Constants.hs
│ │ ├── Render.hs
│ │ ├── Sparks.hs
│ │ ├── Ticks.hs
│ │ └── Types.hs
│ ├── Timeline.hs
│ ├── TraceView.hs
│ ├── Types.hs
│ └── ViewerColours.hs
├── Graphics/
│ └── UI/
│ └── Gtk/
│ └── ModelView/
│ └── TreeView/
│ └── Compat.hs
├── LICENSE
├── Main.hs
├── Makefile
├── README.md
├── Setup.hs
├── TODO
├── cabal.project
├── cabal.project.osx
├── include/
│ └── windows_cconv.h
├── index.html
├── papers/
│ └── haskell_symposium_2009/
│ ├── Makefile
│ ├── bsort/
│ │ ├── BSort.hs
│ │ ├── BSortPar.hs
│ │ ├── BSortPar2.hs
│ │ ├── BSortStreaming.hs
│ │ └── Makefile
│ ├── bsort.tex
│ ├── fib/
│ │ ├── Fib1.hs
│ │ ├── Fib2.hs
│ │ └── Makefile
│ ├── ghc-parallel-tuning.bib
│ ├── ghc-parallel-tuning.tex
│ ├── infrastructure.tex
│ ├── motivation.tex
│ ├── related-work.tex
│ ├── sigplanconf.cls
│ ├── sumEuler/
│ │ ├── Makefile
│ │ ├── SumEuler0.hs
│ │ ├── SumEuler1.hs
│ │ ├── SumEuler2.hs
│ │ └── SumEuler3.hs
│ └── threadring.tex
├── scripts/
│ └── install-on-osx.sh
├── stack.osx.yaml
├── stack.yaml
├── tests/
│ ├── Hello.hs
│ ├── Makefile
│ ├── Null.hs
│ ├── ParFib.hs
│ └── SumEulerPar1.hs
├── threadscope.cabal
└── threadscope.ui
================================================
FILE CONTENTS
================================================
================================================
FILE: .github/workflows/ci.yml
================================================
name: CI
on:
push:
branches:
- master
tags:
- v*
pull_request:
release:
env:
GHC_FOR_RELEASE: "9.10"
jobs:
build:
name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} ${{matrix.container}}
strategy:
fail-fast: false
matrix:
os: [ubuntu-latest]
ghc-version: ['9.12', '9.10', '9.8', '9.6', '9.4', '9.2']
container: ['']
include:
# The windows build is currently broken
# See #135
- os: windows-latest
ghc-version: '9.10'
- os: macos-latest
ghc-version: '9.10'
# gtk2hs is broken under apline
# See https://github.com/gtk2hs/gtk2hs/issues/262
#- os: ubuntu-latest
# ghc-version: '9.10'
# container: alpine:3.21
runs-on: ${{ matrix.os }}
container: ${{ matrix.container }}
steps:
- uses: actions/checkout@v4
- name: Install system dependencies (Alpine)
if: ${{ startsWith(matrix.container, 'alpine') }}
shell: sh
run: |
apk add bash curl sudo jq pkgconfig \
zlib-dev zlib-static binutils curl \
gcc g++ gmp-dev libc-dev libffi-dev make \
musl-dev ncurses-dev perl tar xz \
gtk+3.0-dev
- name: Install system dependencies (Ubuntu)
if: runner.os == 'Linux' && !startsWith(matrix.container, 'alpine')
run: sudo apt-get update && sudo apt-get install libgtk-3-dev
- name: Install system dependencies (macOS)
if: runner.os == 'macOS'
run: brew install cairo gtk+3 pkg-config
- name: Set extra cabal build options (macOS)
if: runner.os == 'macOS'
run: |
printf 'package gtk\n flags: +have-quartz-gtk' >>cabal.project
- name: Set up GHC ${{ matrix.ghc-version }}
uses: haskell-actions/setup@v2
id: setup
with:
ghc-version: ${{ matrix.ghc-version }}
# Taken from https://github.com/agda/agda/blob/8210048a50c35d8d6fd0ae7e5edd1699592fda6f/src/github/workflows/cabal.yml#L113C1-L124C85
# See: https://github.com/haskell/text-icu/pull/86
# pacman needs MSYS /usr/bin in PATH, but this breaks the latest cache action.
# - https://github.com/actions/cache/issues/1073
# MSYS' pkg-config needs MSYS /mingw64/bin which we can safely add to the PATH
#
- name: Install system dependencies (Windows)
if: ${{ startsWith(matrix.os, 'windows') }}
shell: pwsh
run: |
$env:PATH = "C:\msys64\usr\bin;$env:PATH"
pacman --noconfirm -S msys2-keyring mingw-w64-x86_64-pkgconf mingw-w64-x86_64-gtk3
echo "C:\msys64\mingw64\bin" | Out-File -FilePath "$env:GITHUB_PATH" -Append
- name: Enable static build (only on alpine)
if: ${{ startsWith(matrix.container, 'alpine') }}
run: |
echo 'executable-static: true' >>cabal.project
echo 'cc-options: -D_Noreturn=' >>cabal.project
- name: Configure the build
run: |
cabal configure --enable-tests --enable-benchmarks --disable-documentation
cabal build all --dry-run
- name: Restore cached dependencies
uses: actions/cache/restore@v4
id: cache
env:
key: ${{ runner.os }}${{ matrix.container && '-container-' }}${{matrix.container}}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}
with:
path: ${{ steps.setup.outputs.cabal-store }}
key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }}
restore-keys: ${{ env.key }}-
- name: Install dependencies
# If we had an exact cache hit, the dependencies will be up to date.
if: steps.cache.outputs.cache-hit != 'true'
run: cabal build all --only-dependencies
# Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail.
- name: Save cached dependencies
uses: actions/cache/save@v4
# If we had an exact cache hit, trying to save the cache would error because of key clash.
if: steps.cache.outputs.cache-hit != 'true'
with:
path: ${{ steps.setup.outputs.cabal-store }}
key: ${{ steps.cache.outputs.cache-primary-key }}
- name: Build
run: cabal build all
- name: Run tests
run: cabal test all
- name: Check cabal file
run: cabal check
- name: Create bindist
shell: sh
run: |
cabal install --install-method=copy --installdir=dist
BINDIST_NAME="threadscope-ghc-${{matrix.ghc-version}}-${{ matrix.os }}${{ matrix.container && '-' }}${{matrix.container && 'alpine'}}"
echo "BINDIST_NAME=$BINDIST_NAME" >> "$GITHUB_ENV"
tar -cJf "$BINDIST_NAME.tar.xz" -C dist threadscope
echo bindist is "$BINDIST_NAME.tar.xz"
- name: Upload bindist to artifacts
uses: actions/upload-artifact@v4
if: ${{ matrix.ghc-version == env.GHC_FOR_RELEASE }}
with:
name: ${{ env.BINDIST_NAME }}
path: ${{ env.BINDIST_NAME}}.tar.xz
- name: Release
uses: softprops/action-gh-release@v2
if: ${{ startsWith(github.ref, 'refs/tags/') && matrix.ghc-version == env.GHC_FOR_RELEASE }}
with:
files: ${{ env.BINDIST_NAME }}.tar.xz
================================================
FILE: .gitignore
================================================
dist-newstyle
cabal.project.local~*
================================================
FILE: CHANGELOG.md
================================================
# Revision history for threadscope
## 2025-05-29 - v0.2.15.0
* Switch to GTK3 ([#137](https://github.com/haskell/ThreadScope/pull/137)))
* Support new versions of GHC up to 9.12 and dependencies.
## 2022-05-10 - v0.2.14.1
* Spelling fixes ([#121](https://github.com/haskell/ThreadScope/pull/121), [#123](https://github.com/haskell/ThreadScope/pull/123))
* Add compatibility with GHC-9.2 ([#124](https://github.com/haskell/ThreadScope/pull/124), [＃125](https://github.com/haskell/ThreadScope/pull/125))
* Update dependencies ([#126](https://github.com/haskell/ThreadScope/pull/126))
## 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))
* Fix broken GitHub Releases deployment ([#106](https://github.com/haskell/ThreadScope/pull/106))
* Update ghc-events to 0.13.0 ([#107](https://github.com/haskell/ThreadScope/pull/107))
* Relax upper version bound for time
## 2020-03-04 - v0.2.12
* Remove unused events entry box ([#93](https://github.com/haskell/ThreadScope/pull/93))
* Make the app work even if it fails to load the logo ([#96](https://github.com/haskell/ThreadScope/pull/96))
* Support GHC 8.8 ([#99](https://github.com/haskell/ThreadScope/pull/99))
* Support ghc-events 0.12.0 ([#101](https://github.com/haskell/ThreadScope/pull/101))
* Stop using gtk-mac-integration and fix broken CI ([#103](https://github.com/haskell/ThreadScope/pull/103))
* This causes a visual regression. The logo won't be displayed in Dock.
## 2018-07-12 - v0.2.11.1
* Relax upper version bounds for containers and ghc-events (#88)
## 2018-06-08 - v0.2.11
* Relax upper version bounds for template-haskell and temporary
* Fix build failure with gtk-0.14.9
* Modernise AppVeyor CI script
## 2018-02-16 - v0.2.10
* Add instructions to install gtk2 in the README
* Do not include windows_cconv.h on non mingw32 systems (#79)
* Relax upper version bound for ghc-events (#80)
* Relax upper version bound for time
## 2017-09-02 - v0.2.9
* Render GC waiting periods in light orange (#70)
* Fix inappropriate calling convention on Windows x86 (#71)
* Enable GitHub Releases (#75)
## 2017-07-17 - v0.2.8
* Add macOS support (#56)
* Update ghc-events to 0.6.0 (#61)
* CI builds for Linux/Windows/macOS (#64, #65)
* Set upper version bounds for dependencies
================================================
FILE: Events/EventDuration.hs
================================================
-- This module supports a duration-based data-type to represent thread
-- execution and GC information.
module Events.EventDuration (
EventDuration(..),
isGCDuration,
startTimeOf, endTimeOf, durationOf,
eventsToDurations,
isDiscreteEvent
) where
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
-------------------------------------------------------------------------------
-- This data structure is a duration-based representation of the eventlog
-- information where thread-runs and GCs are explicitly represented by a
-- single constructor identifying their start and end points.
data EventDuration
= ThreadRun {-#UNPACK#-}!ThreadId
ThreadStopStatus
{-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCStart {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCWork {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCIdle {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
| GCEnd {-#UNPACK#-}!Timestamp
{-#UNPACK#-}!Timestamp
deriving Show
{-
GCStart GCWork GCIdle GCEnd
gc start -----> work -----> idle ------+> done -----> gc end
| |
`-------<-------<-----'
-}
isGCDuration :: EventDuration -> Bool
isGCDuration GCStart{} = True
isGCDuration GCWork{} = True
isGCDuration GCIdle{} = True
isGCDuration GCEnd{} = True
isGCDuration _ = False
-------------------------------------------------------------------------------
-- The start time of an event.
startTimeOf :: EventDuration -> Timestamp
startTimeOf ed
= case ed of
ThreadRun _ _ startTime _ -> startTime
GCStart startTime _ -> startTime
GCWork startTime _ -> startTime
GCIdle startTime _ -> startTime
GCEnd startTime _ -> startTime
-------------------------------------------------------------------------------
-- The emd time of an event.
endTimeOf :: EventDuration -> Timestamp
endTimeOf ed
= case ed of
ThreadRun _ _ _ endTime -> endTime
GCStart _ endTime -> endTime
GCWork _ endTime -> endTime
GCIdle _ endTime -> endTime
GCEnd _ endTime -> endTime
-------------------------------------------------------------------------------
-- The duration of an EventDuration
durationOf :: EventDuration -> Timestamp
durationOf ed = endTimeOf ed - startTimeOf ed
-------------------------------------------------------------------------------
eventsToDurations :: [GHC.Event] -> [EventDuration]
eventsToDurations [] = []
eventsToDurations (event : events) =
case evSpec event of
RunThread{thread=t}
| Just ev <- runDuration t -> ev : rest
| otherwise -> rest
StopThread{} -> rest
StartGC -> gcStart (evTime event) events
EndGC{} -> rest
_otherEvent -> rest
where
rest = eventsToDurations events
runDuration :: ThreadId -> Maybe EventDuration
runDuration t = do
(endTime, s) <- findRunThreadTime events
return $ ThreadRun t s (evTime event) endTime
isDiscreteEvent :: GHC.Event -> Bool
isDiscreteEvent e =
case evSpec e of
RunThread{} -> False
StopThread{} -> False
StartGC{} -> False
EndGC{} -> False
GHC.GCWork{} -> False
GHC.GCIdle{} -> False
GHC.GCDone{} -> False
GHC.SparkCounters{} -> False
_ -> True
gcStart :: Timestamp -> [GHC.Event] -> [EventDuration]
gcStart _ [] = []
gcStart t0 (event : events) =
case evSpec event of
GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events
GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events
GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events
GHC.EndGC{} -> GCStart t0 t1 : eventsToDurations events
RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = evTime event
gcWork :: Timestamp -> [GHC.Event] -> [EventDuration]
gcWork _ [] = []
gcWork t0 (event : events) =
case evSpec event of
GHC.GCWork{} -> gcWork t0 events
GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events
GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events
GHC.EndGC{} -> GCWork t0 t1 : eventsToDurations events
RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = evTime event
gcIdle :: Timestamp -> [GHC.Event] -> [EventDuration]
gcIdle _ [] = []
gcIdle t0 (event : events) =
case evSpec event of
GHC.GCIdle{} -> gcIdle t0 events
GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events
GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events
GHC.EndGC{} -> GCIdle t0 t1 : eventsToDurations events
RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = evTime event
gcDone :: Timestamp -> [GHC.Event] -> [EventDuration]
gcDone _ [] = []
gcDone t0 (event : events) =
case evSpec event of
GHC.GCDone{} -> gcDone t0 events
GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events
GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events
GHC.EndGC{} -> GCEnd t0 t1 : eventsToDurations events
RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events)
_other -> gcStart t0 events
where
t1 = evTime event
-------------------------------------------------------------------------------
findRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus)
findRunThreadTime [] = Nothing
findRunThreadTime (e : es)
= case evSpec e of
StopThread{status=s} -> Just (evTime e, s)
_ | [] <- 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
-------------------------------------------------------------------------------
================================================
FILE: Events/EventTree.hs
================================================
module Events.EventTree (
DurationTree(..),
mkDurationTree,
runTimeOf, gcTimeOf,
reportDurationTree,
durationTreeCountNodes,
durationTreeMaxDepth,
EventTree(..), EventNode(..),
mkEventTree,
reportEventTree, eventTreeMaxDepth,
) where
import Events.EventDuration
import GHC.RTS.Events hiding (Event)
import qualified GHC.RTS.Events as GHC
import Control.Exception (assert)
import Text.Printf
-------------------------------------------------------------------------------
-- We map the events onto a binary search tree, so that we can easily
-- find the events that correspond to a particular view of the
-- timeline. Additionally, each node of the tree contains a summary
-- of the information below it, so that we can render views at various
-- levels of resolution. For example, if a tree node would represent
-- less than one pixel on the display, there is no point is descending
-- the tree further.
-- We only split at event boundaries; we never split an event into
-- multiple pieces. Therefore, the binary tree is only roughly split
-- by time, the actual split depends on the distribution of events
-- below it.
data DurationTree
= DurationSplit
{-#UNPACK#-}!Timestamp -- The start time of this run-span
{-#UNPACK#-}!Timestamp -- The time used to split the events into two parts
{-#UNPACK#-}!Timestamp -- The end time of this run-span
DurationTree -- The LHS split; all events lie completely between
-- start and split
DurationTree -- The RHS split; all events lie completely between
-- split and end
{-#UNPACK#-}!Timestamp -- The total amount of time spent running a thread
{-#UNPACK#-}!Timestamp -- The total amount of time spend in GC
| DurationTreeLeaf
EventDuration
| DurationTreeEmpty
deriving Show
-------------------------------------------------------------------------------
mkDurationTree :: [EventDuration] -> Timestamp -> DurationTree
mkDurationTree es endTime =
-- trace (show tree) $
tree
where
tree = splitDurations es endTime
splitDurations :: [EventDuration] -- events
-> Timestamp -- end time of last event in the list
-> DurationTree
splitDurations [] _endTime =
-- if len /= 0 then error "splitDurations0" else
DurationTreeEmpty -- The case for an empty list of events.
splitDurations [e] _entTime =
DurationTreeLeaf e
splitDurations es endTime
| null rhs
= splitDurations es lhs_end
| null lhs
= error $
printf "splitDurations: null lhs: len = %d, startTime = %d, endTime = %d\n"
(length es) startTime endTime
++ '\n': show es
| otherwise
= -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $
assert (length lhs + length rhs == length es) $
DurationSplit startTime
lhs_end
endTime
ltree
rtree
runTime
gcTime
where
startTime = startTimeOf (head es)
splitTime = startTime + (endTime - startTime) `div` 2
(lhs, lhs_end, rhs) = splitDurationList es [] splitTime 0
ltree = splitDurations lhs lhs_end
rtree = splitDurations rhs endTime
runTime = runTimeOf ltree + runTimeOf rtree
gcTime = gcTimeOf ltree + gcTimeOf rtree
splitDurationList :: [EventDuration]
-> [EventDuration]
-> Timestamp
-> Timestamp
-> ([EventDuration], Timestamp, [EventDuration])
splitDurationList [] acc !_tsplit !tmax
= (reverse acc, tmax, [])
splitDurationList [e] acc !_tsplit !tmax
-- Just one event left: put it on the right. This ensures that we
-- have at least one event on each side of the split.
= (reverse acc, tmax, [e])
splitDurationList (e:es) acc !tsplit !tmax
| tstart <= tsplit -- pick all events that start at or before the split
= splitDurationList es (e:acc) tsplit (max tmax tend)
| otherwise
= (reverse acc, tmax, e:es)
where
tstart = startTimeOf e
tend = endTimeOf e
-------------------------------------------------------------------------------
runTimeOf :: DurationTree -> Timestamp
runTimeOf (DurationSplit _ _ _ _ _ runTime _) = runTime
runTimeOf (DurationTreeLeaf e) | ThreadRun{} <- e = durationOf e
runTimeOf _ = 0
-------------------------------------------------------------------------------
gcTimeOf :: DurationTree -> Timestamp
gcTimeOf (DurationSplit _ _ _ _ _ _ gcTime) = gcTime
gcTimeOf (DurationTreeLeaf e) | isGCDuration e = durationOf e
gcTimeOf _ = 0
-------------------------------------------------------------------------------
reportDurationTree :: Int -> DurationTree -> IO ()
reportDurationTree hecNumber eventTree
= putStrLn ("HEC " ++ show hecNumber ++ reportText)
where
reportText = " nodes = " ++ show (durationTreeCountNodes eventTree) ++
" max depth = " ++ show (durationTreeMaxDepth eventTree)
-------------------------------------------------------------------------------
durationTreeCountNodes :: DurationTree -> Int
durationTreeCountNodes (DurationSplit _ _ _ lhs rhs _ _)
= 1 + durationTreeCountNodes lhs + durationTreeCountNodes rhs
durationTreeCountNodes _ = 1
-------------------------------------------------------------------------------
durationTreeMaxDepth :: DurationTree -> Int
durationTreeMaxDepth (DurationSplit _ _ _ lhs rhs _ _)
= 1 + durationTreeMaxDepth lhs `max` durationTreeMaxDepth rhs
durationTreeMaxDepth _ = 1
-------------------------------------------------------------------------------
data EventTree
= EventTree
{-#UNPACK#-}!Timestamp -- The start time of this run-span
{-#UNPACK#-}!Timestamp -- The end time of this run-span
EventNode
data EventNode
= EventSplit
{-#UNPACK#-}!Timestamp -- The time used to split the events into two parts
EventNode -- The LHS split; all events lie completely between
-- start and split
EventNode -- The RHS split; all events lie completely between
-- split and end
| EventTreeLeaf [GHC.Event]
-- sometimes events happen "simultaneously" (at the same time
-- given the resolution of our clock source), so we can't
-- separate them.
| EventTreeOne GHC.Event
-- This is a space optimisation for the common case of
-- EventTreeLeaf [e].
mkEventTree :: [GHC.Event] -> Timestamp -> EventTree
mkEventTree es endTime =
EventTree s e $
-- trace (show tree) $
tree
where
tree = splitEvents es endTime
(s,e) = if null es then (0,0) else (evTime (head es), endTime)
splitEvents :: [GHC.Event] -- events
-> Timestamp -- end time of last event in the list
-> EventNode
splitEvents [] !_endTime =
-- if len /= 0 then error "splitEvents0" else
EventTreeLeaf [] -- The case for an empty list of events
splitEvents [e] !_endTime =
EventTreeOne e
splitEvents es !endTime
| duration == 0
= EventTreeLeaf es
| null rhs
= splitEvents es lhs_end
| null lhs
= error $
printf "splitEvents: null lhs: len = %d, startTime = %d, endTime = %d\n"
(length es) startTime endTime
++ '\n': show es
| otherwise
= -- trace (printf "len = %d, startTime = %d, endTime = %d, lhs_len = %d\n" len startTime endTime lhs_len) $
assert (length lhs + length rhs == length es) $
EventSplit (evTime (head rhs))
ltree
rtree
where
-- | Integer division, rounding up.
divUp :: Timestamp -> Timestamp -> Timestamp
divUp n k = (n + k - 1) `div` k
startTime = evTime (head es)
splitTime = startTime + (endTime - startTime) `divUp` 2
duration = endTime - startTime
(lhs, lhs_end, rhs) = splitEventList es [] splitTime 0
ltree = splitEvents lhs lhs_end
rtree = splitEvents rhs endTime
splitEventList :: [GHC.Event]
-> [GHC.Event]
-> Timestamp
-> Timestamp
-> ([GHC.Event], Timestamp, [GHC.Event])
splitEventList [] acc !_tsplit !tmax
= (reverse acc, tmax, [])
splitEventList [e] acc !_tsplit !tmax
-- Just one event left: put it on the right. This ensures that we
-- have at least one event on each side of the split.
= (reverse acc, tmax, [e])
splitEventList (e:es) acc !tsplit !tmax
| t <= tsplit -- pick all events that start at or before the split
= splitEventList es (e:acc) tsplit (max tmax t)
| otherwise
= (reverse acc, tmax, e:es)
where
t = evTime e
-------------------------------------------------------------------------------
reportEventTree :: Int -> EventTree -> IO ()
reportEventTree hecNumber (EventTree _ _ eventTree)
= putStrLn ("HEC " ++ show hecNumber ++ reportText)
where
reportText = " nodes = " ++ show (eventTreeCountNodes eventTree) ++
" max depth = " ++ show (eventNodeMaxDepth eventTree)
-------------------------------------------------------------------------------
eventTreeCountNodes :: EventNode -> Int
eventTreeCountNodes (EventSplit _ lhs rhs)
= 1 + eventTreeCountNodes lhs + eventTreeCountNodes rhs
eventTreeCountNodes _ = 1
-------------------------------------------------------------------------------
eventTreeMaxDepth :: EventTree -> Int
eventTreeMaxDepth (EventTree _ _ t) = eventNodeMaxDepth t
eventNodeMaxDepth :: EventNode -> Int
eventNodeMaxDepth (EventSplit _ lhs rhs)
= 1 + eventNodeMaxDepth lhs `max` eventNodeMaxDepth rhs
eventNodeMaxDepth _ = 1
================================================
FILE: Events/HECs.hs
================================================
{-# LANGUAGE CPP #-}
module Events.HECs (
HECs(..),
Event,
Timestamp,
eventIndexToTimestamp,
timestampToEventIndex,
extractUserMarkers,
histogram,
histogramCounts,
) where
import Events.EventTree
import Events.SparkTree
import GHC.RTS.Events
import Data.Array
import Data.Text (Text)
import qualified Data.List as L
#if MIN_VERSION_containers(0,5,0)
import qualified Data.IntMap.Strict as IM
#else
import qualified Data.IntMap as IM
#endif
-----------------------------------------------------------------------------
-- all the data from a .eventlog file
data HECs = HECs {
hecCount :: Int,
hecTrees :: [(DurationTree, EventTree, SparkTree)],
hecEventArray :: Array Int Event,
hecLastEventTime :: Timestamp,
maxSparkPool :: Double,
minXHistogram :: Int,
maxXHistogram :: Int,
maxYHistogram :: Timestamp,
durHistogram :: [(Timestamp, Int, Timestamp)],
perfNames :: IM.IntMap Text
}
-----------------------------------------------------------------------------
eventIndexToTimestamp :: HECs -> Int -> Timestamp
eventIndexToTimestamp HECs{hecEventArray=arr} n =
evTime (arr ! n)
timestampToEventIndex :: HECs -> Timestamp -> Int
timestampToEventIndex HECs{hecEventArray=arr} ts =
search l (r+1)
where
(l,r) = bounds arr
search !l !r
| (r - l) <= 1 = if ts > evTime (arr!l) then r else l
| ts < tmid = search l mid
| otherwise = search mid r
where
mid = l + (r - l) `quot` 2
tmid = evTime (arr!mid)
extractUserMarkers :: HECs -> [(Timestamp, Text)]
extractUserMarkers hecs =
[ (ts, mark)
| (Event ts (UserMarker mark) _) <- elems (hecEventArray hecs) ]
-- | Sum durations in the same buckets to form a histogram.
histogram :: [(Int, Timestamp)] -> [(Int, Timestamp)]
histogram durs = IM.toList $ fromListWith' (+) durs
-- | Sum durations and spark counts in the same buckets to form a histogram.
histogramCounts :: [(Int, (Timestamp, Int))] -> [(Int, (Timestamp, Int))]
histogramCounts durs =
let agg (dur1, count1) (dur2, count2) =
-- bangs needed to avoid stack overflow
let !dur = dur1 + dur2
!count = count1 + count2
in (dur, count)
in IM.toList $ fromListWith' agg durs
fromListWith' :: (a -> a -> a) -> [(Int, a)] -> IM.IntMap a
fromListWith' f xs =
L.foldl' ins IM.empty xs
where
#if MIN_VERSION_containers(0,5,0)
ins t (k,x) = IM.insertWith f k x t
#elif MIN_VERSION_containers(0,4,1)
ins t (k,x) = IM.insertWith' f k x t
#else
ins t (k,x) =
let r = IM.insertWith f k x t
v = r IM.! k
in v `seq` r
#endif
================================================
FILE: Events/ReadEvents.hs
================================================
module Events.ReadEvents (
registerEventsFromFile, registerEventsFromTrace
) where
import Events.EventDuration
import Events.EventTree
import Events.HECs (HECs (..), histogram)
import Events.SparkTree
import Events.TestEvents
import GUI.ProgressView (ProgressView)
import qualified GUI.ProgressView as ProgressView
import GHC.RTS.Events
import GHC.RTS.Events.Analysis
import GHC.RTS.Events.Analysis.Capability
import GHC.RTS.Events.Analysis.SparkThread
import qualified Control.DeepSeq as DeepSeq
import Control.Exception
import Control.Monad
import Data.Array
import Data.Either
import Data.Function
import qualified Data.IntMap as IM
import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Set (Set)
import System.FilePath
import Text.Printf
-------------------------------------------------------------------------------
-- import qualified GHC.RTS.Events as GHCEvents
--
-- The GHC.RTS.Events library returns the profile information
-- in a data-structure which contains a list data structure
-- representing the events i.e. [GHCEvents.Event]
-- ThreadScope transforms this list into an alternative representation
-- which (for each HEC) records event *durations* which are ordered in time.
-- The durations represent the run-lengths for thread execution and
-- run-lengths for garbage collection. This data-structure is called
-- EventDuration.
-- ThreadScope then transformations this data-structure into another
-- data-structure which gives a binary-tree view of the event information
-- by performing a binary split on the time domain i.e. the EventTree
-- data structure.
-- GHCEvents.Event => [EventDuration] => EventTree
-------------------------------------------------------------------------------
rawEventsToHECs :: [Event] -> Timestamp
-> [(Double, (DurationTree, EventTree, SparkTree))]
rawEventsToHECs evs endTime
= map (\cap -> toTree $ L.find ((Just cap ==) . evCap . head) heclists)
[0 .. maximum (0 : map (fromMaybe 0 . evCap) evs)]
where
heclists =
L.groupBy ((==) `on` evCap) $ L.sortBy (compare `on` evCap) evs
toTree Nothing = (0, (DurationTreeEmpty,
EventTree 0 0 (EventTreeLeaf []),
emptySparkTree))
toTree (Just evs) =
(maxSparkPool,
(mkDurationTree (eventsToDurations nondiscrete) endTime,
mkEventTree discrete endTime,
mkSparkTree sparkD endTime))
where (discrete, nondiscrete) = L.partition isDiscreteEvent evs
(maxSparkPool, sparkD) = eventsToSparkDurations nondiscrete
-------------------------------------------------------------------------------
registerEventsFromFile :: String -> ProgressView
-> IO (HECs, String, Int, Double)
registerEventsFromFile filename = registerEvents (Left filename)
registerEventsFromTrace :: String -> ProgressView
-> IO (HECs, String, Int, Double)
registerEventsFromTrace traceName = registerEvents (Right traceName)
registerEvents :: Either FilePath String
-> ProgressView
-> IO (HECs, String, Int, Double)
registerEvents from progress = do
let msg = case from of
Left filename -> filename
Right test -> test
ProgressView.setTitle progress ("Loading " ++ takeFileName msg)
buildEventLog progress from
-------------------------------------------------------------------------------
-- Runs in a background thread
--
buildEventLog :: ProgressView -> Either FilePath String
-> IO (HECs, String, Int, Double)
buildEventLog progress from =
case from of
Right test -> build test (testTrace test)
Left filename -> do
stopPulse <- ProgressView.startPulse progress
fmt <- readEventLogFromFile filename
stopPulse
case fmt of
Left err -> fail err --FIXME: report error properly
Right evs -> build filename evs
where
-- | Integer division, rounding up.
divUp :: Timestamp -> Timestamp -> Timestamp
divUp n k = (n + k - 1) `div` k
build name evs = do
let
eBy1000 ev = ev{evTime = evTime ev `divUp` 1000}
eventsBy = map eBy1000 (events (dat evs))
eventBlockEnd e | EventBlock{ end_time=t } <- evSpec e = t
eventBlockEnd e = evTime e
-- 1, to avoid graph scale 0 and division by 0 later on
lastTx = maximum (1 : map eventBlockEnd eventsBy)
-- Add caps to perf events, using the OS thread numbers
-- obtained from task validation data.
-- Only the perf events with a cap are displayed in the timeline.
-- TODO: it may make sense to move this code to ghc-events
-- and run after to-eventlog and ghc-events merge, but it requires
-- one more step in the 'perf to TS' workflow and is a bit slower
-- (yet another event sorting and loading eventlog chunks
-- into the CPU cache).
steps :: [Event] -> [(Map KernelThreadId Int, Event)]
steps evs =
zip (map fst $ rights $ validates capabilityTaskOSMachine evs) evs
addC :: (Map KernelThreadId Int, Event) -> Event
addC (state, ev@Event{evSpec=PerfTracepoint{tid}}) =
case M.lookup tid state of
Nothing -> ev -- unknown task's OS thread
evCap -> ev {evCap}
addC (state, ev@Event{evSpec=PerfCounter{tid}}) =
case M.lookup tid state of
Nothing -> ev -- unknown task's OS thread
evCap -> ev {evCap}
addC (_, ev) = ev
addCaps evs = map addC (steps evs)
-- sort the events by time, add extra caps and put them in an array
sorted = addCaps $ sortEvents eventsBy
maxTrees = rawEventsToHECs sorted lastTx
maxSparkPool = maximum (0 : map fst maxTrees)
trees = map snd maxTrees
-- put events in an array
n_events = length sorted
event_arr = listArray (0, n_events-1) sorted
hec_count = length trees
-- Pre-calculate the data for the sparks histogram.
intDoub :: Integral a => a -> Double
intDoub = fromIntegral
-- Discretizes the data using log.
-- Log base 2 seems to result in 7--15 bars, which is OK visually.
-- Better would be 10--15 bars, but we want the base to be a small
-- integer, for readable scales, and we can't go below 2.
ilog :: Timestamp -> Int
ilog 0 = 0
ilog x = floor $ logBase 2 (intDoub x)
times :: (Int, Timestamp, Timestamp)
-> Maybe (Timestamp, Int, Timestamp)
times (_, timeStarted, timeElapsed) =
Just (timeStarted, ilog timeElapsed, timeElapsed)
sparkProfile :: Process
((Map ThreadId (Profile SparkThreadState),
(Map Int ThreadId, Set ThreadId)),
Event)
(ThreadId, (SparkThreadState, Timestamp, Timestamp))
sparkProfile = profileRouted
(refineM evSpec sparkThreadMachine)
capabilitySparkThreadMachine
capabilitySparkThreadIndexer
evTime
sorted
sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp)
-> [(ThreadId, (SparkThreadState, Timestamp, Timestamp))]
-> [Maybe (Timestamp, Int, Timestamp)]
sparkSummary m [] = map times $ M.elems m
sparkSummary m ((threadId, (state, timeStarted', timeElapsed')):xs) =
case state of
SparkThreadRunning sparkId' -> case M.lookup threadId m of
Just el@(sparkId, timeStarted, timeElapsed) ->
if sparkId == sparkId'
then let value = (sparkId, timeStarted, timeElapsed + timeElapsed')
in sparkSummary (M.insert threadId value m) xs
else times el : newSummary sparkId' xs
Nothing -> newSummary sparkId' xs
_ -> sparkSummary m xs
where
newSummary sparkId = let value = (sparkId, timeStarted', timeElapsed')
in sparkSummary (M.insert threadId value m)
allHisto :: [(Timestamp, Int, Timestamp)]
allHisto = catMaybes . sparkSummary M.empty . toList $ sparkProfile
-- Sparks of zero length are already well visualized in other graphs:
durHistogram = filter (\ (_, logdur, _) -> logdur > 0) allHisto
-- Precompute some extremums of the maximal interval, needed for scales.
durs = [(logdur, dur) | (_start, logdur, dur) <- durHistogram]
(logDurs, sumDurs) = L.unzip (histogram durs)
minXHistogram = minimum (maxBound : logDurs)
maxXHistogram = maximum (minBound : logDurs)
maxY = maximum (minBound : sumDurs)
-- round up to multiples of 10ms
maxYHistogram = 10000 * ceiling (fromIntegral maxY / 10000)
getPerfNames nmap ev =
case evSpec ev of
PerfName{perfNum, name} ->
IM.insert (fromIntegral perfNum) name nmap
_ -> nmap
perfNames = L.foldl' getPerfNames IM.empty eventsBy
hecs = HECs {
hecCount = hec_count,
hecTrees = trees,
hecEventArray = event_arr,
hecLastEventTime = lastTx,
maxSparkPool,
minXHistogram,
maxXHistogram,
maxYHistogram,
durHistogram,
perfNames
}
treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO ()
treeProgress hec (tree1, tree2, tree3) = do
ProgressView.setText progress $
printf "Building HEC %d/%d" (hec+1) hec_count
ProgressView.setProgress progress hec_count hec
evaluate tree1
evaluate (eventTreeMaxDepth tree2)
evaluate (sparkTreeMaxDepth tree3)
when (hec_count == 1 || hec == 1) -- eval only with 2nd HEC
(return $! DeepSeq.rnf durHistogram)
zipWithM_ treeProgress [0..] trees
ProgressView.setProgress progress hec_count hec_count
-- TODO: fully evaluate HECs before returning because otherwise the last
-- bit of work gets done after the progress window has been closed.
return (hecs, name, n_events, fromIntegral lastTx / 1000000)
================================================
FILE: Events/SparkStats.hs
================================================
module Events.SparkStats
( SparkStats(..)
, initial, create, rescale, aggregate, agEx
) where
import Data.Word (Word64)
-- | Sparks change state. Each state transition process has a duration.
-- Spark statistics, for a given duration, record the spark transition rate
-- (the number of sparks that enter a given state within the interval)
-- and the absolute mean, maximal and minimal number of sparks
-- in the spark pool within the duration.
data SparkStats =
SparkStats { rateCreated, rateDud, rateOverflowed,
rateConverted, rateFizzled, rateGCd,
meanPool, maxPool, minPool :: {-# UNPACK #-}!Double }
deriving (Show, Eq)
-- | Initial, default value of spark stats, at the start of runtime,
-- before any spark activity is recorded.
initial :: SparkStats
initial = SparkStats 0 0 0 0 0 0 0 0 0
-- | Create spark stats for a duration, given absolute
-- numbers of sparks in all categories at the start and end of the duration.
-- The units for spark transitions (first 6 counters) is [spark/duration]:
-- the fact that intervals may have different lengths is ignored here.
-- The units for the pool stats are just [spark].
-- The values in the second counter have to be greater or equal
-- to the values in the first counter, except for the spark pool size.
-- For pool size, we take into account only the first sample,
-- to visualize more detail at high zoom levels, at the cost
-- of a slight shift of the graph. Mathematically, this corresponds
-- to taking the initial durations as centered around samples,
-- but to have the same tree for rates and pool sizes, we then have
-- to shift the durations by half interval size to the right
-- (which would be neglectable if the interval was small and even).
create :: (Word64, Word64, Word64, Word64, Word64, Word64, Word64)
-> (Word64, Word64, Word64, Word64, Word64, Word64, Word64)
-> SparkStats
create (crt1, dud1, ovf1, cnv1, fiz1, gcd1, remaining1)
(crt2, dud2, ovf2, cnv2, fiz2, gcd2, _remaining2) =
let (crt, dud, ovf, cnv, fiz, gcd) =
(fromIntegral $ crt2 - crt1,
fromIntegral $ dud2 - dud1,
fromIntegral $ ovf2 - ovf1,
fromIntegral $ cnv2 - cnv1,
fromIntegral $ fiz2 - fiz1,
fromIntegral $ gcd2 - gcd1)
p = fromIntegral remaining1
in SparkStats crt dud ovf cnv fiz gcd p p p
-- | Reduce a list of spark stats; spark pool stats are overwritten.
foldStats :: (Double -> Double -> Double)
-> Double -> Double -> Double
-> [SparkStats] -> SparkStats
foldStats f meanP maxP minP l
= SparkStats
(foldr f 0 (map rateCreated l))
(foldr f 0 (map rateDud l))
(foldr f 0 (map rateOverflowed l))
(foldr f 0 (map rateConverted l))
(foldr f 0 (map rateFizzled l))
(foldr f 0 (map rateGCd l))
meanP maxP minP
-- | Rescale the spark transition stats, e.g., to change their units.
rescale :: Double -> SparkStats -> SparkStats
rescale scale s =
let f w _ = scale * w
in foldStats f (meanPool s) (maxPool s) (minPool s) [s]
-- | Derive spark stats for an interval from a list of spark stats,
-- in reverse chronological order, of consecutive subintervals
-- that sum up to the original interval.
aggregate :: [SparkStats] -> SparkStats
aggregate [] = error "aggregate"
aggregate [s] = s -- optimization
aggregate l =
let meanP = sum (map meanPool l) / fromIntegral (length l) -- TODO: inaccurate
maxP = maximum (map maxPool l)
minP = minimum (map minPool l)
in foldStats (+) meanP maxP minP l
-- | Extrapolate spark stats from previous data.
-- Absolute pools size values extrapolate by staying constant,
-- rates of change of spark status extrapolate by dropping to 0
-- (which corresponds to absolute numbers of sparks staying constant).
extrapolate :: SparkStats -> SparkStats
extrapolate s =
let f w _ = 0 * w
in foldStats f (meanPool s) (maxPool s) (minPool s) [s]
-- | Aggregate, if any data provided. Extrapolate from previous data, otherwise.
-- In both cases, the second component is the new choice of "previous data".
-- The list of stats is expected in reverse chronological order,
-- as for aggregate.
agEx :: [SparkStats] -> SparkStats -> (SparkStats, SparkStats)
agEx [] s = (extrapolate s, s)
agEx l@(s:_) _ = (aggregate l, s)
================================================
FILE: Events/SparkTree.hs
================================================
module Events.SparkTree (
SparkTree,
sparkTreeMaxDepth,
emptySparkTree,
eventsToSparkDurations,
mkSparkTree,
sparkProfile,
) where
import qualified Events.SparkStats as SparkStats
import GHC.RTS.Events (Timestamp)
import qualified GHC.RTS.Events as GHCEvents
import Control.Exception (assert)
import Text.Printf
-- import Debug.Trace
-- | Sparks change state. Each state transition process has a duration.
-- SparkDuration is a condensed description of such a process,
-- containing a start time of the duration interval,
-- spark stats that record the spark transition rate
-- and the absolute number of sparks in the spark pool within the duration.
data SparkDuration =
SparkDuration { startT :: {-#UNPACK#-}!Timestamp,
deltaC :: {-#UNPACK#-}!SparkStats.SparkStats }
deriving Show
-- | Calculates durations and maximal rendered values from the event log.
-- Warning: cannot be applied to a suffix of the log (assumes start at time 0).
eventsToSparkDurations :: [GHCEvents.Event] -> (Double, [SparkDuration])
eventsToSparkDurations es =
let aux _startTime _startCounters [] = (0, [])
aux startTime startCounters (event : events) =
case GHCEvents.evSpec event of
GHCEvents.SparkCounters crt dud ovf cnv fiz gcd rem ->
let endTime = GHCEvents.evTime event
endCounters = (crt, dud, ovf, cnv, fiz, gcd, rem)
delta = SparkStats.create startCounters endCounters
newMaxSparkPool = SparkStats.maxPool delta
sd = SparkDuration { startT = startTime,
deltaC = delta }
(oldMaxSparkPool, l) = aux endTime endCounters events
in (max oldMaxSparkPool newMaxSparkPool, sd : l)
_otherEvent -> aux startTime startCounters events
in aux 0 (0,0,0,0,0,0,0) es
-- | We map the spark transition durations (intervals) onto a binary
-- search tree, so that we can easily find the durations
-- that correspond to a particular view of the timeline.
-- Additionally, each node of the tree contains a summary
-- of the information below it, so that we can render views at various
-- levels of resolution. For example, if a tree node would represent
-- less than one pixel on the display, there is no point is descending
-- the tree further.
data SparkTree
= SparkTree
{-#UNPACK#-}!Timestamp -- ^ start time of span represented by the tree
{-#UNPACK#-}!Timestamp -- ^ end time of the span represented by the tree
SparkNode
deriving Show
data SparkNode
= SparkSplit
{-#UNPACK#-}!Timestamp -- ^ time used to split the span into two parts
SparkNode
-- ^ the LHS split; all data lies completely between start and split
SparkNode
-- ^ the RHS split; all data lies completely between split and end
{-#UNPACK#-}!SparkStats.SparkStats
-- ^ aggregate of the spark stats within the span
| SparkTreeLeaf
{-#UNPACK#-}!SparkStats.SparkStats
-- ^ the spark stats for the base duration
| SparkTreeEmpty
-- ^ represents a span that no data referts to, e.g., after the last GC
deriving Show
sparkTreeMaxDepth :: SparkTree -> Int
sparkTreeMaxDepth (SparkTree _ _ t) = sparkNodeMaxDepth t
sparkNodeMaxDepth :: SparkNode -> Int
sparkNodeMaxDepth (SparkSplit _ lhs rhs _)
= 1 + sparkNodeMaxDepth lhs `max` sparkNodeMaxDepth rhs
sparkNodeMaxDepth _ = 1
emptySparkTree :: SparkTree
emptySparkTree = SparkTree 0 0 SparkTreeEmpty
-- | Create spark tree from spark durations.
-- Note that the last event may be not a spark event, in which case
-- there is no data about sparks for the last time interval
-- (the subtree for the interval will have SparkTreeEmpty node).
mkSparkTree :: [SparkDuration] -- ^ spark durations calculated from events
-> Timestamp -- ^ end time of last event in the list
-> SparkTree
mkSparkTree es endTime =
SparkTree s e $
-- trace (show tree) $
tree
where
tree = splitSparks es endTime
(s, e) = if null es then (0, 0) else (startT (head es), endTime)
-- | Construct spark tree, by recursively splitting time intervals..
-- We only split at spark transition duration boundaries;
-- we never split a duration into multiple pieces.
-- Therefore, the binary tree is only roughly split by time,
-- the actual split depends on the distribution of sample points below it.
splitSparks :: [SparkDuration] -> Timestamp -> SparkNode
splitSparks [] !_endTime =
SparkTreeEmpty
splitSparks [e] !_endTime =
SparkTreeLeaf (deltaC e)
splitSparks es !endTime
| null rhs
= splitSparks es lhs_end
| null lhs
= error $
printf "splitSparks: null lhs: len = %d, startTime = %d, endTime = %d\n"
(length es) startTime endTime
++ '\n' : show es
| otherwise
= -- trace (printf "len = %d, startTime = %d, endTime = %d\n" (length es) startTime endTime) $
assert (length lhs + length rhs == length es) $
SparkSplit (startT $ head rhs)
ltree
rtree
(SparkStats.aggregate (subDelta rtree ++ subDelta ltree))
where
-- | Integer division, rounding up.
divUp :: Timestamp -> Timestamp -> Timestamp
divUp n k = (n + k - 1) `div` k
startTime = startT $ head es
splitTime = startTime + (endTime - startTime) `divUp` 2
(lhs, lhs_end, rhs) = splitSparkList es [] splitTime 0
ltree = splitSparks lhs lhs_end
rtree = splitSparks rhs endTime
subDelta (SparkSplit _ _ _ delta) = [delta]
subDelta (SparkTreeLeaf delta) = [delta]
subDelta SparkTreeEmpty = []
splitSparkList :: [SparkDuration]
-> [SparkDuration]
-> Timestamp
-> Timestamp
-> ([SparkDuration], Timestamp, [SparkDuration])
splitSparkList [] acc !_tsplit !tmax
= (reverse acc, tmax, [])
splitSparkList [e] acc !_tsplit !tmax
-- Just one event left: put it on the right. This ensures that we
-- have at least one event on each side of the split.
= (reverse acc, tmax, [e])
splitSparkList (e:es) acc !tsplit !tmax
| startT e <= tsplit -- pick all durations that start at or before the split
= splitSparkList es (e:acc) tsplit (max tmax (startT e))
| otherwise
= (reverse acc, tmax, e:es)
-- | For each timeslice, give the spark stats calculated for that interval.
-- The spark stats are Approximated from the aggregated data
-- at the level of the spark tree covering intervals of the size
-- similar to the timeslice size.
sparkProfile :: Timestamp -> Timestamp -> Timestamp -> SparkTree
-> [SparkStats.SparkStats]
sparkProfile slice start0 end0 t
= {- trace (show flat) $ -} chopped
where
-- do an extra slice at both ends
start = if start0 < slice then start0 else start0 - slice
end = end0 + slice
flat = flatten start t []
-- TODO: redefine chop so that it's obvious this error will not happen
-- e.g., catch pathological cases, like a tree with only SparkTreeEmpty
-- inside and/or make it tail-recursive instead of
-- taking the 'previous' argument
chopped0 = chop (error "Fatal error in sparkProfile.") [] start flat
chopped | start0 < slice = SparkStats.initial : chopped0
| otherwise = chopped0
flatten :: Timestamp -> SparkTree -> [SparkTree] -> [SparkTree]
flatten _start (SparkTree _s _e SparkTreeEmpty) rest = rest
flatten start t@(SparkTree s e (SparkSplit split l r _)) rest
| e <= start = rest
| end <= s = rest
| start >= split = flatten start (SparkTree split e r) rest
| end <= split = flatten start (SparkTree s split l) rest
| e - s > slice = flatten start (SparkTree s split l) $
flatten start (SparkTree split e r) rest
-- A rule of thumb: if a node is narrower than slice, don't drill down,
-- even if the node sits astride slice boundaries and so the readings
-- for each of the two neigbouring slices will not be accurate
-- (but for the pair as a whole, they will be). Smooths the curve down
-- even more than averaging over the timeslice already does.
| otherwise = t : rest
flatten _start t@(SparkTree _s _e (SparkTreeLeaf _)) rest
= t : rest
chop :: SparkStats.SparkStats -> [SparkStats.SparkStats]
-> Timestamp -> [SparkTree] -> [SparkStats.SparkStats]
chop _previous sofar start1 _ts
| start1 >= end
= case sofar of
_ : _ -> [SparkStats.aggregate sofar]
[] -> []
chop _previous sofar _start1 [] -- data too short for the redrawn area
| null sofar -- no data at all in the redrawn area
= []
| otherwise
= [SparkStats.aggregate sofar]
chop previous sofar start1 (t : ts)
| e <= start1 -- skipping data left of the slice
= case sofar of
_ : _ -> error "chop"
[] -> chop previous sofar start1 ts
| s >= start1 + slice -- postponing data right of the slice
= let (c, p) = SparkStats.agEx sofar previous
in c : chop p [] (start1 + slice) (t : ts)
| e > start1 + slice
= let (c, p) = SparkStats.agEx (created_in_this_slice t ++ sofar) previous
in c : chop p [] (start1 + slice) (t : ts)
| otherwise
= chop previous (created_in_this_slice t ++ sofar) start1 ts
where
(s, e) | SparkTree s e _ <- t = (s, e)
-- The common part of the slice and the duration.
mi = min (start1 + slice) e
ma = max start1 s
common = if mi < ma then 0 else mi - ma
-- Instead of drilling down the tree (unless it's a leaf),
-- we approximate by taking a proportion of the aggregate value,
-- depending on how much of the spark duration corresponding
-- to the tree node is covered by our timeslice.
proportion = if e > s
then fromIntegral common / fromIntegral (e - s)
else assert (e == s && common == 0) $ 0
-- Spark transitions in the tree are in units spark/duration.
-- Here the numbers are rescaled so that the units are spark/ms.
created_in_this_slice (SparkTree _ _ node) = case node of
SparkTreeLeaf delta -> [SparkStats.rescale proportion delta]
SparkTreeEmpty -> []
SparkSplit _ _ _ delta -> [SparkStats.rescale proportion delta]
================================================
FILE: Events/TestEvents.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module Events.TestEvents (testTrace)
where
import Data.Word
import GHC.RTS.Events
-------------------------------------------------------------------------------
testTrace :: String -> EventLog
testTrace name = eventLog (test name)
-------------------------------------------------------------------------------
eventLog :: [Event] -> EventLog
eventLog events =
let eBy1000 ev = ev{evTime = evTime ev * 1000}
eventsBy = map eBy1000 events
in EventLog (Header testEventTypes) (Data eventsBy)
-------------------------------------------------------------------------------
create :: Word16
create = 0
-------------------------------------------------------------------------------
runThread :: Word16
runThread = 1
-------------------------------------------------------------------------------
stop :: Word16
stop = 2
-------------------------------------------------------------------------------
runnable :: Word16
runnable = 3
-------------------------------------------------------------------------------
migrate :: Word16
migrate = 4
-------------------------------------------------------------------------------
runSpark :: Word16
runSpark = 5
-------------------------------------------------------------------------------
stealSpark :: Word16
stealSpark = 6
-------------------------------------------------------------------------------
shutdown :: Word16
shutdown = 7
-------------------------------------------------------------------------------
wakeup :: Word16
wakeup = 8
-------------------------------------------------------------------------------
startGC :: Word16
startGC = 9
------------------------------------------------------------------------------
finishGC :: Word16
finishGC = 10
------------------------------------------------------------------------------
reqSeqGC :: Word16
reqSeqGC = 11
------------------------------------------------------------------------------
reqParGC :: Word16
reqParGC = 12
------------------------------------------------------------------------------
createSparkThread :: Word16
createSparkThread = 15
------------------------------------------------------------------------------
logMessage :: Word16
logMessage = 16
------------------------------------------------------------------------------
startup :: Word16
startup = 17
------------------------------------------------------------------------------
blockMarker :: Word16
blockMarker = 18
------------------------------------------------------------------------------
testEventTypes :: [EventType]
testEventTypes
= [EventType create "Create thread" (Just 8),
EventType runThread "Run thread" (Just 8),
EventType stop "Stop thread" (Just 10),
EventType runnable "Thread runnable" (Just 8),
EventType migrate "Migrate thread" (Just 10),
EventType runSpark "Run spark" (Just 8),
EventType stealSpark "Steal spark" (Just 10),
EventType shutdown "Shutdown" (Just 0),
EventType wakeup "Wakeup thread" (Just 10),
EventType startGC "Start GC" (Just 0),
EventType finishGC "Finish GC" (Just 0),
EventType reqSeqGC "Request sequential GC" (Just 0),
EventType reqParGC "Reqpargc parallel GC" (Just 0),
EventType createSparkThread "Create spark thread" (Just 8),
EventType logMessage "Log message" Nothing,
EventType startup "Startup" (Just 0),
EventType blockMarker "Block marker" (Just 14)
]
-------------------------------------------------------------------------------
test :: String -> [Event]
-------------------------------------------------------------------------------
test "empty0"
= [
Event 0 (Startup 1) (Just 0)
]
-------------------------------------------------------------------------------
test "empty1"
= [
Event 0 (Startup 1) (Just 0)
]
-------------------------------------------------------------------------------
test "test0"
= [
Event 0 (Startup 1) (Just 0),
Event 4000000 Shutdown (Just 0)
]
-------------------------------------------------------------------------------
test "small"
= [
Event 0 (Startup 1) (Just 0),
Event 1000000 (CreateThread 1) (Just 0),
Event 2000000 (RunThread 1) (Just 0),
Event 3000000 (StopThread 1 ThreadFinished) (Just 0),
Event 4000000 (Shutdown) (Just 0)
]
-------------------------------------------------------------------------------
test "tick"
= [-- A thread from 2s to 3s
Event 0 (Startup 3) (Just 0),
Event 1000000000 (CreateThread 1) (Just 0),
Event 2000000000 (RunThread 1) (Just 0),
Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),
Event 4000000000 (Shutdown) (Just 0),
-- A thread from 0.2ms to 0.3ms
Event 1000000 (CreateThread 2) (Just 1),
Event 2000000 (RunThread 2) (Just 1),
Event 3000000 (StopThread 2 ThreadFinished) (Just 1),
Event 4000000 (Shutdown) (Just 1),
-- A thread from 0.2us to 0.3us
Event 1000 (CreateThread 3) (Just 2),
Event 2000 (RunThread 3) (Just 2),
Event 3000 (StopThread 3 ThreadFinished) (Just 2),
Event 4000 (Shutdown) (Just 2)
]
-------------------------------------------------------------------------------
test "tick2"
= [-- A thread create but no run
Event 0 (Startup 1) (Just 0),
Event 1000000000 (CreateThread 1) (Just 0),
Event 4000000000 (Shutdown) (Just 0)
]
-------------------------------------------------------------------------------
test "tick3"
= [-- A thread from 2s to 3s
Event 0 (Startup 1) (Just 0),
Event 1000000000 (CreateThread 1) (Just 0),
Event 2000000000 (RunThread 1) (Just 0),
Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),
Event 4000000000 (Shutdown) (Just 0)
]
-------------------------------------------------------------------------------
test "tick4"
= [-- A test for scale values close to 1.0
Event 0 (Startup 1) (Just 0),
Event 100 (CreateThread 1) (Just 0),
Event 200 (RunThread 1) (Just 0),
Event 300 (StopThread 1 ThreadFinished) (Just 0),
Event 400 (Shutdown) (Just 0)
]
-------------------------------------------------------------------------------
test "tick5"
= [-- A thread from 2s to 3s
Event 0 (Startup 1) (Just 0),
Event 1000000000 (CreateThread 1) (Just 0),
Event 2000000000 (RunThread 1) (Just 0),
Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),
Event 4000000000 (Shutdown) (Just 0)
]
-------------------------------------------------------------------------------
-- A long tick run to check small and large tick labels
test "tick6" = chequered 2 100 10000000
-------------------------------------------------------------------------------
test "overlap"
= [-- A thread from 2s to 3s
Event 0 (Startup 1) (Just 0),
Event 1000 (CreateThread 1) (Just 0),
Event 1100 (RunThread 1) (Just 0),
Event 1200 (CreateThread 2) (Just 0),
Event 1300 (StopThread 1 ThreadFinished) (Just 0),
Event 1400 (RunThread 2) (Just 0),
Event 1500 (CreateThread 3) (Just 0),
Event 1500 (CreateThread 4) (Just 0),
Event 1500 (StopThread 2 ThreadFinished) (Just 0),
Event 1600 (RunThread 3) (Just 0),
Event 1600 (CreateThread 5) (Just 0),
Event 1600 (StopThread 3 ThreadFinished) (Just 0),
Event 1700 (RunThread 4) (Just 0),
Event 1700 (CreateThread 6) (Just 0),
Event 1800 (StopThread 4 ThreadFinished) (Just 0),
Event 3000 (Shutdown) (Just 0)
]
-------------------------------------------------------------------------------
-- These tests are for chequered patterns to help check for rendering
-- problems and also to help test the performance of scrolling etc.
-- Each line has a fixed frequency of a thread running and then performing GC.
-- Each successive HEC runs thread at half the frequency of the previous HEC.
test "ch1" = chequered 1 100 100000
test "ch2" = chequered 2 100 100000
test "ch3" = chequered 3 100 100000
test "ch4" = chequered 4 100 100000
test "ch5" = chequered 5 100 100000
test "ch6" = chequered 6 100 100000
test "ch7" = chequered 7 100 100000
test "ch8" = chequered 8 100 100000
-------------------------------------------------------------------------------
test _ = []
-------------------------------------------------------------------------------
chequered :: ThreadId -> Timestamp -> Timestamp -> [Event]
chequered numThreads basicDuration runLength
= Event 0 (Startup (fromIntegral numThreads)) (Just 0) :
makeChequered 1 numThreads basicDuration runLength
-------------------------------------------------------------------------------
makeChequered :: ThreadId -> ThreadId -> Timestamp -> Timestamp -> [Event]
makeChequered currentThread numThreads _basicDuration _runLength
| currentThread > numThreads = [] -- All threads rendered
makeChequered currentThread numThreads basicDuration runLength
= eventBlock ++
makeChequered (currentThread+1) numThreads (2*basicDuration) runLength
where
eventBlock = Event 0 (CreateThread currentThread) (Just $ fromIntegral $ currentThread - 1)
: chequeredPattern currentThread 0 basicDuration runLength
-------------------------------------------------------------------------------
chequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event]
chequeredPattern currentThread currentPos basicDuration runLength
= if currentPos + 2*basicDuration > runLength then
[Event runLength Shutdown mcap]
else
[Event currentPos (RunThread currentThread) mcap,
Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding) mcap,
Event (currentPos+basicDuration) StartGC mcap,
Event (currentPos+2*basicDuration) EndGC mcap
] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength
where mcap = Just $ fromIntegral $ currentThread - 1
-------------------------------------------------------------------------------
================================================
FILE: GUI/App.hs
================================================
-------------------------------------------------------------------------------
-- | Module : GUI.App
--
-- Platform-specific application functionality
-------------------------------------------------------------------------------
module GUI.App (initApp) where
-------------------------------------------------------------------------------
-- | Initialize application
-- Perform application initialization for non-macOS platforms
initApp :: IO ()
initApp = return ()
================================================
FILE: GUI/BookmarkView.hs
================================================
module GUI.BookmarkView (
BookmarkView,
bookmarkViewNew,
BookmarkViewActions(..),
bookmarkViewGet,
bookmarkViewAdd,
bookmarkViewRemove,
bookmarkViewClear,
bookmarkViewSetLabel,
) where
import GHC.RTS.Events (Timestamp)
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import Numeric
import Data.Text (Text)
---------------------------------------------------------------------------
-- | Abstract bookmark view object.
--
data BookmarkView = BookmarkView {
bookmarkStore :: ListStore (Timestamp, Text)
}
-- | The actions to take in response to TraceView events.
--
data BookmarkViewActions = BookmarkViewActions {
bookmarkViewAddBookmark :: IO (),
bookmarkViewRemoveBookmark :: Int -> IO (),
bookmarkViewGotoBookmark :: Timestamp -> IO (),
bookmarkViewEditLabel :: Int -> Text -> IO ()
}
---------------------------------------------------------------------------
bookmarkViewAdd :: BookmarkView -> Timestamp -> Text -> IO ()
bookmarkViewAdd BookmarkView{bookmarkStore} ts label = do
listStoreAppend bookmarkStore (ts, label)
return ()
bookmarkViewRemove :: BookmarkView -> Int -> IO ()
bookmarkViewRemove BookmarkView{bookmarkStore} n = do
listStoreRemove bookmarkStore n
return ()
bookmarkViewClear :: BookmarkView -> IO ()
bookmarkViewClear BookmarkView{bookmarkStore} =
listStoreClear bookmarkStore
bookmarkViewGet :: BookmarkView -> IO [(Timestamp, Text)]
bookmarkViewGet BookmarkView{bookmarkStore} =
listStoreToList bookmarkStore
bookmarkViewSetLabel :: BookmarkView -> Int -> Text -> IO ()
bookmarkViewSetLabel BookmarkView{bookmarkStore} n label = do
(ts,_) <- listStoreGetValue bookmarkStore n
listStoreSetValue bookmarkStore n (ts, label)
---------------------------------------------------------------------------
bookmarkViewNew :: Builder -> BookmarkViewActions -> IO BookmarkView
bookmarkViewNew builder BookmarkViewActions{..} = do
let getWidget cast name = builderGetObject builder cast name
---------------------------------------------------------------------------
bookmarkTreeView <- getWidget castToTreeView "bookmark_list"
bookmarkStore <- listStoreNew []
columnTs <- treeViewColumnNew
cellTs <- cellRendererTextNew
columnLabel <- treeViewColumnNew
cellLabel <- cellRendererTextNew
selection <- treeViewGetSelection bookmarkTreeView
treeViewColumnSetTitle columnTs "Time"
treeViewColumnSetTitle columnLabel "Label"
treeViewColumnPackStart columnTs cellTs False
treeViewColumnPackStart columnLabel cellLabel True
treeViewAppendColumn bookmarkTreeView columnTs
treeViewAppendColumn bookmarkTreeView columnLabel
Compat.treeViewSetModel bookmarkTreeView (Just bookmarkStore)
cellLayoutSetAttributes columnTs cellTs bookmarkStore $ \(ts,_) ->
[ cellText := showFFloat (Just 6) (fromIntegral ts / 1000000) "s" ]
cellLayoutSetAttributes columnLabel cellLabel bookmarkStore $ \(_,label) ->
[ cellText := label ]
---------------------------------------------------------------------------
addBookmarkButton <- getWidget castToToolButton "add_bookmark_button"
deleteBookmarkButton <- getWidget castToToolButton "delete_bookmark"
gotoBookmarkButton <- getWidget castToToolButton "goto_bookmark_button"
onToolButtonClicked addBookmarkButton $
bookmarkViewAddBookmark
onToolButtonClicked deleteBookmarkButton $ do
selected <- treeSelectionGetSelected selection
case selected of
Nothing -> return ()
Just iter ->
let pos = listStoreIterToIndex iter
in bookmarkViewRemoveBookmark pos
onToolButtonClicked gotoBookmarkButton $ do
selected <- treeSelectionGetSelected selection
case selected of
Nothing -> return ()
Just iter -> do
let pos = listStoreIterToIndex iter
(ts,_) <- listStoreGetValue bookmarkStore pos
bookmarkViewGotoBookmark ts
bookmarkTreeView `on` rowActivated $ \[pos] _ -> do
(ts, _) <- listStoreGetValue bookmarkStore pos
bookmarkViewGotoBookmark ts
set cellLabel [ cellTextEditable := True ]
on cellLabel edited $ \[pos] val -> do
bookmarkViewEditLabel pos val
---------------------------------------------------------------------------
return BookmarkView{..}
================================================
FILE: GUI/ConcurrencyControl.hs
================================================
module GUI.ConcurrencyControl (
ConcurrencyControl,
start,
fullSpeed,
) where
import qualified System.Glib.MainLoop as Glib
import qualified Control.Concurrent as Concurrent
import qualified Control.Exception as Exception
import Control.Concurrent.MVar
newtype ConcurrencyControl = ConcurrencyControl (MVar (Int, Glib.HandlerId))
-- | Setup cooperative thread scheduling with Gtk+.
--
start :: IO ConcurrencyControl
start = do
handlerId <- normalScheduling
return . ConcurrencyControl =<< newMVar (0, handlerId)
-- | Run an expensive action that needs to use all the available CPU power.
--
-- The normal cooperative GUI thread scheduling does not work so well in this
-- case so we use an alternative technique. We can't use this one all the time
-- however or we'd hog the CPU even when idle.
--
fullSpeed :: ConcurrencyControl -> IO a -> IO a
fullSpeed (ConcurrencyControl handlerRef) =
Exception.bracket_ begin end
where
-- remove the normal scheduling handler and put in the full speed one
begin = do
(count, handlerId) <- takeMVar handlerRef
if count == 0
-- nobody else is running fullSpeed
then do Glib.timeoutRemove handlerId
handlerId' <- fullSpeedScheduling
putMVar handlerRef (1, handlerId')
-- we're already running fullSpeed, just inc the count
else do putMVar handlerRef (count+1, handlerId)
-- reinstate the normal scheduling
end = do
(count, handlerId) <- takeMVar handlerRef
if count == 1
-- just us running fullSpeed so we clean up
then do Glib.timeoutRemove handlerId
handlerId' <- normalScheduling
putMVar handlerRef (0, handlerId')
-- someone else running fullSpeed, they're responsible for stopping
else do putMVar handlerRef (count-1, handlerId)
normalScheduling :: IO Glib.HandlerId
normalScheduling =
Glib.timeoutAddFull
(Concurrent.yield >> return True)
Glib.priorityDefaultIdle 50
--50ms, ie 20 times a second.
fullSpeedScheduling :: IO Glib.HandlerId
fullSpeedScheduling =
Glib.idleAdd
(Concurrent.yield >> return True)
Glib.priorityDefaultIdle
================================================
FILE: GUI/DataFiles.hs
================================================
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module GUI.DataFiles
( ui
, loadLogo
) where
import Control.Exception (IOException, Handler(..), catches)
import System.IO
import Data.FileEmbed
import Graphics.UI.Gtk (Pixbuf, pixbufNewFromFile)
import Language.Haskell.TH
import System.Glib (GError)
import System.IO.Temp
import qualified Data.ByteString as B
import qualified Data.Text.Encoding as TE
uiFile :: FilePath
uiFile = "threadscope.ui"
logoFile :: FilePath
logoFile = "threadscope.png"
-- | Textual representation of the UI file
ui :: Q Exp
ui = [| TE.decodeUtf8 $(makeRelativeToProject uiFile >>= embedFile) |]
renderLogo :: B.ByteString -> IO (Maybe Pixbuf)
renderLogo bytes =
withSystemTempFile logoFile $ \path h -> do
B.hPut h bytes
hClose h
Just <$> pixbufNewFromFile path
`catches`
-- in case of a failure in the file IO or pixbufNewFromFile, return Nothing
[ Handler $ \(_ :: IOException) -> return Nothing
, Handler $ \(_ :: GError) -> return Nothing
]
-- | Load the logo file as a 'Pixbuf'.
loadLogo :: Q Exp
loadLogo = [| renderLogo $(makeRelativeToProject logoFile >>= embedFile) |]
================================================
FILE: GUI/Dialogs.hs
================================================
{-# LANGUAGE TemplateHaskell #-}
module GUI.Dialogs where
import GUI.DataFiles (loadLogo)
import Paths_threadscope (version)
import Graphics.UI.Gtk
import Data.Version (showVersion)
import System.FilePath
import Control.Monad.Trans
-------------------------------------------------------------------------------
aboutDialog :: WindowClass window => window -> IO ()
aboutDialog parent
= do dialog <- aboutDialogNew
logo <- $loadLogo
set dialog [
aboutDialogName := "ThreadScope",
aboutDialogVersion := showVersion version,
aboutDialogCopyright := "Released under the GHC license as part of the Glasgow Haskell Compiler.",
aboutDialogComments := "A GHC eventlog profile viewer",
aboutDialogAuthors := ["Donnie Jones <donnie@darthik.com>",
"Simon Marlow <simonm@microsoft.com>",
"Satnam Singh <s.singh@ieee.org>",
"Duncan Coutts <duncan@well-typed.com>",
"Mikolaj Konarski <mikolaj@well-typed.com>",
"Nicolas Wu <nick@well-typed.com>",
"Eric Kow <eric@well-typed.com>"],
aboutDialogLogo := logo,
aboutDialogWebsite := "http://www.haskell.org/haskellwiki/ThreadScope",
windowTransientFor := toWindow parent
]
dialog `on` response $ \_ -> widgetDestroy dialog
widgetShow dialog
-------------------------------------------------------------------------------
openFileDialog :: WindowClass window => window -> (FilePath -> IO ()) -> IO ()
openFileDialog parent open
= do dialog <- fileChooserDialogNew
(Just "Open Profile...")
(Just (toWindow parent))
FileChooserActionOpen
[("gtk-cancel", ResponseCancel)
,("gtk-open", ResponseAccept)]
set dialog [
windowModal := True
]
eventlogfiles <- fileFilterNew
fileFilterSetName eventlogfiles "GHC eventlog files (*.eventlog)"
fileFilterAddPattern eventlogfiles "*.eventlog"
fileChooserAddFilter dialog eventlogfiles
allfiles <- fileFilterNew
fileFilterSetName allfiles "All files"
fileFilterAddPattern allfiles "*"
fileChooserAddFilter dialog allfiles
dialog `on` response $ \response -> do
case response of
ResponseAccept -> do
mfile <- fileChooserGetFilename dialog
case mfile of
Just file -> open file
Nothing -> return ()
_ -> return ()
widgetDestroy dialog
widgetShowAll dialog
-------------------------------------------------------------------------------
data FileExportFormat = FormatPDF | FormatPNG
exportFileDialog :: WindowClass window => window
-> FilePath
-> (FilePath -> FileExportFormat -> IO ())
-> IO ()
exportFileDialog parent oldfile save = do
dialog <- fileChooserDialogNew
(Just "Save timeline image...")
(Just (toWindow parent))
FileChooserActionSave
[("gtk-cancel", ResponseCancel)
,("gtk-save", ResponseAccept)]
set dialog [
fileChooserDoOverwriteConfirmation := True,
windowModal := True
]
let (olddir, oldfilename) = splitFileName oldfile
fileChooserSetCurrentName dialog (replaceExtension oldfilename "png")
fileChooserSetCurrentFolder dialog olddir
pngFiles <- fileFilterNew
fileFilterSetName pngFiles "PNG bitmap files"
fileFilterAddPattern pngFiles "*.png"
fileChooserAddFilter dialog pngFiles
pdfFiles <- fileFilterNew
fileFilterSetName pdfFiles "PDF files"
fileFilterAddPattern pdfFiles "*.pdf"
fileChooserAddFilter dialog pdfFiles
dialog `on` response $ \response ->
case response of
ResponseAccept -> do
mfile <- fileChooserGetFilename dialog
case mfile of
Just file
| takeExtension file == ".pdf" -> do
save file FormatPDF
widgetDestroy dialog
| takeExtension file == ".png" -> do
save file FormatPNG
widgetDestroy dialog
| otherwise ->
formatError dialog
Nothing -> widgetDestroy dialog
_ -> widgetDestroy dialog
widgetShowAll dialog
where
formatError dialog = do
msg <- messageDialogNew (Just (toWindow dialog))
[DialogModal, DialogDestroyWithParent]
MessageError ButtonsClose
"The file format is unknown or unsupported"
set msg [
messageDialogSecondaryText := Just $
"The PNG and PDF formats are supported. "
++ "Please use a file extension of '.png' or '.pdf'."
]
dialogRun msg
widgetDestroy msg
-------------------------------------------------------------------------------
errorMessageDialog :: WindowClass window => window -> String -> String -> IO ()
errorMessageDialog parent headline explanation = do
dialog <- messageDialogNew (Just (toWindow parent))
[] MessageError ButtonsNone ""
set dialog
[ windowModal := True
, windowTransientFor := toWindow parent
, messageDialogText := Just headline
, messageDialogSecondaryText := Just explanation
, windowResizable := True
]
dialogAddButton dialog "Close" ResponseClose
dialogSetDefaultResponse dialog ResponseClose
dialog `on` response $ \_-> widgetDestroy dialog
widgetShowAll dialog
================================================
FILE: GUI/EventsView.hs
================================================
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module GUI.EventsView (
EventsView,
eventsViewNew,
EventsViewActions(..),
eventsViewSetEvents,
eventsViewGetCursor,
eventsViewSetCursor,
eventsViewScrollToLine,
) where
import GHC.RTS.Events
import Graphics.UI.Gtk hiding (rectangle)
import Graphics.Rendering.Cairo
import GUI.ViewerColours
import Control.Monad
import Data.Array
import Data.Monoid
import Data.IORef
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Lazy.Builder.Int as TB (decimal)
import Numeric
import Prelude
-------------------------------------------------------------------------------
data EventsView = EventsView {
drawArea :: !Widget,
adj :: !Adjustment,
stateRef :: !(IORef ViewState)
}
data EventsViewActions = EventsViewActions {
eventsViewCursorChanged :: Int -> IO ()
}
data ViewState = ViewState {
lineHeight :: !Double,
eventsState :: !EventsState
}
data EventsState
= EventsEmpty
| EventsLoaded {
cursorPos :: !Int,
mrange :: !(Maybe (Int, Int)),
eventsArr :: Array Int Event
}
-------------------------------------------------------------------------------
eventsViewNew :: Builder -> EventsViewActions -> IO EventsView
eventsViewNew builder EventsViewActions{..} = do
stateRef <- newIORef undefined
let getWidget cast = builderGetObject builder cast
drawArea <- getWidget castToWidget ("eventsDrawingArea" :: T.Text)
vScrollbar <- getWidget castToVScrollbar ("eventsVScroll" :: T.Text)
adj <- get vScrollbar rangeAdjustment
widgetSetCanFocus drawArea True
--TODO: needs to be reset on each style change ^^
-----------------------------------------------------------------------------
-- Line height
-- Calculate the height of each line based on the current font
let getLineHeight = do
pangoCtx <- widgetGetPangoContext drawArea
fontDesc <- contextGetFontDescription pangoCtx
metrics <- contextGetMetrics pangoCtx fontDesc emptyLanguage
return $ ascent metrics + descent metrics --TODO: padding?
-- We cache the height of each line
initialLineHeight <- getLineHeight
-- but have to update it when the font changes
on drawArea styleSet $ \_ -> do
lineHeight' <- getLineHeight
modifyIORef stateRef $ \viewstate -> viewstate { lineHeight = lineHeight' }
-----------------------------------------------------------------------------
writeIORef stateRef ViewState {
lineHeight = initialLineHeight,
eventsState = EventsEmpty
}
let eventsView = EventsView {..}
-----------------------------------------------------------------------------
-- Drawing
on drawArea draw $ liftIO $ do
drawEvents eventsView =<< readIORef stateRef
return ()
-----------------------------------------------------------------------------
-- Key navigation
on drawArea keyPressEvent $ do
let scroll by = liftIO $ do
ViewState{eventsState, lineHeight} <- readIORef stateRef
pagesize <- get adj adjustmentPageSize
let pagejump = max 1 (truncate (pagesize / lineHeight) - 1)
case eventsState of
EventsEmpty -> return ()
EventsLoaded{cursorPos, eventsArr} ->
eventsViewCursorChanged cursorPos'
where
cursorPos' = clampBounds range (by pagejump end cursorPos)
range@(_,end) = bounds eventsArr
return True
key <- eventKeyName
#if MIN_VERSION_gtk3(0,13,0)
case T.unpack key of
#else
case key of
#endif
"Up" -> scroll (\_page _end pos -> pos-1)
"Down" -> scroll (\_page _end pos -> pos+1)
"Page_Up" -> scroll (\ page _end pos -> pos-page)
"Page_Down" -> scroll (\ page _end pos -> pos+page)
"Home" -> scroll (\_page _end _pos -> 0)
"End" -> scroll (\_page end _pos -> end)
"Left" -> return True
"Right" -> return True
_ -> return False
-----------------------------------------------------------------------------
-- Scrolling
set adj [ adjustmentLower := 0 ]
on drawArea sizeAllocate $ \_ ->
updateScrollAdjustment eventsView =<< readIORef stateRef
let hitpointToLine :: ViewState -> Double -> Double -> Maybe Int
hitpointToLine ViewState{eventsState = EventsEmpty} _ _ = Nothing
hitpointToLine ViewState{eventsState = EventsLoaded{eventsArr}, lineHeight}
yOffset eventY
| hitLine > maxIndex = Nothing
| otherwise = Just hitLine
where
hitLine = truncate ((yOffset + eventY) / lineHeight)
maxIndex = snd (bounds eventsArr)
on drawArea buttonPressEvent $ tryEvent $ do
(_,y) <- eventCoordinates
liftIO $ do
viewState <- readIORef stateRef
yOffset <- get adj adjustmentValue
widgetGrabFocus drawArea
case hitpointToLine viewState yOffset y of
Nothing -> return ()
Just n -> eventsViewCursorChanged n
on drawArea scrollEvent $ do
dir <- eventScrollDirection
liftIO $ do
val <- get adj adjustmentValue
upper <- get adj adjustmentUpper
pagesize <- get adj adjustmentPageSize
step <- get adj adjustmentStepIncrement
case dir of
ScrollUp -> set adj [ adjustmentValue := val - step ]
ScrollDown -> set adj [ adjustmentValue := min (val + step)
(upper - pagesize) ]
_ -> return ()
return True
onValueChanged adj $
widgetQueueDraw drawArea
-----------------------------------------------------------------------------
return eventsView
-------------------------------------------------------------------------------
eventsViewSetEvents :: EventsView -> Maybe (Array Int Event) -> IO ()
eventsViewSetEvents eventWin@EventsView{drawArea, stateRef} mevents = do
viewState <- readIORef stateRef
let eventsState' = case mevents of
Nothing -> EventsEmpty
Just events -> EventsLoaded {
cursorPos = 0,
mrange = Nothing,
eventsArr = events
}
viewState' = viewState { eventsState = eventsState' }
writeIORef stateRef viewState'
updateScrollAdjustment eventWin viewState'
widgetQueueDraw drawArea
-------------------------------------------------------------------------------
eventsViewGetCursor :: EventsView -> IO (Maybe Int)
eventsViewGetCursor EventsView{stateRef} = do
ViewState{eventsState} <- readIORef stateRef
case eventsState of
EventsEmpty -> return Nothing
EventsLoaded{cursorPos} -> return (Just cursorPos)
eventsViewSetCursor :: EventsView -> Int -> Maybe (Int, Int) -> IO ()
eventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n mrange = do
viewState@ViewState{eventsState} <- readIORef stateRef
case eventsState of
EventsEmpty -> return ()
EventsLoaded{eventsArr} -> do
let n' = clampBounds (bounds eventsArr) n
writeIORef stateRef viewState {
eventsState = eventsState { cursorPos = n', mrange }
}
eventsViewScrollToLine eventsView n'
widgetQueueDraw drawArea
eventsViewScrollToLine :: EventsView -> Int -> IO ()
eventsViewScrollToLine EventsView{adj, stateRef} n = do
ViewState{lineHeight} <- readIORef stateRef
-- make sure that the range [n..n+1] is within the current page:
adjustmentClampPage adj
(fromIntegral n * lineHeight)
(fromIntegral (n+1) * lineHeight)
-------------------------------------------------------------------------------
updateScrollAdjustment :: EventsView -> ViewState -> IO ()
updateScrollAdjustment EventsView{drawArea, adj}
ViewState{lineHeight, eventsState} = do
Rectangle _ _ _ windowHeight <- widgetGetAllocation drawArea
let numLines = case eventsState of
EventsEmpty -> 0
EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1
linesHeight = fromIntegral numLines * lineHeight
upper = max linesHeight (fromIntegral windowHeight)
pagesize = fromIntegral windowHeight
set adj [
adjustmentUpper := upper,
adjustmentPageSize := pagesize,
adjustmentStepIncrement := pagesize * 0.2,
adjustmentPageIncrement := pagesize * 0.9
]
val <- get adj adjustmentValue
when (val > upper - pagesize) $
set adj [ adjustmentValue := max 0 (upper - pagesize) ]
-------------------------------------------------------------------------------
drawEvents :: EventsView -> ViewState -> IO ()
drawEvents _ ViewState {eventsState = EventsEmpty} = return ()
drawEvents EventsView{drawArea, adj}
ViewState {lineHeight, eventsState = EventsLoaded{..}} = do
yOffset <- get adj adjustmentValue
pageSize <- get adj adjustmentPageSize
-- calculate which lines are visible
let lower = truncate (yOffset / lineHeight)
upper = ceiling ((yOffset + pageSize) / lineHeight)
-- the array indexes [begin..end] inclusive
-- are partially or fully visible
begin = lower
end = min upper (snd (bounds eventsArr))
-- TODO: don't use Just here
Just win <- widgetGetWindow drawArea
style <- widgetGetStyle drawArea
focused <- widgetGetIsFocus drawArea
let state | focused = StateSelected
| otherwise = StateActive
pangoCtx <- widgetGetPangoContext drawArea
layout <- layoutEmpty pangoCtx
layoutSetEllipsize layout EllipsizeEnd
(Rectangle _ _ width _) <- widgetGetAllocation drawArea
let clipRect = Rectangle 0 0 0 0
let -- With average char width, timeWidth is enough for 24 hours of logs
-- (way more than TS can handle, currently). Aligns nicely with
-- current timeline_yscale_area width, too.
-- TODO: take timeWidth from the yScaleDrawingArea width
-- TODO: perhaps make the timeWidth area grey, too?
-- TODO: perhaps limit scroll to the selected interval (perhaps not strictly, but only so that the interval area does not completely vanish from the visible area)?
timeWidth = 105
columnGap = 20
descrWidth = width - timeWidth - columnGap
sequence_
[ do when (inside || selected) $
renderWithDrawWindow win $ do
setSourceRGBAForStyle styleGetBackground style state1
rectangle 0 y (fromIntegral width) lineHeight
fill
-- The event time
layoutSetText layout (showEventTime event)
layoutSetAlignment layout AlignRight
layoutSetWidth layout (Just (fromIntegral timeWidth))
renderWithDrawWindow win $ do
setForegroundColor style state2
moveTo 0 y
showLayout layout
-- The event description text
layoutSetText layout (showEventDescr event)
layoutSetAlignment layout AlignLeft
layoutSetWidth layout (Just (fromIntegral descrWidth))
renderWithDrawWindow win $ do
setForegroundColor style state2
moveTo (fromIntegral $ timeWidth + columnGap) y
showLayout layout
| n <- [begin..end]
, let y = fromIntegral n * lineHeight - yOffset
event = eventsArr ! n
inside = maybe False (\ (s, e) -> s <= n && n <= e) mrange
selected = cursorPos == n
(state1, state2)
| inside = (StateSelected, StateSelected)
| selected = (StateSelected, state)
| otherwise = (state, StateNormal)
]
where
showEventTime (Event time _spec _) =
showFFloat (Just 6) (fromIntegral time / 1000000) "s"
showEventDescr :: Event -> T.Text
showEventDescr (Event _time spec cap) = TL.toStrict $ TB.toLazyText $
maybe "" (\c -> "HEC " <> TB.decimal c <> ": ") cap
<> case spec of
UnknownEvent{ref} -> "unknown event; " <> TB.decimal ref
Message msg -> TB.fromText msg
UserMessage msg -> TB.fromText msg
_ -> buildEventInfo spec
setForegroundColor = setSourceRGBAForStyle styleGetForeground
-------------------------------------------------------------------------------
clampBounds :: Ord a => (a, a) -> a -> a
clampBounds (lower, upper) x
| x <= lower = lower
| x > upper = upper
| otherwise = x
================================================
FILE: GUI/GtkExtras.hs
================================================
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
module GUI.GtkExtras where
-- This is all stuff that should be bound in the gtk package but is not yet
-- (as of gtk-0.12.0)
import Graphics.UI.GtkInternals
import Graphics.UI.Gtk (Rectangle)
import System.Glib.MainLoop
import Graphics.Rendering.Pango.Types
import Graphics.Rendering.Pango.BasicTypes
import Graphics.UI.Gtk.General.Enums (StateType, ShadowType)
import Foreign
import Foreign.C
import Control.Concurrent.MVar
#if mingw32_HOST_OS || mingw32_TARGET_OS
#include "windows_cconv.h"
#else
import System.Glib.GError
import Control.Monad
#endif
waitGUI :: IO ()
waitGUI = do
resultVar <- newEmptyMVar
idleAdd (putMVar resultVar () >> return False) priorityDefaultIdle
takeMVar resultVar
-------------------------------------------------------------------------------
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 WINDOWS_CCONV unsafe "shlobj.h ShellExecuteA"
c_ShellExecuteA :: Ptr () -- HWND hwnd
-> CString -- LPCTSTR lpOperation
-> CString -- LPCTSTR lpFile
-> CString -- LPCTSTR lpParameters
-> CString -- LPCTSTR lpDirectory
-> CInt -- INT nShowCmd
-> IO CInt -- HINSTANCE return
#else
launchProgramForURI uri =
propagateGError $ \errPtrPtr ->
withCString uri $ \uriStrPtr -> do
timestamp <- gtk_get_current_event_time
liftM toBool $ gtk_show_uri nullPtr uriStrPtr timestamp errPtrPtr
#endif
-------------------------------------------------------------------------------
foreign import ccall safe "gtk_show_uri"
gtk_show_uri :: Ptr Screen -> Ptr CChar -> CUInt -> Ptr (Ptr ()) -> IO CInt
foreign import ccall unsafe "gtk_get_current_event_time"
gtk_get_current_event_time :: IO CUInt
================================================
FILE: GUI/Histogram.hs
================================================
{-# LANGUAGE ScopedTypeVariables #-}
module GUI.Histogram (
HistogramView,
histogramViewNew,
histogramViewSetHECs,
histogramViewSetInterval,
) where
import Events.HECs
import GUI.Timeline.Render (renderTraces, renderYScaleArea)
import GUI.Timeline.Render.Constants
import GUI.Types
import qualified Graphics.Rendering.Cairo as C
import Graphics.UI.Gtk
import qualified GUI.GtkExtras as GtkExt
import Data.IORef
import Control.Monad.Trans
data HistogramView =
HistogramView
{ hecsIORef :: IORef (Maybe HECs)
, mintervalIORef :: IORef (Maybe Interval)
, histogramDrawingArea :: DrawingArea
, histogramYScaleArea :: DrawingArea
}
histogramViewSetHECs :: HistogramView -> Maybe HECs -> IO ()
histogramViewSetHECs HistogramView{..} mhecs = do
writeIORef hecsIORef mhecs
writeIORef mintervalIORef Nothing -- the old interval may make no sense
widgetQueueDraw histogramDrawingArea
widgetQueueDraw histogramYScaleArea
histogramViewSetInterval :: HistogramView -> Maybe Interval -> IO ()
histogramViewSetInterval HistogramView{..} minterval = do
writeIORef mintervalIORef minterval
widgetQueueDraw histogramDrawingArea
widgetQueueDraw histogramYScaleArea
histogramViewNew :: Builder -> IO HistogramView
histogramViewNew builder = do
let getWidget cast = builderGetObject builder cast
histogramDrawingArea <- getWidget castToDrawingArea "histogram_drawingarea"
histogramYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area2"
timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area"
-- HACK: layoutSetAttributes does not work for \mu, so let's work around
fd <- fontDescriptionNew
fontDescriptionSetSize fd 8
fontDescriptionSetFamily fd "sans serif"
widgetModifyFont histogramYScaleArea (Just fd)
Rectangle _ _ _ xh <- widgetGetAllocation timelineXScaleArea
let xScaleAreaHeight = fromIntegral xh
traces = [TraceHistogram]
paramsHist (w, h) minterval = ViewParameters
{ width = w
, height = h
, viewTraces = traces
, hadjValue = 0
, scaleValue = 1
, maxSpkValue = undefined
, detail = undefined
, bwMode = undefined
, labelsMode = False
, histogramHeight = h - histXScaleHeight
, minterval = minterval
, xScaleAreaHeight = xScaleAreaHeight
}
hecsIORef <- newIORef Nothing
mintervalIORef <- newIORef Nothing
pangoCtx <- widgetGetPangoContext histogramDrawingArea
style <- get histogramDrawingArea widgetStyle
layout <- layoutEmpty pangoCtx
(_ :: String) <- layoutSetMarkup layout $
"No detailed spark events in this eventlog.\n"
++ "Re-run with <tt>+RTS -lf</tt> to generate them."
-- Program the callback for the capability drawingArea
on histogramDrawingArea draw $
C.liftIO $ do
maybeEventArray <- readIORef hecsIORef
-- TODO: get rid of Just
Just win <- widgetGetWindow histogramDrawingArea
Rectangle _ _ w windowHeight <- widgetGetAllocation histogramDrawingArea
case maybeEventArray of
Nothing -> return ()
Just hecs
| null (durHistogram hecs) -> do
renderWithDrawWindow win $ do
C.moveTo 4 20
showLayout layout
return ()
| otherwise -> do
minterval <- readIORef mintervalIORef
if windowHeight < 80
then return ()
else do
let size = (w, windowHeight - firstTraceY)
params = paramsHist size minterval
rect = Rectangle 0 0 w (snd size)
renderWithDrawWindow win $
renderTraces params hecs rect
return ()
-- Redrawing histogramYScaleArea
histogramYScaleArea `on` draw $ liftIO $ do
maybeEventArray <- readIORef hecsIORef
case maybeEventArray of
Nothing -> return ()
Just hecs
| null (durHistogram hecs) -> return ()
| otherwise -> do
-- TODO: get rid of Just
Just win <- widgetGetWindow histogramYScaleArea
minterval <- readIORef mintervalIORef
Rectangle _ _ _ windowHeight <- widgetGetAllocation histogramYScaleArea
if windowHeight < 80
then return ()
else do
let size = (undefined, windowHeight - firstTraceY)
params = paramsHist size minterval
renderWithDrawWindow win $
renderYScaleArea params hecs histogramYScaleArea
return ()
return HistogramView{..}
================================================
FILE: GUI/KeyView.hs
================================================
module GUI.KeyView (
KeyView,
keyViewNew,
) where
import GUI.ViewerColours
import GUI.Timeline.Render.Constants
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import qualified Graphics.Rendering.Cairo as C
---------------------------------------------------------------------------
-- | Abstract key view object.
--
data KeyView = KeyView
---------------------------------------------------------------------------
keyViewNew :: Builder -> IO KeyView
keyViewNew builder = do
keyTreeView <- builderGetObject builder castToTreeView "key_list"
-- TODO: get rid of this Just
Just dw <- widgetGetWindow keyTreeView
keyEntries <- createKeyEntries dw keyData
keyStore <- listStoreNew keyEntries
keyColumn <- treeViewColumnNew
imageCell <- cellRendererPixbufNew
labelCell <- cellRendererTextNew
treeViewColumnPackStart keyColumn imageCell False
treeViewColumnPackStart keyColumn labelCell True
treeViewAppendColumn keyTreeView keyColumn
selection <- treeViewGetSelection keyTreeView
treeSelectionSetMode selection SelectionNone
let tooltipColumn = makeColumnIdString 0
customStoreSetColumn keyStore tooltipColumn (\(_,tooltip,_) -> tooltip)
Compat.treeViewSetModel keyTreeView (Just keyStore)
set keyTreeView [ treeViewTooltipColumn := tooltipColumn ]
cellLayoutSetAttributes keyColumn imageCell keyStore $ \(_,_,img) ->
[ cellPixbuf := img ]
cellLayoutSetAttributes keyColumn labelCell keyStore $ \(label,_,_) ->
[ cellText := label ]
---------------------------------------------------------------------------
return KeyView
-------------------------------------------------------------------------------
data KeyStyle = KDuration | KEvent | KEventAndGraph
keyData :: [(String, KeyStyle, Color, String)]
keyData =
[ ("running", KDuration, runningColour,
"Indicates a period of time spent running Haskell code (not GC, not blocked/idle)")
, ("GC", KDuration, gcColour,
"Indicates a period of time spent by the RTS performing garbage collection (GC)")
, ("GC waiting", KDuration, gcWaitColour,
"Indicates a period of time spent by the RTS waiting to initiate or finish garbage collection (GC)")
, ("create thread", KEvent, createThreadColour,
"Indicates a new Haskell thread has been created")
, ("seq GC req", KEvent, seqGCReqColour,
"Indicates a HEC has requested to start a sequential GC")
, ("par GC req", KEvent, parGCReqColour,
"Indicates a HEC has requested to start a parallel GC")
, ("migrate thread", KEvent, migrateThreadColour,
"Indicates a Haskell thread has been moved from one HEC to another")
, ("thread wakeup", KEvent, threadWakeupColour,
"Indicates that a thread that was previously blocked (e.g. I/O, MVar etc) is now ready to run")
, ("shutdown", KEvent, shutdownColour,
"Indicates a HEC is terminating")
, ("user message", KEvent, userMessageColour,
"Indicates a message generated from Haskell code (via traceEvent)")
, ("perf counter", KEvent, createdConvertedColour,
"Indicates an update of a perf counter")
, ("perf tracepoint", KEvent, shutdownColour,
"Indicates that a perf tracepoint was reached")
, ("create spark", KEventAndGraph, createdConvertedColour,
"As an event it indicates a use of `par` resulted in a spark being " ++
"created (and added to the spark pool). In the spark creation " ++
"graph the coloured area represents the number of sparks created.")
, ("dud spark", KEventAndGraph, fizzledDudsColour,
"As an event it indicates a use of `par` resulted in the spark being " ++
"discarded because it was a 'dud' (already evaluated). In the spark " ++
"creation graph the coloured area represents the number of dud sparks.")
, ("overflowed spark",KEventAndGraph, overflowedColour,
"As an event it indicates a use of `par` resulted in the spark being " ++
"discarded because the spark pool was full. In the spark creation " ++
"graph the coloured area represents the number of overflowed sparks.")
, ("run spark", KEventAndGraph, createdConvertedColour,
"As an event it indicates a spark has started to be run/evaluated. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks run.")
, ("fizzled spark", KEventAndGraph, fizzledDudsColour,
"As an event it indicates a spark has 'fizzled', meaning it has been " ++
"discovered that the spark's thunk was evaluated by some other thread. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks that have fizzled.")
, ("GCed spark", KEventAndGraph, gcColour,
"As an event it indicates a spark has been GCed, meaning it has been " ++
"discovered that the spark's thunk was no longer needed anywhere. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks that were GCed.")
]
createKeyEntries :: DrawWindowClass dw
=> dw
-> [(String, KeyStyle, Color,String)]
-> IO [(String, String, Pixbuf)]
createKeyEntries similar entries =
sequence
[ do pixbuf <- renderToPixbuf similar (50, hecBarHeight) $ do
C.setSourceRGB 1 1 1
C.paint
renderKeyIcon style colour
return (label, tooltip, pixbuf)
| (label, style, colour, tooltip) <- entries ]
renderKeyIcon :: KeyStyle -> Color -> C.Render ()
renderKeyIcon KDuration keyColour = do
setSourceRGBAhex keyColour 1.0
let x = fromIntegral ox
C.rectangle (x - 2) 5 38 (fromIntegral (hecBarHeight `div` 2))
C.fill
renderKeyIcon KEvent keyColour = renderKEvent keyColour
renderKeyIcon KEventAndGraph keyColour = do
renderKEvent keyColour
-- An icon roughly representing a jaggedy graph.
let x = fromIntegral ox
y = fromIntegral hecBarHeight
C.moveTo (2*x) (y - 2)
C.relLineTo 3 (-6)
C.relLineTo 3 0
C.relLineTo 3 3
C.relLineTo 5 1
C.relLineTo 1 (-(y - 4))
C.relLineTo 2 (y - 4)
C.relLineTo 1 (-(y - 4))
C.relLineTo 2 (y - 4)
C.lineTo (2*x+20) (y - 2)
C.fill
setSourceRGBAhex black 1.0
C.setLineWidth 1.0
C.moveTo (2*x-4) (y - 2.5)
C.lineTo (2*x+24) (y - 2.5)
C.stroke
renderKEvent :: Color -> C.Render ()
renderKEvent keyColour = do
setSourceRGBAhex keyColour 1.0
C.setLineWidth 3.0
let x = fromIntegral ox
C.moveTo x 0
C.relLineTo 0 25
C.stroke
renderToPixbuf :: DrawWindowClass dw => dw -> (Int, Int) -> C.Render ()
-> IO Pixbuf
renderToPixbuf similar (w, h) draw = do
renderWithDrawWindow similar draw
pixbuf <- pixbufNewFromWindow similar 0 0 w h
return pixbuf
-------------------------------------------------------------------------------
================================================
FILE: GUI/Main.hs
================================================
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module GUI.Main (runGUI) where
-- Imports for GTK
import qualified Graphics.UI.Gtk as Gtk
import System.Glib.GError (failOnGError)
-- Imports from Haskell library
import Text.Printf
#ifndef mingw32_HOST_OS
import System.Posix
#endif
import Control.Concurrent
import qualified Control.Concurrent.Chan as Chan
import Control.Exception
import Data.Array
import Data.Maybe
import Data.Text (Text)
-- Imports for ThreadScope
import qualified GUI.App as App
import qualified GUI.MainWindow as MainWindow
import GUI.Types
import Events.HECs hiding (Event)
import GUI.DataFiles (ui)
import GUI.Dialogs
import Events.ReadEvents
import GUI.EventsView
import GUI.SummaryView
import GUI.StartupInfoView
import GUI.Histogram
import GUI.Timeline
import GUI.TraceView
import GUI.BookmarkView
import GUI.KeyView
import GUI.SaveAs
import qualified GUI.ConcurrencyControl as ConcurrencyControl
import qualified GUI.ProgressView as ProgressView
import qualified GUI.GtkExtras as GtkExtras
-------------------------------------------------------------------------------
data UIEnv = UIEnv {
mainWin :: MainWindow.MainWindow,
eventsView :: EventsView,
startupView :: StartupInfoView,
summaryView :: SummaryView,
histogramView :: HistogramView,
timelineWin :: TimelineView,
traceView :: TraceView,
bookmarkView :: BookmarkView,
keyView :: KeyView,
eventQueue :: Chan Event,
concCtl :: ConcurrencyControl.ConcurrencyControl
}
data EventlogState
= NoEventlogLoaded
| EventlogLoaded {
mfilename :: Maybe FilePath, --test traces have no filepath
hecs :: HECs,
selection :: TimeSelection,
cursorPos :: Int
}
postEvent :: Chan Event -> Event -> IO ()
postEvent = Chan.writeChan
getEvent :: Chan Event -> IO Event
getEvent = Chan.readChan
data Event
= EventOpenDialog
| EventExportDialog
| EventLaunchWebsite
| EventLaunchTutorial
| EventAboutDialog
| EventQuit
| EventFileLoad FilePath
| EventTestLoad String
| EventFileReload
| EventFileExport FilePath FileExportFormat
| EventSetState HECs (Maybe FilePath) String Int Double
| EventShowSidebar Bool
| EventShowEvents Bool
| EventTimelineJumpStart
| EventTimelineJumpEnd
| EventTimelineJumpCursor
| EventTimelineScrollLeft
| EventTimelineScrollRight
| EventTimelineZoomIn
| EventTimelineZoomOut
| EventTimelineZoomToFit
| EventTimelineLabelsMode Bool
| EventTimelineShowBW Bool
| EventCursorChangedIndex Int
| EventCursorChangedSelection TimeSelection
| EventTracesChanged [Trace]
| EventBookmarkAdd
| EventBookmarkRemove Int
| EventBookmarkEdit Int Text
| EventUserError String SomeException
-- can add more specific ones if necessary
constructUI :: IO UIEnv
constructUI = failOnGError $ do
builder <- Gtk.builderNew
Gtk.builderAddFromString builder $ui
eventQueue <- Chan.newChan
let post = postEvent eventQueue
mainWin <- MainWindow.mainWindowNew builder MainWindow.MainWindowActions {
mainWinOpen = post EventOpenDialog,
mainWinExport = post EventExportDialog,
mainWinQuit = post EventQuit,
mainWinViewSidebar = post . EventShowSidebar,
mainWinViewEvents = post . EventShowEvents,
mainWinViewReload = post EventFileReload,
mainWinWebsite = post EventLaunchWebsite,
mainWinTutorial = post EventLaunchTutorial,
mainWinAbout = post EventAboutDialog,
mainWinJumpStart = post EventTimelineJumpStart,
mainWinJumpEnd = post EventTimelineJumpEnd,
mainWinJumpCursor = post EventTimelineJumpCursor,
mainWinScrollLeft = post EventTimelineScrollLeft,
mainWinScrollRight = post EventTimelineScrollRight,
mainWinJumpZoomIn = post EventTimelineZoomIn,
mainWinJumpZoomOut = post EventTimelineZoomOut,
mainWinJumpZoomFit = post EventTimelineZoomToFit,
mainWinDisplayLabels = post . EventTimelineLabelsMode,
mainWinViewBW = post . EventTimelineShowBW
}
timelineWin <- timelineViewNew builder TimelineViewActions {
timelineViewSelectionChanged = post . EventCursorChangedSelection
}
eventsView <- eventsViewNew builder EventsViewActions {
eventsViewCursorChanged = post . EventCursorChangedIndex
}
startupView <- startupInfoViewNew builder
summaryView <- summaryViewNew builder
histogramView <- histogramViewNew builder
traceView <- traceViewNew builder TraceViewActions {
traceViewTracesChanged = post . EventTracesChanged
}
bookmarkView <- bookmarkViewNew builder BookmarkViewActions {
bookmarkViewAddBookmark = post EventBookmarkAdd,
bookmarkViewRemoveBookmark = post . EventBookmarkRemove,
bookmarkViewGotoBookmark = \ts -> do
post (EventCursorChangedSelection (PointSelection ts))
post EventTimelineJumpCursor,
bookmarkViewEditLabel = \n v -> post (EventBookmarkEdit n v)
}
keyView <- keyViewNew builder
concCtl <- ConcurrencyControl.start
return UIEnv{..}
-------------------------------------------------------------------------------
data LoopDone = LoopDone
eventLoop :: UIEnv -> EventlogState -> IO ()
eventLoop uienv@UIEnv{..} eventlogState = do
event <- getEvent eventQueue
next <- dispatch event eventlogState
#if __GLASGOW_HASKELL__ <= 612
-- workaround for a wierd exception handling bug in ghc-6.12
`catch` \e -> throwIO (e :: SomeException)
#endif
case next of
Left LoopDone -> return ()
Right eventlogState' -> eventLoop uienv eventlogState'
where
dispatch :: Event -> EventlogState -> IO (Either LoopDone EventlogState)
dispatch EventQuit _ = return (Left LoopDone)
dispatch EventOpenDialog _ = do
openFileDialog mainWin $ \filename ->
post (EventFileLoad filename)
continue
dispatch (EventFileLoad filename) _ = do
async "loading the eventlog" $
loadEvents (Just filename) (registerEventsFromFile filename)
--TODO: set state to be empty during loading
continue
dispatch (EventTestLoad testname) _ = do
async "loading the test eventlog" $
loadEvents Nothing (registerEventsFromTrace testname)
--TODO: set state to be empty during loading
continue
dispatch EventFileReload EventlogLoaded{mfilename = Just filename} = do
async "reloading the eventlog" $
loadEvents (Just filename) (registerEventsFromFile filename)
--TODO: set state to be empty during loading
continue
dispatch EventFileReload EventlogLoaded{mfilename = Nothing} =
continue
-- dispatch EventClearState _
dispatch (EventSetState hecs mfilename name nevents timespan) _ =
-- We have to draw this ASAP, before the user manages to move
-- the mouse away from the window, or the window is left
-- in a partially drawn state.
ConcurrencyControl.fullSpeed concCtl $ do
MainWindow.setFileLoaded mainWin (Just name)
MainWindow.setStatusMessage mainWin $
printf "%s (%d events, %.3fs)" name nevents timespan
let mevents = Just $ hecEventArray hecs
eventsViewSetEvents eventsView mevents
startupInfoViewSetEvents startupView mevents
summaryViewSetEvents summaryView mevents
histogramViewSetHECs histogramView (Just hecs)
traceViewSetHECs traceView hecs
traces' <- traceViewGetTraces traceView
timelineWindowSetHECs timelineWin (Just hecs)
timelineWindowSetTraces timelineWin traces'
-- We set user 'traceMarker' events as initial bookmarks.
let usrMarkers = extractUserMarkers hecs
bookmarkViewClear bookmarkView
sequence_ [ bookmarkViewAdd bookmarkView ts label
| (ts, label) <- usrMarkers ]
timelineWindowSetBookmarks timelineWin (map fst usrMarkers)
if nevents == 0
then continueWith NoEventlogLoaded
else continueWith EventlogLoaded
{ mfilename = mfilename
, hecs = hecs
, selection = PointSelection 0
, cursorPos = 0
}
dispatch EventExportDialog
EventlogLoaded {mfilename} = do
exportFileDialog mainWin (fromMaybe "" mfilename) $ \filename' format ->
post (EventFileExport filename' format)
continue
dispatch (EventFileExport filename format)
EventlogLoaded {hecs} = do
viewParams <- timelineGetViewParameters timelineWin
let viewParams' = viewParams {
detail = 1,
bwMode = False,
labelsMode = False
}
let yScaleArea = timelineGetYScaleArea timelineWin
case format of
FormatPDF ->
saveAsPDF filename hecs viewParams' yScaleArea
FormatPNG ->
saveAsPNG filename hecs viewParams' yScaleArea
continue
dispatch EventLaunchWebsite _ = do
GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope"
continue
dispatch EventLaunchTutorial _ = do
GtkExtras.launchProgramForURI "http://www.haskell.org/haskellwiki/ThreadScope_Tour"
continue
dispatch EventAboutDialog _ = do
aboutDialog mainWin
continue
dispatch (EventShowSidebar visible) _ = do
MainWindow.sidebarSetVisibility mainWin visible
continue
dispatch (EventShowEvents visible) _ = do
MainWindow.eventsSetVisibility mainWin visible
continue
dispatch EventTimelineJumpStart _ = do
timelineScrollToBeginning timelineWin
eventsViewScrollToLine eventsView 0
continue
dispatch EventTimelineJumpEnd EventlogLoaded{hecs} = do
timelineScrollToEnd timelineWin
let (_,end) = bounds (hecEventArray hecs)
eventsViewScrollToLine eventsView end
continue
dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do
timelineCentreOnCursor timelineWin --TODO: pass selection here
eventsViewScrollToLine eventsView cursorPos
continue
dispatch EventTimelineScrollLeft _ = do
timelineScrollLeft timelineWin
continue
dispatch EventTimelineScrollRight _ = do
timelineScrollRight timelineWin
continue
dispatch EventTimelineZoomIn _ = do
timelineZoomIn timelineWin
continue
dispatch EventTimelineZoomOut _ = do
timelineZoomOut timelineWin
continue
dispatch EventTimelineZoomToFit _ = do
timelineZoomToFit timelineWin
continue
dispatch (EventTimelineLabelsMode labelsMode) _ = do
timelineSetLabelsMode timelineWin labelsMode
continue
dispatch (EventTimelineShowBW showBW) _ = do
timelineSetBWMode timelineWin showBW
continue
dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do
let cursorTs' = eventIndexToTimestamp hecs cursorPos'
selection' = PointSelection cursorTs'
mselection <- timelineSetSelection timelineWin selection'
setSelection cursorPos' Nothing mselection
dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs'))
EventlogLoaded{hecs} = do
let cursorPos' = timestampToEventIndex hecs cursorTs'
mselection <- timelineSetSelection timelineWin selection'
setSelection cursorPos' Nothing mselection
dispatch (EventCursorChangedSelection selection'@(RangeSelection start end))
EventlogLoaded{hecs} = do
let cursorPos' = timestampToEventIndex hecs start
mrange = Just (cursorPos', timestampToEventIndex hecs end)
mselection <- timelineSetSelection timelineWin selection'
setSelection cursorPos' mrange mselection
dispatch (EventTracesChanged traces) _ = do
timelineWindowSetTraces timelineWin traces
continue
dispatch EventBookmarkAdd EventlogLoaded{selection} = do
case selection of
PointSelection a -> bookmarkViewAdd bookmarkView a ""
RangeSelection a b -> do bookmarkViewAdd bookmarkView a ""
bookmarkViewAdd bookmarkView b ""
--TODO: should have a way to add/set a single bookmark for the timeline
-- rather than this hack where we ask the bookmark view for the whole lot.
ts <- bookmarkViewGet bookmarkView
timelineWindowSetBookmarks timelineWin (map fst ts)
continue
dispatch (EventBookmarkRemove n) _ = do
bookmarkViewRemove bookmarkView n
--TODO: should have a way to add/set a single bookmark for the timeline
-- rather than this hack where we ask the bookmark view for the whole lot.
ts <- bookmarkViewGet bookmarkView
timelineWindowSetBookmarks timelineWin (map fst ts)
continue
dispatch (EventBookmarkEdit n v) _ = do
bookmarkViewSetLabel bookmarkView n v
continue
dispatch (EventUserError doing exception) _ = do
let headline = "There was a problem " ++ doing ++ "."
explanation = show exception
errorMessageDialog mainWin headline explanation
continue
dispatch _ NoEventlogLoaded = continue
loadEvents mfilename registerEvents = do
ConcurrencyControl.fullSpeed concCtl $
ProgressView.withProgress mainWin $ \progress -> do
(hecs, name, nevents, timespan) <- registerEvents progress
-- This is a desperate hack to avoid the "segfault on reload" bug
-- http://trac.haskell.org/ThreadScope/ticket/1
-- It should be enough to let other threads finish and so avoid
-- re-entering gtk C code (see ticket for the dirty details).
--
-- Unfortunately it halts drawing of the loaded events if the user
-- manages to move the mouse away from the window during the delay.
-- threadDelay 100000 -- 1/10th of a second
post (EventSetState hecs mfilename name nevents timespan)
return ()
async doing action =
forkIO (action `catch` \e -> post (EventUserError doing e))
setSelection cursorPos' _ (Just selection'@(PointSelection _)) = do
eventsViewSetCursor eventsView cursorPos' Nothing
histogramViewSetInterval histogramView Nothing
summaryViewSetInterval summaryView Nothing
continueWith eventlogState {
selection = selection',
cursorPos = cursorPos'
}
setSelection cursorPos' mrange (Just selection'@(RangeSelection start end)) = do
eventsViewSetCursor eventsView cursorPos' mrange
histogramViewSetInterval histogramView (Just (start, end))
summaryViewSetInterval summaryView (Just (start, end))
continueWith eventlogState {
selection = selection',
cursorPos = cursorPos'
}
setSelection _ _ Nothing = continue
post = postEvent eventQueue
continue = continueWith eventlogState
continueWith = return . Right
-------------------------------------------------------------------------------
runGUI :: Maybe (Either FilePath String) -> IO ()
runGUI initialTrace = do
Gtk.initGUI
App.initApp
uiEnv <- constructUI
let post = postEvent (eventQueue uiEnv)
case initialTrace of
Nothing -> return ()
Just (Left filename) -> post (EventFileLoad filename)
Just (Right traceName) -> post (EventTestLoad traceName)
doneVar <- newEmptyMVar
forkIO $ do
res <- try $ eventLoop uiEnv NoEventlogLoaded
Gtk.mainQuit
putMVar doneVar (res :: Either SomeException ())
#ifndef mingw32_HOST_OS
installHandler sigINT (Catch $ post EventQuit) Nothing
#endif
-- Enter Gtk+ main event loop.
Gtk.mainGUI
-- Wait for child event loop to terminate
-- This lets us wait for any exceptions.
either throwIO return =<< takeMVar doneVar
================================================
FILE: GUI/MainWindow.hs
================================================
{-# LANGUAGE TemplateHaskell #-}
module GUI.MainWindow (
MainWindow,
mainWindowNew,
MainWindowActions(..),
setFileLoaded,
setStatusMessage,
sidebarSetVisibility,
eventsSetVisibility,
) where
import Graphics.UI.Gtk as Gtk
import qualified System.Glib.GObject as Glib
import GUI.DataFiles (loadLogo)
-------------------------------------------------------------------------------
data MainWindow = MainWindow {
mainWindow :: Window,
sidebarBox,
eventsBox :: Widget,
statusBar :: Statusbar,
statusBarCxt :: ContextId
}
instance Glib.GObjectClass MainWindow where
toGObject = toGObject . mainWindow
unsafeCastGObject = error "cannot downcast to MainView type"
instance Gtk.WidgetClass MainWindow
instance Gtk.ContainerClass MainWindow
instance Gtk.BinClass MainWindow
instance Gtk.WindowClass MainWindow
data MainWindowActions = MainWindowActions {
-- Menu actions
mainWinOpen :: IO (),
mainWinExport :: IO (),
mainWinQuit :: IO (),
mainWinViewSidebar :: Bool -> IO (),
mainWinViewEvents :: Bool -> IO (),
mainWinViewBW :: Bool -> IO (),
mainWinViewReload :: IO (),
mainWinWebsite :: IO (),
mainWinTutorial :: IO (),
mainWinAbout :: IO (),
-- Toolbar actions
mainWinJumpStart :: IO (),
mainWinJumpEnd :: IO (),
mainWinJumpCursor :: IO (),
mainWinJumpZoomIn :: IO (),
mainWinJumpZoomOut :: IO (),
mainWinJumpZoomFit :: IO (),
mainWinScrollLeft :: IO (),
mainWinScrollRight :: IO (),
mainWinDisplayLabels :: Bool -> IO ()
}
-------------------------------------------------------------------------------
setFileLoaded :: MainWindow -> Maybe FilePath -> IO ()
setFileLoaded mainWin Nothing =
set (mainWindow mainWin) [
windowTitle := "ThreadScope"
]
setFileLoaded mainWin (Just file) =
set (mainWindow mainWin) [
windowTitle := file ++ " - ThreadScope"
]
setStatusMessage :: MainWindow -> String -> IO ()
setStatusMessage mainWin msg = do
statusbarPop (statusBar mainWin) (statusBarCxt mainWin)
statusbarPush (statusBar mainWin) (statusBarCxt mainWin) (' ':msg)
return ()
sidebarSetVisibility :: MainWindow -> Bool -> IO ()
sidebarSetVisibility mainWin visible =
set (sidebarBox mainWin) [ widgetVisible := visible ]
eventsSetVisibility :: MainWindow -> Bool -> IO ()
eventsSetVisibility mainWin visible =
set (eventsBox mainWin) [ widgetVisible := visible ]
-------------------------------------------------------------------------------
mainWindowNew :: Builder -> MainWindowActions -> IO MainWindow
mainWindowNew builder actions = do
let getWidget cast name = builderGetObject builder cast name
mainWindow <- getWidget castToWindow "main_window"
statusBar <- getWidget castToStatusbar "statusbar"
sidebarBox <- getWidget castToWidget "sidebar"
eventsBox <- getWidget castToWidget "eventsbox"
bwToggle <- getWidget castToCheckMenuItem "black_and_white"
labModeToggle <- getWidget castToCheckMenuItem "view_labels_mode"
sidebarToggle <- getWidget castToCheckMenuItem "view_sidebar"
eventsToggle <- getWidget castToCheckMenuItem "view_events"
openMenuItem <- getWidget castToMenuItem "openMenuItem"
exportMenuItem <- getWidget castToMenuItem "exportMenuItem"
reloadMenuItem <- getWidget castToMenuItem "view_reload"
quitMenuItem <- getWidget castToMenuItem "quitMenuItem"
websiteMenuItem <- getWidget castToMenuItem "websiteMenuItem"
tutorialMenuItem <- getWidget castToMenuItem "tutorialMenuItem"
aboutMenuItem <- getWidget castToMenuItem "aboutMenuItem"
firstMenuItem <- getWidget castToMenuItem "move_first"
centreMenuItem <- getWidget castToMenuItem "move_centre"
lastMenuItem <- getWidget castToMenuItem "move_last"
zoomInMenuItem <- getWidget castToMenuItem "move_zoomin"
zoomOutMenuItem <- getWidget castToMenuItem "move_zoomout"
zoomFitMenuItem <- getWidget castToMenuItem "move_zoomfit"
openButton <- getWidget castToToolButton "cpus_open"
firstButton <- getWidget castToToolButton "cpus_first"
centreButton <- getWidget castToToolButton "cpus_centre"
lastButton <- getWidget castToToolButton "cpus_last"
zoomInButton <- getWidget castToToolButton "cpus_zoomin"
zoomOutButton <- getWidget castToToolButton "cpus_zoomout"
zoomFitButton <- getWidget castToToolButton "cpus_zoomfit"
------------------------------------------------------------------------
-- Show everything
widgetShowAll mainWindow
------------------------------------------------------------------------
logo <- $loadLogo
set mainWindow [ windowIcon := logo ]
------------------------------------------------------------------------
-- Status bar functionality
statusBarCxt <- statusbarGetContextId statusBar "file"
statusbarPush statusBar statusBarCxt "No eventlog loaded."
------------------------------------------------------------------------
-- Bind all the events
-- Menus
on openMenuItem menuItemActivate $ mainWinOpen actions
on exportMenuItem menuItemActivate $ mainWinExport actions
on quitMenuItem menuItemActivate $ mainWinQuit actions
on mainWindow objectDestroy $ mainWinQuit actions
on sidebarToggle checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle
>>= mainWinViewSidebar actions
on eventsToggle checkMenuItemToggled $ checkMenuItemGetActive eventsToggle
>>= mainWinViewEvents actions
on bwToggle checkMenuItemToggled $ checkMenuItemGetActive bwToggle
>>= mainWinViewBW actions
on labModeToggle checkMenuItemToggled $ checkMenuItemGetActive labModeToggle
>>= mainWinDisplayLabels actions
on reloadMenuItem menuItemActivate $ mainWinViewReload actions
on websiteMenuItem menuItemActivate $ mainWinWebsite actions
on tutorialMenuItem menuItemActivate $ mainWinTutorial actions
on aboutMenuItem menuItemActivate $ mainWinAbout actions
on firstMenuItem menuItemActivate $ mainWinJumpStart actions
on centreMenuItem menuItemActivate $ mainWinJumpCursor actions
on lastMenuItem menuItemActivate $ mainWinJumpEnd actions
on zoomInMenuItem menuItemActivate $ mainWinJumpZoomIn actions
on zoomOutMenuItem menuItemActivate $ mainWinJumpZoomOut actions
on zoomFitMenuItem menuItemActivate $ mainWinJumpZoomFit actions
-- Toolbar
onToolButtonClicked openButton $ mainWinOpen actions
onToolButtonClicked firstButton $ mainWinJumpStart actions
onToolButtonClicked centreButton $ mainWinJumpCursor actions
onToolButtonClicked lastButton $ mainWinJumpEnd actions
onToolButtonClicked zoomInButton $ mainWinJumpZoomIn actions
onToolButtonClicked zoomOutButton $ mainWinJumpZoomOut actions
onToolButtonClicked zoomFitButton $ mainWinJumpZoomFit actions
return MainWindow {..}
================================================
FILE: GUI/ProgressView.hs
================================================
{-# LANGUAGE DeriveDataTypeable #-}
module GUI.ProgressView (
ProgressView,
withProgress,
setText,
setTitle,
setProgress,
startPulse,
) where
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk as Gtk
import GUI.GtkExtras
import qualified Control.Concurrent as Concurrent
import Control.Exception
import Data.Typeable
import Control.Monad.Trans
data ProgressView = ProgressView {
progressWindow :: Gtk.Window,
progressLabel :: Gtk.Label,
progressBar :: Gtk.ProgressBar
}
-- | Perform a long-running operation and display a progress window. The
-- operation has access to the progress window and it is expected to update it
-- using 'setText' and 'setProgress'
--
-- The user may cancel the operation at any time.
--
withProgress :: WindowClass win => win -> (ProgressView -> IO a) -> IO (Maybe a)
withProgress parent action = do
self <- Concurrent.myThreadId
let cancel = throwTo self OperationInterrupted
bracket (new parent cancel) close $ \progress ->
fmap Just (action progress)
`catch` \OperationInterrupted -> return Nothing
data OperationInterrupted = OperationInterrupted
deriving (Typeable, Show)
instance Exception OperationInterrupted
setText :: ProgressView -> String -> IO ()
setText view msg =
set (progressBar view) [
progressBarText := msg
]
setTitle :: ProgressView -> String -> IO ()
setTitle view msg = do
set (progressWindow view) [ windowTitle := msg ]
set (progressLabel view) [ labelLabel := "<b>" ++ msg ++ "</b>" ]
startPulse :: ProgressView -> IO (IO ())
startPulse view = do
let pulse = do
progressBarPulse (progressBar view)
Concurrent.threadDelay 200000
pulse
thread <- Concurrent.forkIO $
pulse `catch` \OperationInterrupted -> return ()
let stop = throwTo thread OperationInterrupted
waitGUI
return stop
setProgress :: ProgressView -> Int -> Int -> IO ()
setProgress view total current = do
let frac = fromIntegral current / fromIntegral total
set (progressBar view) [ progressBarFraction := frac ]
waitGUI
close :: ProgressView -> IO ()
close view = widgetDestroy (progressWindow view)
new :: WindowClass win => win -> IO () -> IO ProgressView
new parent cancelAction = do
win <- windowNew
set win [
containerBorderWidth := 10,
windowTitle := "",
windowTransientFor := toWindow parent,
windowModal := True,
windowWindowPosition := WinPosCenterOnParent,
windowDefaultWidth := 400,
windowSkipTaskbarHint := True
]
progText <- labelNew (Nothing :: Maybe String)
set progText [
miscXalign := 0,
labelUseMarkup := True
]
progress <- progressBarNew
cancel <- buttonNewFromStock stockCancel
cancel `on` buttonActivated $ (widgetDestroy win >> cancelAction)
win `on` destroyEvent $ lift cancelAction >> return True
on win keyPressEvent $ do
keyVal <- eventKeyVal
case keyVal of
0xff1b -> liftIO $ cancelAction >> return True
_ -> return False
vbox <- vBoxNew False 20
hbox <- hBoxNew False 0
boxPackStart vbox progText PackRepel 10
boxPackStart vbox progress PackGrow 5
boxPackStart vbox hbox PackNatural 5
boxPackEnd hbox cancel PackNatural 0
containerAdd win vbox
widgetShowAll win
return ProgressView {
progressWindow = win,
progressLabel = progText,
progressBar = progress
}
================================================
FILE: GUI/SaveAs.hs
================================================
module GUI.SaveAs (saveAsPDF, saveAsPNG) where
-- Imports for ThreadScope
import GUI.Timeline.Render (renderTraces, renderYScaleArea)
import GUI.Timeline.Render.Constants
import GUI.Timeline.Ticks (renderXScaleArea)
import GUI.Types
import Events.HECs
-- Imports for GTK
import Graphics.UI.Gtk hiding (rectangle)
import Graphics.Rendering.Cairo
( Render
, Operator(..)
, Format(..)
, rectangle
, getOperator
, setOperator
, fill
, translate
, liftIO
, withPDFSurface
, renderWith
, withImageSurface
, surfaceWriteToPNG
)
saveAs :: HECs -> ViewParameters -> Double -> DrawingArea
-> (Int, Int, Render ())
saveAs hecs params'@ViewParameters{xScaleAreaHeight, width,
height = oldHeight {-, histogramHeight-}}
yScaleAreaWidth yScaleArea =
let histTotalHeight = histXScaleHeight -- + histogramHeight
params@ViewParameters{height} =
params'{ viewTraces = viewTraces params' -- ++ [TraceHistogram]
, height = oldHeight + histTotalHeight + tracePad
}
w = ceiling yScaleAreaWidth + width
h = xScaleAreaHeight + height
drawTraces = renderTraces params hecs (Rectangle 0 0 width height)
drawXScale = renderXScaleArea params hecs
drawYScale = renderYScaleArea params hecs yScaleArea
-- Functions renderTraces and renderXScaleArea draw to the left of 0
-- which is not seen in the normal mode, but would be seen in export,
-- so it has to be cleared before renderYScaleArea is written on top:
clearLeftArea = do
rectangle 0 0 yScaleAreaWidth (fromIntegral h)
op <- getOperator
setOperator OperatorClear
fill
setOperator op
drawAll = do
translate yScaleAreaWidth (fromIntegral xScaleAreaHeight)
drawTraces
translate 0 (- fromIntegral xScaleAreaHeight)
drawXScale
translate (-yScaleAreaWidth) 0
clearLeftArea
translate 0 (fromIntegral xScaleAreaHeight)
drawYScale
in (w, h, drawAll)
saveAsPDF :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()
saveAsPDF filename hecs params yScaleArea = do
Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea
let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea
withPDFSurface filename (fromIntegral w') (fromIntegral h') $ \surface ->
renderWith surface drawAll
saveAsPNG :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()
saveAsPNG filename hecs params yScaleArea = do
Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea
let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea
withImageSurface FormatARGB32 w' h' $ \surface -> do
renderWith surface drawAll
surfaceWriteToPNG surface filename
================================================
FILE: GUI/StartupInfoView.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module GUI.StartupInfoView (
StartupInfoView,
startupInfoViewNew,
startupInfoViewSetEvents,
) where
import GHC.RTS.Events
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import Data.Array
import Data.List
import Data.Maybe
import Data.Time
import Data.Time.Clock.POSIX
import Data.Text (Text)
import qualified Data.Text as T
-------------------------------------------------------------------------------
data StartupInfoView = StartupInfoView
{ labelProgName :: Label
, storeProgArgs :: ListStore Text
, storeProgEnv :: ListStore (Text, Text)
, labelProgStartTime :: Label
, labelProgRtsId :: Label
}
data StartupInfoState
= StartupInfoEmpty
| StartupInfoLoaded
{ progName :: Maybe Text
, progArgs :: Maybe [Text]
, progEnv :: Maybe [(Text, Text)]
, progStartTime :: Maybe UTCTime
, progRtsId :: Maybe Text
}
-------------------------------------------------------------------------------
startupInfoViewNew :: Builder -> IO StartupInfoView
startupInfoViewNew builder = do
let getWidget cast = builderGetObject builder cast
labelProgName <- getWidget castToLabel ("labelProgName" :: Text)
treeviewProgArgs <- getWidget castToTreeView ("treeviewProgArguments" :: Text)
treeviewProgEnv <- getWidget castToTreeView ("treeviewProgEnvironment" :: Text)
labelProgStartTime <- getWidget castToLabel ("labelProgStartTime" :: Text)
labelProgRtsId <- getWidget castToLabel ("labelProgRtsIdentifier" :: Text)
storeProgArgs <- listStoreNew []
columnArgs <- treeViewColumnNew
cellArgs <- cellRendererTextNew
treeViewColumnPackStart columnArgs cellArgs True
treeViewAppendColumn treeviewProgArgs columnArgs
Compat.treeViewSetModel treeviewProgArgs (Just storeProgArgs)
set cellArgs [ cellTextEditable := True ]
cellLayoutSetAttributes columnArgs cellArgs storeProgArgs $ \arg ->
[ cellText := arg ]
storeProgEnv <- listStoreNew []
columnVar <- treeViewColumnNew
cellVar <- cellRendererTextNew
columnValue <- treeViewColumnNew
cellValue <- cellRendererTextNew
treeViewColumnPackStart columnVar cellVar False
treeViewColumnPackStart columnValue cellValue True
treeViewAppendColumn treeviewProgEnv columnVar
treeViewAppendColumn treeviewProgEnv columnValue
Compat.treeViewSetModel treeviewProgEnv (Just storeProgEnv)
cellLayoutSetAttributes columnVar cellVar storeProgEnv $ \(var,_) ->
[ cellText := var ]
set cellValue [ cellTextEditable := True ]
cellLayoutSetAttributes columnValue cellValue storeProgEnv $ \(_,value) ->
[ cellText := value ]
let startupInfoView = StartupInfoView{..}
return startupInfoView
-------------------------------------------------------------------------------
startupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int Event) -> IO ()
startupInfoViewSetEvents view mevents =
updateStartupInfo view (maybe StartupInfoEmpty processEvents mevents)
--TODO: none of this handles the possibility of an eventlog containing multiple
-- OS processes. Note that the capset arg is ignored in the events below.
processEvents :: Array Int Event -> StartupInfoState
processEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing)
. take 1000
. elems
where
accum info (Event _ (ProgramArgs _ (name:args)) _) =
info {
progName = Just name,
progArgs = Just args
}
accum info (Event _ (ProgramEnv _ env) _) =
info { progEnv = Just (sort (parseEnv env)) }
accum info (Event _ (RtsIdentifier _ rtsid) _) =
info { progRtsId = Just rtsid }
accum info (Event timestamp (WallClockTime _ sec nsec) _) =
-- WallClockTime records the wall clock time of *this* event
-- which occurs some time after startup, so we can just subtract
-- the timestamp since that is the relative time since startup.
let wallTimePosix :: NominalDiffTime
wallTimePosix = fromIntegral sec
+ (fromIntegral nsec / nanoseconds)
- (fromIntegral timestamp / nanoseconds)
nanoseconds = 1000000000
wallTimeUTC = posixSecondsToUTCTime wallTimePosix
in info { progStartTime = Just wallTimeUTC }
accum info _ = info
-- convert ["foo=bar", ...] to [("foo", "bar"), ...]
parseEnv env = [ (var, value) | (var, T.drop 1 -> value) <- map (T.span (/='=')) env ]
updateStartupInfo :: StartupInfoView -> StartupInfoState -> IO ()
updateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do
set labelProgName [ labelText := fromMaybe "(unknown)" progName ]
set labelProgStartTime [ labelText := maybe "(unknown)" show progStartTime ]
set labelProgRtsId [ labelText := fromMaybe "(unknown)" progRtsId ]
listStoreClear storeProgArgs
mapM_ (listStoreAppend storeProgArgs) (fromMaybe [] progArgs)
listStoreClear storeProgEnv
mapM_ (listStoreAppend storeProgEnv) (fromMaybe [] progEnv)
updateStartupInfo StartupInfoView{..} StartupInfoEmpty = do
set labelProgName [ labelText := ("" :: Text) ]
set labelProgStartTime [ labelText := ("" :: Text) ]
set labelProgRtsId [ labelText := ("" :: Text) ]
listStoreClear storeProgArgs
listStoreClear storeProgEnv
================================================
FILE: GUI/SummaryView.hs
================================================
module GUI.SummaryView (
SummaryView,
summaryViewNew,
summaryViewSetEvents,
summaryViewSetInterval,
) where
import GHC.RTS.Events
import GUI.Types
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import Control.Exception (assert)
import Control.Monad
import Data.Array
import qualified Data.IntMap as IM
import Data.IORef
import Data.List as L
import Data.Maybe
import Data.Word (Word64)
import Numeric (showFFloat)
import Text.Printf
------------------------------------------------------------------------------
type Events = Array Int Event
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"
Compat.treeViewSetModel treeviewGcStats (Just storeGcStats)
let addGcColumn = addColumn treeviewGcStats storeGcStats
addGcColumn "Generation" $ \(GcStatsEntry gen _ _ _ _ _) ->
[ cellText := if gen == -1 then "GC Total" else "Gen " ++ show gen ]
addGcColumn "Collections" $ \(GcStatsEntry _ colls _ _ _ _) ->
[ cellText := show colls ]
addGcColumn "Par collections" $ \(GcStatsEntry _ _ pcolls _ _ _) ->
[ cellText := show pcolls ]
addGcColumn "Elapsed time" $ \(GcStatsEntry _ _ _ time _ _) ->
[ cellText := (printf "%5.2fs" (timeToSecondsDbl time) :: String) ]
addGcColumn "Avg pause" $ \(GcStatsEntry _ _ _ _ avgpause _) ->
[ cellText := (printf "%3.4fs" avgpause :: String) ]
addGcColumn "Max pause" $ \(GcStatsEntry _ _ _ _ _ maxpause) ->
[ cellText := (printf "%3.4fs" maxpause :: String) ]
treeviewSparkStats <- getWidget castToTreeView "treeviewSparkStats"
Compat.treeViewSetModel treeviewSparkStats (Just 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 "GCed" $ \(_, 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 Event) -> 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 , showTimeWithUnit timeTotal)
, (labelTimeMutator , showTimeWithUnit timeMutator)
, (labelTimeGC , showTimeWithUnit timeGC)
, (labelTimeProductivity, showFFloat (Just 1) (timeProductivity * 100) "% of mutator vs total")
]
setHeapStats :: SummaryView -> HeapStats -> IO ()
setHeapStats SummaryView{..} HeapStats{..} = do
setHeapStatLabels labelHeapMaxSize heapMaxSize "" ""
setHeapStatLabels labelHeapMaxResidency heapMaxResidency "" ""
setHeapStatLabels labelHeapAllocTotal heapTotalAlloc "" ""
setHeapStatLabels labelHeapAllocRate heapAllocRate "/s" " per second (of mutator time)"
setHeapStatLabels labelHeapMaxSlop heapMaxSlop "" ""
setHeapStatLabels labelGcCopied heapCopiedDuringGc "" ""
where
setHeapStatLabels labels stat unitSuffix unitSuffixLong =
let texts = case stat of
Nothing -> ("N/A", "", "", "")
Just b -> ( formatBytesInUnit b u, formatUnit u ++ unitSuffix
, formatBytes b, "bytes" ++ unitSuffixLong)
where u = getByteUnit b
in setLabels labels texts
setLabels (short,shortunit,long,longunit) (short', shortunit', long', longunit') = do
mapM_ (\(label, text) -> set label [ labelText := text ])
[ (short, short'), (shortunit, shortunit')
, (long, long'), (longunit, longunit') ]
setGcStats :: SummaryView -> GcStats -> IO ()
setGcStats SummaryView{..} GcStats{..} = do
let balText = maybe "N/A"
(printf "%.2f%% (serial 0%%, perfect 100%%)")
gcParWorkBalance
set labelGcParWorkBalance [ labelText := balText ]
listStoreClear storeGcStats
mapM_ (listStoreAppend storeGcStats) (gcTotalStats:gcGenStats)
setSparkStats :: SummaryView -> SparkStats -> IO ()
setSparkStats SummaryView{..} SparkStats{..} = do
listStoreClear storeSparkStats
mapM_ (listStoreAppend storeSparkStats) ((-1,totalSparkStats):capSparkStats)
data ByteUnit = TiB | GiB | MiB | KiB | B deriving Show
byteUnitVal :: ByteUnit -> Word64
byteUnitVal TiB = 2^40
byteUnitVal GiB = 2^30
byteUnitVal MiB = 2^20
byteUnitVal KiB = 2^10
byteUnitVal B = 1
getByteUnit :: Word64 -> ByteUnit
getByteUnit b
| b >= 2^40 = TiB
| b >= 2^30 = GiB
| b >= 2^20 = MiB
| b >= 2^10 = KiB
| otherwise = B
formatBytesInUnit :: Word64 -> ByteUnit -> String
formatBytesInUnit n u =
formatFixed (fromIntegral n / fromIntegral (byteUnitVal u))
where
formatFixed x = showFFloat (Just 1) x ""
formatUnit :: ByteUnit -> String
formatUnit = show
formatBytes :: Word64 -> String
formatBytes b = ppWithCommas b
ppWithCommas :: Word64 -> String
ppWithCommas =
let spl [] = []
spl l = let (c3, cs) = L.splitAt 3 l
in c3 : spl cs
in L.reverse . L.intercalate "," . spl . L.reverse . show
setSummaryStatsEmpty :: SummaryView -> IO ()
setSummaryStatsEmpty SummaryView{..} = do
mapM_ (\label -> set label [ labelText := ""
, widgetTooltipText
:= (Nothing :: Maybe String) ]) $
[ labelTimeTotal, labelTimeMutator
, labelTimeGC, labelTimeProductivity ] ++
[ w
| (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop, labelGcCopied ]
, w <- [ a,b,c,d] ]
listStoreClear storeGcStats
listStoreClear storeSparkStats
setHeapStatsAvailable :: SummaryView -> Bool -> IO ()
setHeapStatsAvailable SummaryView{..} available
| available = do
forM_ unavailableWidgets $ \widget ->
set widget [ widgetTooltipText := (Nothing :: Maybe String)
, widgetSensitive := True ]
| otherwise = do
forM_ allLabels $ \label -> set label [ labelText := "" ]
listStoreClear storeGcStats
forM_ unavailableLabels $ \label ->
set label [ labelText := "(unavailable)" ]
forM_ unavailableWidgets $ \widget ->
set widget [ widgetTooltipText := Just msgInfoUnavailable, widgetSensitive := False ]
where
allLabels =
[ labelTimeMutator, labelTimeGC
, labelTimeProductivity, labelGcParWorkBalance ] ++
[ w | (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop, labelGcCopied ]
, w <- [ a,b,c,d] ]
unavailableLabels =
[ labelTimeMutator, labelTimeGC
, labelTimeProductivity, labelGcParWorkBalance
, case labelGcCopied of (w,_,_,_) -> w ] ++
[ c | (_,_,c,_) <- [ labelHeapMaxSize, labelHeapMaxResidency
, labelHeapAllocTotal, labelHeapAllocRate
, labelHeapMaxSlop ] ]
unavailableWidgets = [ toWidget labelTimeMutator, toWidget labelTimeGC
, toWidget labelTimeProductivity
, tableHeap, tableGc ]
msgInfoUnavailable = "This eventlog does not contain heap or GC information."
------------------------------------------------------------------------------
-- Calculating the stats we want to display
--
data SummaryStats = SummaryStats {
summTimeStats :: TimeStats,
summHeapStats :: HeapStats,
summGcStats :: GcStats,
summSparkStats :: SparkStats
}
data TimeStats = TimeStats {
timeTotal :: !Word64, -- we really should have a better type for elapsed time
timeGC :: !Word64,
timeMutator :: !Word64,
timeProductivity :: !Double
}
data HeapStats = HeapStats {
heapMaxSize :: Maybe Word64,
heapMaxResidency :: Maybe Word64,
heapMaxSlop :: Maybe Word64,
heapTotalAlloc :: Maybe Word64,
heapAllocRate :: Maybe Word64,
heapCopiedDuringGc :: Maybe Word64
}
data GcStats = GcStats {
gcNumThreads :: !Int,
gcParWorkBalance :: !(Maybe Double),
gcGenStats :: [GcStatsEntry],
gcTotalStats :: !GcStatsEntry
}
data GcStatsEntry = GcStatsEntry !Int !Int !Int !Word64 !Double !Double
data SparkStats = SparkStats {
capSparkStats :: [(Cap, SparkCounts)],
totalSparkStats :: !SparkCounts
}
data SparkCounts = SparkCounts !Word64 !Word64 !Word64 !Word64 !Word64 !Word64
-- | Take the events, and optionally some sub-range, and generate the summary
-- stats for that range.
--
-- We take a two-step approach:
-- * a single pass over the events, accumulating into an intermediate
-- 'StatsAccum' record,
-- * then look at that 'StatsAccum' record and construct the various final
-- stats that we want to present.
--
summaryStats :: Array Int Event -> Maybe Interval -> SummaryStats
summaryStats events minterval =
SummaryStats {
summHeapStats = hs,
summGcStats = gs,
summSparkStats = ss,
summTimeStats = ts
}
where
!statsAccum = accumStats events minterval
gs = gcStats statsAccum
ss = sparkStats statsAccum
ts = timeStats events minterval gs
hs = heapStats statsAccum ts
-- | Linearly accumulate the stats from the events array,
-- either the full thing or some sub-range.
accumStats :: Array Int Event -> 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 Event -> 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 (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 Event -> 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, evTime (events ! ub))
where
(_lb, ub) = bounds events
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
------------------------------------------------------------------------------
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
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
}
-- Fail only when assertions are turned on.
errorAs :: String -> a -> a
errorAs msg a = assert (error msg) a
accumEvent :: StatsAccum -> Event -> StatsAccum
accumEvent !statsAccum 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 interval.
-- 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 !sd@StatsAccum{..} Event{evTime, evSpec, evCap} =
let cap = fromMaybe (error "Error: missing cap; use 'ghc-events validate' to verify the eventlog") evCap
capGC = IM.findWithDefault (defaultGC evTime) cap dGCTable
in case evSpec of
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 = evTime
}
-- 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 overwriting 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 -> errorAs "scanEvents: GlobalSyncGC ModeInit" dGC
ModeSync{} -> errorAs "scanEvents: GlobalSyncGC ModeSync" dGC
ModeGHC{} -> -- error "scanEvents: GlobalSyncGC ModeGHC"
dGC -- workaround for #46
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 -> errorAs "scanEvents: GCStatsGHC ModeInit" dGC
ModeGHC{} -> -- error "scanEvents: GCStatsGHC ModeGHC"
dGC -- workaround for #46
-- The last two cases are copied from case @GlobalSyncGC@
-- to work around low-resolution timestamps (#35).
-- Normally, these states would be impossible here, because
-- @GlobalSyncGC@ would already transition away from these
-- states. But if @GlobalSyncGC@ comes too early, the states
-- can appear here. The computed stats are usually only
-- slightly different than if @GlobalSyncGC@ made the state
-- transitions, because the timestamps of @GCStatsGHC@
-- and @GlobalSyncGC@ are normally only slightly different.
--
-- Cap takes part in the GC (not known if seq or par).
-- Here is the moment where all caps taking place in the GC
-- are identified and we can aggregate all their data
-- at once (currently we just increment a counter for each).
-- The EndGC events can come much later for some caps and at
-- that time other caps are already inside their new GC.
ModeStart ->
dGC { gcMode = ModeSync cap
, gcGenStat =
if capKey == cap
then IM.insert gcGenTot
totGC{ gcAll = gcAll totGC + 1 }
gcGenStat
else gcGenStat
}
-- Cap is not in the GC. Mark it as idle to complete
-- the identification of caps that take part
-- in the current GC. Without overwriting the mode,
-- the cap could be processed later on as if
-- it took part in the GC, giving wrong results.
ModeEnd -> dGC { gcMode = ModeIdle }
EndGC ->
assert (gcMode capGC `notElem` [ModeEnd, ModeIdle]) $
let endedGC = capGC { gcMode = ModeEnd }
duration = evTime - 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 evTime) 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 evTime) dGCMain
mainGenTot = updateMainCap mainCap gcGenTot dgm
newMain = updateMainCap mainCap gen mainGenTot
in sd { dGCTable = IM.insert cap newTime dGCTable
, dGCMain = Just newMain
}
ModeEnd -> errorAs "scanEvents: EndGC ModeEnd" sd
ModeIdle -> errorAs "scanEvents: EndGC ModeIdle"
$ sd { dGCTable = IM.insert cap endedGC dGCTable }
SparkCounters crt dud ovf cnv fiz gcd _rem ->
-- We are guaranteed 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 statsAccum ev
================================================
FILE: GUI/Timeline/Activity.hs
================================================
module GUI.Timeline.Activity (
renderActivity
) where
import GUI.Timeline.Render.Constants
import Events.HECs
import Events.EventTree
import Events.EventDuration
import GUI.Types
import GUI.ViewerColours
import Graphics.Rendering.Cairo
import Control.Monad
import Data.List
-- ToDo:
-- - we average over the slice, but the point is drawn at the beginning
-- of the slice rather than in the middle.
-----------------------------------------------------------------------------
renderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp
-> Render ()
renderActivity ViewParameters{..} hecs start0 end0 = do
let
slice = ceiling (fromIntegral activity_detail * scaleValue)
-- round the start time down, and the end time up, to a slice boundary
start = (start0 `div` slice) * slice
end = ((end0 + slice) `div` slice) * slice
hec_profs = map (actProfile slice start end)
(map (\ (t, _, _) -> t) (hecTrees hecs))
total_prof = map sum (transpose hec_profs)
-- liftIO $ printf "%s\n" (show (map length hec_profs))
-- liftIO $ printf "%s\n" (show (map (take 20) hec_profs))
drawActivity hecs start end slice total_prof
(if not bwMode then runningColour else black)
activity_detail :: Int
activity_detail = 4 -- in pixels
-- for each timeslice, the amount of time spent in the mutator
-- during that period.
actProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp]
actProfile slice start0 end0 t
= {- trace (show flat) $ -} chopped
where
-- do an extra slice at both ends
start = if start0 < slice then start0 else start0 - slice
end = end0 + slice
flat = flatten start t []
chopped0 = chop 0 start flat
chopped | start0 < slice = 0 : chopped0
| otherwise = chopped0
flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree]
flatten _start DurationTreeEmpty rest = rest
flatten start t@(DurationSplit s split e l r _run _) rest
| e <= start = rest
| end <= s = rest
| start >= split = flatten start r rest
| end <= split = flatten start l rest
| e - s > slice = flatten start l $ flatten start r rest
| otherwise = t : rest
flatten _start t@(DurationTreeLeaf _) rest
= t : rest
chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp]
chop sofar start _ts
| start >= end = if sofar > 0 then [sofar] else []
chop sofar start []
= sofar : chop 0 (start+slice) []
chop sofar start (t : ts)
| e <= start
= if sofar /= 0
then error "chop"
else chop sofar start ts
| s >= start + slice
= sofar : chop 0 (start + slice) (t : ts)
| e > start + slice
= (sofar + time_in_this_slice t) : chop 0 (start + slice) (t : ts)
| otherwise
= chop (sofar + time_in_this_slice t) start ts
where
(s, e)
| DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev)
| DurationSplit s _ e _ _ _run _ <- t = (s, e)
mi = min (start + slice) e
ma = max start s
duration = if mi < ma then 0 else mi - ma
time_in_this_slice t = case t of
DurationTreeLeaf ThreadRun{} -> duration
DurationTreeLeaf _ -> 0
DurationSplit _ _ _ _ _ run _ ->
round (fromIntegral (run * duration) / fromIntegral (e-s))
DurationTreeEmpty -> error "time_in_this_slice"
drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp]
-> Color
-> Render ()
drawActivity hecs start end slice ts color = do
case ts of
[] -> return ()
t:ts -> do
-- liftIO $ printf "ts: %s\n" (show (t:ts))
-- liftIO $ printf "off: %s\n" (show (map off (t:ts) :: [Double]))
let dstart = fromIntegral start
dend = fromIntegral end
dslice = fromIntegral slice
dheight = fromIntegral activityGraphHeight
-- funky gradients don't seem to work:
-- withLinearPattern 0 0 0 dheight $ \pattern -> do
-- patternAddColorStopRGB pattern 0 0.8 0.8 0.8
-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0
-- rectangle dstart 0 dend dheight
-- setSource pattern
-- fill
newPath
moveTo (dstart-dslice/2) (off t)
zipWithM_ lineTo (tail [dstart-dslice/2, dstart+dslice/2 ..]) (map off ts)
setSourceRGBAhex black 1.0
setLineWidth 1
strokePreserve
lineTo dend dheight
lineTo dstart dheight
setSourceRGBAhex color 1.0
fill
-- funky gradients don't seem to work:
-- save
-- withLinearPattern 0 0 0 dheight $ \pattern -> do
-- patternAddColorStopRGB pattern 0 0 1.0 0
-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0
-- setSource pattern
-- -- identityMatrix
-- -- setFillRule FillRuleEvenOdd
-- fillPreserve
-- restore
save
forM_ [0 .. hecCount hecs - 1] $ \h -> do
let y = fromIntegral (floor (fromIntegral h * dheight / fromIntegral (hecCount hecs))) - 0.5
setSourceRGBAhex black 0.3
moveTo dstart y
lineTo dend y
dashedLine1
restore
where
off t = fromIntegral activityGraphHeight -
fromIntegral (t * fromIntegral activityGraphHeight) /
fromIntegral (fromIntegral (hecCount hecs) * slice)
-- | Draw a dashed line along the current path.
dashedLine1 :: Render ()
dashedLine1 = do
save
identityMatrix
let dash = fromIntegral ox
setDash [dash, dash] 0.0
setLineWidth 1
stroke
restore
================================================
FILE: GUI/Timeline/CairoDrawing.hs
================================================
-------------------------------------------------------------------------------
--- $Id: CairoDrawing.hs#3 2009/07/18 22:48:30 REDMOND\\satnams $
--- $Source: //depot/satnams/haskell/ThreadScope/CairoDrawing.hs $
-------------------------------------------------------------------------------
module GUI.Timeline.CairoDrawing
where
import Graphics.Rendering.Cairo
import qualified Graphics.Rendering.Cairo as C
import Control.Monad
-------------------------------------------------------------------------------
{-# INLINE draw_line #-}
draw_line :: (Integral a, Integral b, Integral c, Integral d) =>
(a, b) -> (c, d) -> Render ()
draw_line (x0, y0) (x1, y1)
= do move_to (x0, y0)
lineTo (fromIntegral x1) (fromIntegral y1)
stroke
{-# INLINE move_to #-}
move_to :: (Integral a, Integral b) => (a, b) -> Render ()
move_to (x, y)
= moveTo (fromIntegral x) (fromIntegral y)
{-# INLINE rel_line_to #-}
rel_line_to :: (Integral a, Integral b) => (a, b) -> Render ()
rel_line_to (x, y)
= relLineTo (fromIntegral x) (fromIntegral y)
-------------------------------------------------------------------------------
{-# INLINE draw_rectangle #-}
draw_rectangle :: (Integral x, Integral y, Integral w, Integral h)
=> x -> y -> w -> h
-> Render ()
draw_rectangle x y w h = do
rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
C.fill
-------------------------------------------------------------------------------
{-# INLINE draw_outlined_rectangle #-}
draw_outlined_rectangle :: (Integral x, Integral y, Integral w, Integral h)
=> x -> y -> w -> h
-> Render ()
draw_outlined_rectangle x y w h = do
rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
fillPreserve
setLineWidth 1
setSourceRGBA 0 0 0 0.7
stroke
-------------------------------------------------------------------------------
{-# INLINE draw_rectangle_opt #-}
draw_rectangle_opt :: (Integral x, Integral y, Integral w, Integral h)
=> Bool -> x -> y -> w -> h
-> Render ()
draw_rectangle_opt opt x y w h
= draw_rectangle_opt' opt (fromIntegral x) (fromIntegral y)
(fromIntegral w) (fromIntegral h)
draw_rectangle_opt' :: Bool -> Double -> Double -> Double -> Double
-> Render ()
draw_rectangle_opt' opt x y w h
= do rectangle x y (1.0 `max` w) h
C.fill
when opt $ do
setLineWidth 1
setSourceRGBA 0 0 0 0.7
rectangle x y w h
stroke
-------------------------------------------------------------------------------
{-# INLINE draw_rectangle_outline #-}
draw_rectangle_outline :: (Integral x, Integral y, Integral w, Integral h)
=> x -> y -> w -> h
-> Render ()
draw_rectangle_outline x y w h = do
setLineWidth 2
rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
stroke
-------------------------------------------------------------------------------
clearWhite :: Render ()
clearWhite = do
save
setOperator OperatorSource
setSourceRGBA 0xffff 0xffff 0xffff 0xffff
paint
restore
================================================
FILE: GUI/Timeline/HEC.hs
================================================
{-# LANGUAGE OverloadedStrings #-}
module GUI.Timeline.HEC (
renderHEC,
renderInstantHEC,
) where
import GUI.Timeline.Render.Constants
import Events.EventDuration
import Events.EventTree
import GUI.Timeline.CairoDrawing
import GUI.Types
import GUI.ViewerColours
import Graphics.Rendering.Cairo
import GHC.RTS.Events hiding (Event, GCIdle, GCWork)
import qualified GHC.RTS.Events as GHC
import Control.Monad
import qualified Data.IntMap as IM
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import qualified Data.Text.Lazy.Builder.Int as TB (decimal)
import Prelude
renderHEC :: ViewParameters -> Timestamp -> Timestamp
-> IM.IntMap Text -> (DurationTree,EventTree)
-> Render ()
renderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do
renderDurations params start end dtree
when (scaleValue < detailThreshold) $
case etree of
EventTree ltime etime tree -> do
renderEvents params ltime etime start end (fromIntegral detail)
perfNames tree
return ()
renderInstantHEC :: ViewParameters -> Timestamp -> Timestamp
-> IM.IntMap Text -> EventTree
-> Render ()
renderInstantHEC params start end
perfNames (EventTree ltime etime tree) = do
let instantDetail = 1
renderEvents params ltime etime start end instantDetail perfNames tree
return ()
detailThreshold :: Double
detailThreshold = 3
-------------------------------------------------------------------------------
-- draws the trace for a single HEC
renderDurations :: ViewParameters
-> Timestamp -> Timestamp -> DurationTree
-> Render ()
renderDurations _ _ _ DurationTreeEmpty = return ()
renderDurations params startPos endPos (DurationTreeLeaf e)
| inView startPos endPos e = drawDuration params e
| otherwise = return ()
renderDurations params@ViewParameters{..} !startPos !endPos
(DurationSplit s splitTime e lhs rhs runAv gcAv)
| startPos < splitTime && endPos >= splitTime &&
(fromIntegral (e - s) / scaleValue) <= fromIntegral detail
= -- View spans both left and right sub-tree.
-- trace (printf "renderDurations (average): start:%d end:%d s:%d e:%d" startPos endPos s e) $
drawAverageDuration params s e runAv gcAv
| otherwise
= -- trace (printf "renderDurations: start:%d end:%d s:%d e:%d" startPos endPos s e) $
do when (startPos < splitTime) $
renderDurations params startPos endPos lhs
when (endPos >= splitTime) $
renderDurations params startPos endPos rhs
-------------------------------------------------------------------------------
renderEvents :: ViewParameters
-> Timestamp -- start time of this tree node
-> Timestamp -- end time of this tree node
-> Timestamp -> Timestamp -> Double
-> IM.IntMap Text -> EventNode
-> Render Bool
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
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 !_s !_e !startPos !endPos ewidth
perfNames (EventTreeOne ev)
| t >= startPos && t < endPos = drawEvent params ewidth perfNames ev
| otherwise = return False
where t = evTime ev
renderEvents params@ViewParameters{..} !s !e !startPos !endPos ewidth
perfNames (EventSplit splitTime lhs rhs)
| startPos < splitTime && endPos >= splitTime &&
(fromIntegral (e - s) / scaleValue) <= ewidth
= do drawnLhs <-
renderEvents params s splitTime startPos endPos ewidth perfNames lhs
if not drawnLhs
then
renderEvents params splitTime e startPos endPos ewidth perfNames rhs
else return True
| otherwise
= do drawnLhs <-
if startPos < splitTime
then
renderEvents params s splitTime startPos endPos ewidth perfNames lhs
else return False
drawnRhs <-
if endPos >= splitTime
then
renderEvents params splitTime e startPos endPos ewidth perfNames rhs
else return False
return $ drawnLhs || drawnRhs
-------------------------------------------------------------------------------
-- An event is in view if it is not outside the view.
inView :: Timestamp -> Timestamp -> EventDuration -> Bool
inView viewStart viewEnd event =
not (eStart > viewEnd || eEnd <= viewStart)
where
eStart = startTimeOf event
eEnd = endTimeOf event
-------------------------------------------------------------------------------
drawAverageDuration :: ViewParameters
-> Timestamp -> Timestamp -> Timestamp -> Timestamp
-> Render ()
drawAverageDuration ViewParameters{..} startTime endTime runAv gcAv = do
setSourceRGBAhex (if not bwMode then runningColour else black) 1.0
when (runAv > 0) $
draw_rectangle startTime hecBarOff -- x, y
(endTime - startTime) -- w
hecBarHeight
setSourceRGBAhex black 1.0
--move_to (oxs + startTime, 0)
--relMoveTo (4/scaleValue) 13
--unscaledText scaleValue (show nrEvents)
setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio
draw_rectangle startTime -- x
(hecBarOff+hecBarHeight) -- y
(endTime - startTime) -- w
(hecBarHeight `div` 2) -- h
where
duration = endTime - startTime
-- runRatio :: Double
-- runRatio = (fromIntegral runAv) / (fromIntegral duration)
gcRatio :: Double
gcRatio = (fromIntegral gcAv) / (fromIntegral duration)
-------------------------------------------------------------------------------
unscaledText :: String -> Render ()
unscaledText text
= do m <- getMatrix
identityMatrix
showText text
setMatrix m
-------------------------------------------------------------------------------
textWidth :: Double -> String -> Render TextExtents
textWidth _scaleValue text
= do m <- getMatrix
identityMatrix
tExtent <- textExtents text
setMatrix m
return tExtent
-------------------------------------------------------------------------------
drawDuration :: ViewParameters -> EventDuration -> Render ()
drawDuration ViewParameters{..} (ThreadRun t s startTime endTime) = do
setSourceRGBAhex (if not bwMode then runningColour else black) 1.0
setLineWidth (1/scaleValue)
draw_rectangle_opt False
startTime -- x
hecBarOff -- y
(endTime - startTime) -- w
hecBarHeight -- h
-- Optionally label the bar with the threadID if there is room
tExtent <- textWidth scaleValue tStr
let tw = textExtentsWidth tExtent
th = textExtentsHeight tExtent
when (tw + 6 < fromIntegral rectWidth) $ do
setSourceRGBAhex labelTextColour 1.0
move_to (fromIntegral startTime + truncate (4*scaleValue),
hecBarOff + (hecBarHeight + round th) `quot` 2)
unscaledText tStr
-- Optionally write the reason for the thread being stopped
-- depending on the zoom value
labelAt labelsMode endTime $
T.pack $ show t ++ " " ++ showThreadStopStatus s
where
rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels
tStr = show t
drawDuration ViewParameters{..} (GCStart startTime endTime)
= gcBar (if bwMode then black else gcStartColour) startTime endTime
drawDuration ViewParameters{..} (GCWork startTime endTime)
= gcBar (if bwMode then black else gcWorkColour) startTime endTime
drawDuration ViewParameters{..} (GCIdle startTime endTime)
= gcBar (if bwMode then black else gcIdleColour) startTime endTime
drawDuration ViewParameters{..} (GCEnd startTime endTime)
= gcBar (if bwMode then black else gcEndColour) startTime endTime
gcBar :: Color -> Timestamp -> Timestamp -> Render ()
gcBar col !startTime !endTime = do
setSourceRGBAhex col 1.0
draw_rectangle_opt False
startTime -- x
(hecBarOff+hecBarHeight) -- y
(endTime - startTime) -- w
(hecBarHeight `div` 2) -- h
labelAt :: Bool -> Timestamp -> Text -> Render ()
labelAt labelsMode t str
| not labelsMode = return ()
| otherwise = do
setSourceRGB 0.0 0.0 0.0
move_to (t, hecBarOff+hecBarHeight+12)
save
identityMatrix
rotate (pi/4)
showText str
restore
drawEvent :: ViewParameters -> Double -> IM.IntMap Text -> GHC.Event
-> Render Bool
drawEvent params ewidth perfNames event =
let renderI = renderInstantEvent params perfNames event ewidth
in case evSpec 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
renderInstantEv
gitextract_n4vjqfzb/ ├── .github/ │ └── workflows/ │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── Events/ │ ├── EventDuration.hs │ ├── EventTree.hs │ ├── HECs.hs │ ├── ReadEvents.hs │ ├── SparkStats.hs │ ├── SparkTree.hs │ └── TestEvents.hs ├── GUI/ │ ├── App.hs │ ├── BookmarkView.hs │ ├── ConcurrencyControl.hs │ ├── DataFiles.hs │ ├── Dialogs.hs │ ├── EventsView.hs │ ├── GtkExtras.hs │ ├── Histogram.hs │ ├── KeyView.hs │ ├── Main.hs │ ├── MainWindow.hs │ ├── ProgressView.hs │ ├── SaveAs.hs │ ├── StartupInfoView.hs │ ├── SummaryView.hs │ ├── Timeline/ │ │ ├── Activity.hs │ │ ├── CairoDrawing.hs │ │ ├── HEC.hs │ │ ├── Motion.hs │ │ ├── Render/ │ │ │ └── Constants.hs │ │ ├── Render.hs │ │ ├── Sparks.hs │ │ ├── Ticks.hs │ │ └── Types.hs │ ├── Timeline.hs │ ├── TraceView.hs │ ├── Types.hs │ └── ViewerColours.hs ├── Graphics/ │ └── UI/ │ └── Gtk/ │ └── ModelView/ │ └── TreeView/ │ └── Compat.hs ├── LICENSE ├── Main.hs ├── Makefile ├── README.md ├── Setup.hs ├── TODO ├── cabal.project ├── cabal.project.osx ├── include/ │ └── windows_cconv.h ├── index.html ├── papers/ │ └── haskell_symposium_2009/ │ ├── Makefile │ ├── bsort/ │ │ ├── BSort.hs │ │ ├── BSortPar.hs │ │ ├── BSortPar2.hs │ │ ├── BSortStreaming.hs │ │ └── Makefile │ ├── bsort.tex │ ├── fib/ │ │ ├── Fib1.hs │ │ ├── Fib2.hs │ │ └── Makefile │ ├── ghc-parallel-tuning.bib │ ├── ghc-parallel-tuning.tex │ ├── infrastructure.tex │ ├── motivation.tex │ ├── related-work.tex │ ├── sigplanconf.cls │ ├── sumEuler/ │ │ ├── Makefile │ │ ├── SumEuler0.hs │ │ ├── SumEuler1.hs │ │ ├── SumEuler2.hs │ │ └── SumEuler3.hs │ └── threadring.tex ├── scripts/ │ └── install-on-osx.sh ├── stack.osx.yaml ├── stack.yaml ├── tests/ │ ├── Hello.hs │ ├── Makefile │ ├── Null.hs │ ├── ParFib.hs │ └── SumEulerPar1.hs ├── threadscope.cabal └── threadscope.ui
Condensed preview — 81 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (584K chars).
[
{
"path": ".github/workflows/ci.yml",
"chars": 5421,
"preview": "name: CI\non:\n push:\n branches:\n - master\n tags:\n - v*\n pull_request:\n release:\n\nenv:\n GHC_FOR_RELEAS"
},
{
"path": ".gitignore",
"chars": 36,
"preview": "dist-newstyle\ncabal.project.local~*\n"
},
{
"path": "CHANGELOG.md",
"chars": 2725,
"preview": "# Revision history for threadscope\n\n## 2025-05-29 - v0.2.15.0\n* Switch to GTK3 ([#137](https://github.com/haskell/Thread"
},
{
"path": "Events/EventDuration.hs",
"chars": 6248,
"preview": "-- This module supports a duration-based data-type to represent thread\n-- execution and GC information.\n\nmodule Events.E"
},
{
"path": "Events/EventTree.hs",
"chars": 9589,
"preview": "module Events.EventTree (\n DurationTree(..),\n mkDurationTree,\n\n runTimeOf, gcTimeOf,\n reportDurationTree"
},
{
"path": "Events/HECs.hs",
"chars": 2723,
"preview": "{-# LANGUAGE CPP #-}\nmodule Events.HECs (\n HECs(..),\n Event,\n Timestamp,\n\n eventIndexToTimestamp,\n timest"
},
{
"path": "Events/ReadEvents.hs",
"chars": 10320,
"preview": "module Events.ReadEvents (\n registerEventsFromFile, registerEventsFromTrace\n ) where\n\nimport Events.EventDuration\nim"
},
{
"path": "Events/SparkStats.hs",
"chars": 4310,
"preview": "module Events.SparkStats\n ( SparkStats(..)\n , initial, create, rescale, aggregate, agEx\n ) where\n\nimport Data.Word (W"
},
{
"path": "Events/SparkTree.hs",
"chars": 10342,
"preview": "module Events.SparkTree (\n SparkTree,\n sparkTreeMaxDepth,\n emptySparkTree,\n eventsToSparkDurations,\n mkSparkTree,\n "
},
{
"path": "Events/TestEvents.hs",
"chars": 10085,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule Events.TestEvents (testTrace)\nwhere\n\nimport Data.Word\nimport GHC.RTS.Events\n\n-"
},
{
"path": "GUI/App.hs",
"chars": 473,
"preview": "-------------------------------------------------------------------------------\n-- | Module : GUI.App\n--\n-- Platform-spe"
},
{
"path": "GUI/BookmarkView.hs",
"chars": 4485,
"preview": "module GUI.BookmarkView (\n BookmarkView,\n bookmarkViewNew,\n BookmarkViewActions(..),\n\n bookmarkViewGet,\n "
},
{
"path": "GUI/ConcurrencyControl.hs",
"chars": 2200,
"preview": "\nmodule GUI.ConcurrencyControl (\n ConcurrencyControl,\n start,\n fullSpeed,\n ) where\n\nimport qualified System.Gl"
},
{
"path": "GUI/DataFiles.hs",
"chars": 1171,
"preview": "{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TemplateHaskell #-}\nmodule GUI.DataFiles\n ( ui\n , loadLogo\n ) where"
},
{
"path": "GUI/Dialogs.hs",
"chars": 5763,
"preview": "{-# LANGUAGE TemplateHaskell #-}\nmodule GUI.Dialogs where\n\nimport GUI.DataFiles (loadLogo)\nimport Paths_threadscope (ver"
},
{
"path": "GUI/EventsView.hs",
"chars": 12609,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule GUI.EventsView (\n EventsView,\n eventsViewNew,\n E"
},
{
"path": "GUI/GtkExtras.hs",
"chars": 2143,
"preview": "{-# LANGUAGE ForeignFunctionInterface, CPP #-}\nmodule GUI.GtkExtras where\n\n-- This is all stuff that should be bound in "
},
{
"path": "GUI/Histogram.hs",
"chars": 4668,
"preview": "{-# LANGUAGE ScopedTypeVariables #-}\n module GUI.Histogram (\n HistogramView,\n histogramViewNew,\n histogramView"
},
{
"path": "GUI/KeyView.hs",
"chars": 7014,
"preview": "module GUI.KeyView (\n KeyView,\n keyViewNew,\n ) where\n\nimport GUI.ViewerColours\nimport GUI.Timeline.Render.Constan"
},
{
"path": "GUI/Main.hs",
"chars": 15957,
"preview": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE TemplateHaskell #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule GUI.Main (runGUI) where\n"
},
{
"path": "GUI/MainWindow.hs",
"chars": 7345,
"preview": "{-# LANGUAGE TemplateHaskell #-}\nmodule GUI.MainWindow (\n MainWindow,\n mainWindowNew,\n MainWindowActions(..),\n\n"
},
{
"path": "GUI/ProgressView.hs",
"chars": 3405,
"preview": "{-# LANGUAGE DeriveDataTypeable #-}\n\nmodule GUI.ProgressView (\n ProgressView,\n withProgress,\n setText,\n setT"
},
{
"path": "GUI/SaveAs.hs",
"chars": 2829,
"preview": "module GUI.SaveAs (saveAsPDF, saveAsPNG) where\n\n-- Imports for ThreadScope\nimport GUI.Timeline.Render (renderTraces, ren"
},
{
"path": "GUI/StartupInfoView.hs",
"chars": 5594,
"preview": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ViewPatterns #-}\nmodule GUI.StartupInfoView (\n StartupInfoView,\n s"
},
{
"path": "GUI/SummaryView.hs",
"chars": 40085,
"preview": "module GUI.SummaryView (\n SummaryView,\n summaryViewNew,\n summaryViewSetEvents,\n summaryViewSetInterval,\n ) "
},
{
"path": "GUI/Timeline/Activity.hs",
"chars": 5603,
"preview": "module GUI.Timeline.Activity (\n renderActivity\n ) where\n\nimport GUI.Timeline.Render.Constants\n\nimport Events.HECs\n"
},
{
"path": "GUI/Timeline/CairoDrawing.hs",
"chars": 3250,
"preview": "-------------------------------------------------------------------------------\n--- $Id: CairoDrawing.hs#3 2009/07/18 22"
},
{
"path": "GUI/Timeline/HEC.hs",
"chars": 11301,
"preview": "{-# LANGUAGE OverloadedStrings #-}\nmodule GUI.Timeline.HEC (\n renderHEC,\n renderInstantHEC,\n ) where\n\nimport GUI."
},
{
"path": "GUI/Timeline/Motion.hs",
"chars": 5212,
"preview": "module GUI.Timeline.Motion (\n zoomIn, zoomOut, zoomToFit,\n scrollLeft, scrollRight, scrollToBeginning, scrollToEnd"
},
{
"path": "GUI/Timeline/Render/Constants.hs",
"chars": 1415,
"preview": "module GUI.Timeline.Render.Constants (\n ox, firstTraceY, tracePad,\n hecTraceHeight, hecInstantHeight, hecSparksHei"
},
{
"path": "GUI/Timeline/Render.hs",
"chars": 17298,
"preview": "{-# LANGUAGE CPP #-}\nmodule GUI.Timeline.Render (\n renderView,\n renderTraces,\n updateXScaleArea,\n renderYSca"
},
{
"path": "GUI/Timeline/Sparks.hs",
"chars": 9512,
"preview": "module GUI.Timeline.Sparks (\n treesProfile,\n maxSparkRenderedValue,\n renderSparkCreation,\n renderSparkConver"
},
{
"path": "GUI/Timeline/Ticks.hs",
"chars": 11603,
"preview": "{-# LANGUAGE CPP #-}\nmodule GUI.Timeline.Ticks (\n renderVRulers,\n XScaleMode(..),\n renderXScaleArea,\n render"
},
{
"path": "GUI/Timeline/Types.hs",
"chars": 1171,
"preview": "module GUI.Timeline.Types (\n TimelineState(..),\n TimeSelection(..),\n ) where\n\n\nimport GUI.Types\n\nimport Graphics.U"
},
{
"path": "GUI/Timeline.hs",
"chars": 20554,
"preview": "{-# LANGUAGE CPP #-}\nmodule GUI.Timeline (\n TimelineView,\n timelineViewNew,\n TimelineViewActions(..),\n\n time"
},
{
"path": "GUI/TraceView.hs",
"chars": 7365,
"preview": "module GUI.TraceView (\n TraceView,\n traceViewNew,\n TraceViewActions(..),\n traceViewSetHECs,\n traceViewGet"
},
{
"path": "GUI/Types.hs",
"chars": 953,
"preview": "module GUI.Types (\n ViewParameters(..),\n Trace(..),\n Timestamp,\n Interval,\n ) where\n\nimport GHC.RTS.Events\n"
},
{
"path": "GUI/ViewerColours.hs",
"chars": 3545,
"preview": "-------------------------------------------------------------------------------\n--- $Id: ViewerColours.hs#2 2009/07/18 2"
},
{
"path": "Graphics/UI/Gtk/ModelView/TreeView/Compat.hs",
"chars": 660,
"preview": "{-# LANGUAGE CPP #-}\nmodule Graphics.UI.Gtk.ModelView.TreeView.Compat\n ( treeViewSetModel\n ) where\nimport Graphics"
},
{
"path": "LICENSE",
"chars": 1623,
"preview": "The Glasgow Haskell Compiler License\n\nCopyright 2002-2012, The University Court of the University of Glasgow\nand others."
},
{
"path": "Main.hs",
"chars": 2387,
"preview": "module Main where\n\nimport GUI.Main (runGUI)\n\nimport System.Environment\nimport System.Exit\nimport System.Console.GetOpt\ni"
},
{
"path": "Makefile",
"chars": 223,
"preview": "# Makefile for ThreadScope\r\n\r\nGHC = c:/ghc/ghc-6.10.3/bin/ghc\r\n\r\ncabal:\r\n\tcabal install -w $(GHC) --user --prefix=$(HOME"
},
{
"path": "README.md",
"chars": 3126,
"preview": "# ThreadScope\n\n[](https://hackage.haskell.org/package/thread"
},
{
"path": "Setup.hs",
"chars": 45,
"preview": "import Distribution.Simple\nmain = defaultMain"
},
{
"path": "TODO",
"chars": 19918,
"preview": "BUGS:\n\n- ThreadScope DEADLOCKs occasionally, more often with --debug, why?\n\n- X Window System error sometimes?\n\n- backgr"
},
{
"path": "cabal.project",
"chars": 109,
"preview": "-- see http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html for more information\n\npackages: .\n"
},
{
"path": "cabal.project.osx",
"chars": 46,
"preview": "packages: .\nconstraints: gtk +have-quartz-gtk\n"
},
{
"path": "include/windows_cconv.h",
"chars": 223,
"preview": "#ifndef __WINDOWS_CCONV_H\n#define __WINDOWS_CCONV_H\n\n#if defined(i386_HOST_ARCH)\n# define WINDOWS_CCONV stdcall\n#elif de"
},
{
"path": "index.html",
"chars": 1116,
"preview": "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"
},
{
"path": "papers/haskell_symposium_2009/Makefile",
"chars": 466,
"preview": "# $Id: Makefile#3 2009/07/18 22:48:30 REDMOND\\\\satnams $\r\n# $Source: //depot/satnams/haskell/ThreadScope/papers/haskell_"
},
{
"path": "papers/haskell_symposium_2009/bsort/BSort.hs",
"chars": 6086,
"preview": "-------------------------------------------------------------------------------\r\n--- $Id: BSort.hs#1 2009/03/06 10:53:15"
},
{
"path": "papers/haskell_symposium_2009/bsort/BSortPar.hs",
"chars": 6142,
"preview": "-------------------------------------------------------------------------------\r\n--- $Id: BSort.hs#1 2009/03/06 10:53:15"
},
{
"path": "papers/haskell_symposium_2009/bsort/BSortPar2.hs",
"chars": 6187,
"preview": "-------------------------------------------------------------------------------\r\n--- $Id: BSort.hs#1 2009/03/06 10:53:15"
},
{
"path": "papers/haskell_symposium_2009/bsort/BSortStreaming.hs",
"chars": 6896,
"preview": "-------------------------------------------------------------------------------\r\n--- $Id: BSortStreaming.hs#1 2009/03/06"
},
{
"path": "papers/haskell_symposium_2009/bsort/Makefile",
"chars": 1439,
"preview": "GHC = /c/ghc/ghc/inplace/bin/ghc-stage2\r\nGHC_OPTS = -threaded -eventlog\r\n# HEAP = -H100M\r\nHEAP =\r\nEBH = -feager-blackhol"
},
{
"path": "papers/haskell_symposium_2009/bsort.tex",
"chars": 5781,
"preview": "\\subsection{Batcher's Bitonic Parallel Sorter}\r\nBatcher's bitonic merger and sorter is a parallel sorting algorithm whic"
},
{
"path": "papers/haskell_symposium_2009/fib/Fib1.hs",
"chars": 1298,
"preview": "-------------------------------------------------------------------------------\r\n\r\nmodule Main\r\nwhere\r\nimport System.Tim"
},
{
"path": "papers/haskell_symposium_2009/fib/Fib2.hs",
"chars": 1307,
"preview": "-------------------------------------------------------------------------------\r\n\r\nmodule Main\r\nwhere\r\nimport System.Tim"
},
{
"path": "papers/haskell_symposium_2009/fib/Makefile",
"chars": 323,
"preview": "GHC = /c/ghc/ghc/inplace/bin/ghc-stage2\r\nGHC_OPTS = -threaded -eventlog\r\n\r\nall:\t\r\n\t$(GHC) $(GHC_OPTS) --make Fib1.hs\r\n\t$"
},
{
"path": "papers/haskell_symposium_2009/ghc-parallel-tuning.bib",
"chars": 4639,
"preview": "% $Id: ghc-parallel-tuning.bib#3 2009/07/18 22:48:30 REDMOND\\\\satnams $\r\n% $Source: //depot/satnams/haskell/ThreadScope/"
},
{
"path": "papers/haskell_symposium_2009/ghc-parallel-tuning.tex",
"chars": 25778,
"preview": "\\documentclass[twocolumn,9pt]{sigplanconf}\r\n\r\n\\usepackage{url}\r\n% \\usepackage{code}\r\n\\usepackage{graphicx}\r\n\\usepackage{"
},
{
"path": "papers/haskell_symposium_2009/infrastructure.tex",
"chars": 11330,
"preview": "\\section{Profiling Infrastructure}\n\\begin{figure*}\n\\begin{center}\n\\includegraphics[scale=0.3]{eventbench.png}\n\\end{cente"
},
{
"path": "papers/haskell_symposium_2009/motivation.tex",
"chars": 8836,
"preview": "\\section{Profiling Motivation}\r\nHaskell provides a mechanism to allow the user to control the granularity of parallelism"
},
{
"path": "papers/haskell_symposium_2009/related-work.tex",
"chars": 917,
"preview": "\\section{Related Work}\r\n\r\nGranSim~\\cite{loidl} is an event-driven simulator for the parallel\r\nexecution of Glasgow Paral"
},
{
"path": "papers/haskell_symposium_2009/sigplanconf.cls",
"chars": 31815,
"preview": "%-----------------------------------------------------------------------------\n%\n% LaTeX Class/Style File\n"
},
{
"path": "papers/haskell_symposium_2009/sumEuler/Makefile",
"chars": 1106,
"preview": "GHC = /c/ghc/ghc/inplace/bin/ghc-stage2\r\nGHC_OPTS = -threaded -eventlog\r\n# HEAP = -H100M\r\nHEAP =\r\n\r\nall:\t\r\n\t$(GHC) $(GHC"
},
{
"path": "papers/haskell_symposium_2009/sumEuler/SumEuler0.hs",
"chars": 2163,
"preview": "-------------------------------------------------------------------------------\r\n-- This program runs fib and sumEuler s"
},
{
"path": "papers/haskell_symposium_2009/sumEuler/SumEuler1.hs",
"chars": 2150,
"preview": "-------------------------------------------------------------------------------\r\n-- This demonstrates that f `par` (f + "
},
{
"path": "papers/haskell_symposium_2009/sumEuler/SumEuler2.hs",
"chars": 2075,
"preview": "-------------------------------------------------------------------------------\r\n\r\nmodule Main\r\nwhere\r\nimport System.Tim"
},
{
"path": "papers/haskell_symposium_2009/sumEuler/SumEuler3.hs",
"chars": 2086,
"preview": "-------------------------------------------------------------------------------\r\n\r\nmodule Main\r\nwhere\r\nimport System.Tim"
},
{
"path": "papers/haskell_symposium_2009/threadring.tex",
"chars": 4929,
"preview": "\\subsection{Thread Ring}\n\nThe thread ring benchmark originates in the Computer Language\nBenchmarks Game\\footnote{\\url{ht"
},
{
"path": "scripts/install-on-osx.sh",
"chars": 1325,
"preview": "#!/bin/sh\n\nHC=$1\n\nset -ex\n\nCABALPKG=\"cabal-c92b4ea7ce036fae6ebf3c2965d6ecc0ef252775-20170725-123913.xz\"\nCABALCHECKSUM=\"2"
},
{
"path": "stack.osx.yaml",
"chars": 656,
"preview": "resolver: lts-16.28\npackages:\n- .\nextra-deps:\n- cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa"
},
{
"path": "stack.yaml",
"chars": 616,
"preview": "resolver: lts-16.28\npackages:\n- .\nextra-deps:\n- cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa"
},
{
"path": "tests/Hello.hs",
"chars": 46,
"preview": "module Main\r\nwhere\r\n\r\nmain = putStrLn \"Hello.\""
},
{
"path": "tests/Makefile",
"chars": 502,
"preview": "GHC = c:/ghc/ghc/inplace/bin/ghc-stage2\r\nGHC_OPTS = -O -threaded -eventlog\r\n\r\nall:\t\r\n\t$(GHC) $(GHC_OPTS) --make Null.hs\r"
},
{
"path": "tests/Null.hs",
"chars": 40,
"preview": "module Main\r\nwhere\r\n\r\nmain = return ()\r\n"
},
{
"path": "tests/ParFib.hs",
"chars": 1811,
"preview": "-------------------------------------------------------------------------------\r\n-- A parallel implementation of fib in "
},
{
"path": "tests/SumEulerPar1.hs",
"chars": 1906,
"preview": "-------------------------------------------------------------------------------\r\n--- $Id: SumEulerPar1.hs#1 2008/05/06 1"
},
{
"path": "threadscope.cabal",
"chars": 5234,
"preview": "Cabal-version: 1.24\nName: threadscope\nVersion: 0.2.15.0\nCategory: Developmen"
},
{
"path": "threadscope.ui",
"chars": 105043,
"preview": "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<interface>\n <requires lib=\"gtk+\" version=\"2.16\"/>\n <object class=\"GtkAdjustmen"
}
]
About this extraction
This page contains the full source code of the haskell/ThreadScope GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 81 files (543.7 KB), approximately 132.6k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.