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 ", "Simon Marlow ", "Satnam Singh ", "Duncan Coutts ", "Mikolaj Konarski ", "Nicolas Wu ", "Eric Kow "], 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 +RTS -lf 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 := "" ++ msg ++ "" ] startPulse :: ProgressView -> IO (IO ()) startPulse view = do let pulse = do progressBarPulse (progressBar view) Concurrent.threadDelay 200000 pulse thread <- Concurrent.forkIO $ pulse `catch` \OperationInterrupted -> return () let stop = throwTo thread OperationInterrupted waitGUI return stop setProgress :: ProgressView -> Int -> Int -> IO () setProgress view total current = do let frac = fromIntegral current / fromIntegral total set (progressBar view) [ progressBarFraction := frac ] waitGUI close :: ProgressView -> IO () close view = widgetDestroy (progressWindow view) new :: WindowClass win => win -> IO () -> IO ProgressView new parent cancelAction = do win <- windowNew set win [ containerBorderWidth := 10, windowTitle := "", windowTransientFor := toWindow parent, windowModal := True, windowWindowPosition := WinPosCenterOnParent, windowDefaultWidth := 400, windowSkipTaskbarHint := True ] progText <- labelNew (Nothing :: Maybe String) set progText [ miscXalign := 0, labelUseMarkup := True ] progress <- progressBarNew cancel <- buttonNewFromStock stockCancel 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 renderInstantEvent :: ViewParameters -> IM.IntMap Text -> GHC.Event -> Double -> Color -> Render Bool renderInstantEvent ViewParameters{..} perfNames event ewidth color = do setSourceRGBAhex color 1.0 setLineWidth (ewidth * scaleValue) let t = evTime event draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4) let numToLabel :: EventInfo -> Maybe Text numToLabel PerfCounter{perfNum, period} | period == 0 = IM.lookup (fromIntegral perfNum) perfNames numToLabel PerfCounter{perfNum, period} = do name <- IM.lookup (fromIntegral perfNum) perfNames return $ toText $ TB.fromText name <> " <" <> TB.decimal (period + 1) <> " times>" numToLabel PerfTracepoint{perfNum} = do name <- IM.lookup (fromIntegral perfNum) perfNames return $ toText $ "tracepoint: " <> TB.fromText name numToLabel _ = Nothing showLabel espec = fromMaybe (toText $ buildEventInfo espec) (numToLabel espec) labelAt labelsMode t $ showLabel (evSpec event) return True where toText = TL.toStrict . TB.toLazyText ------------------------------------------------------------------------------- ================================================ FILE: GUI/Timeline/Motion.hs ================================================ module GUI.Timeline.Motion ( zoomIn, zoomOut, zoomToFit, scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, scrollTo, centreOnCursor, vscrollDown, vscrollUp, ) where import GUI.Timeline.Types import GUI.Timeline.Sparks import Events.HECs import Graphics.UI.Gtk import Data.IORef import Control.Monad -- import Text.Printf -- import Debug.Trace ------------------------------------------------------------------------------- -- Zoom in works by expanding the current view such that the -- left hand edge of the original view remains at the same -- position and the zoom in factor is 2. -- For example, zoom into the time range 1.0 3.0 -- produces a new view with the time range 1.0 2.0 zoomIn :: TimelineState -> Timestamp -> IO () zoomIn = zoom (/2) zoomOut :: TimelineState -> Timestamp -> IO () zoomOut = zoom (*2) zoom :: (Double -> Double) -> TimelineState -> Timestamp -> IO () zoom factor TimelineState{timelineAdj, scaleIORef} cursor = do scaleValue <- readIORef scaleIORef -- TODO: we'd need HECs, as below, to fit maxScale to graphs at hand let maxScale = 10000000000 -- big enough for hours of eventlogs clampedFactor = if factor scaleValue < 0.2 || factor scaleValue > maxScale then id else factor newScaleValue = clampedFactor scaleValue writeIORef scaleIORef newScaleValue hadj_value <- adjustmentGetValue timelineAdj hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar let newPageSize = clampedFactor hadj_pagesize adjustmentSetPageSize timelineAdj newPageSize let cursord = fromIntegral cursor when (cursord >= hadj_value && cursord < hadj_value + hadj_pagesize) $ adjustmentSetValue timelineAdj $ cursord - clampedFactor (cursord - hadj_value) let pageshift = 0.9 * newPageSize let nudge = 0.1 * newPageSize adjustmentSetStepIncrement timelineAdj nudge adjustmentSetPageIncrement timelineAdj pageshift ------------------------------------------------------------------------------- zoomToFit :: TimelineState -> Maybe HECs -> IO () zoomToFit TimelineState{scaleIORef, maxSpkIORef,timelineAdj, timelineDrawingArea} mb_hecs = do case mb_hecs of Nothing -> return () Just hecs -> do let lastTx = hecLastEventTime hecs upper = fromIntegral lastTx lower = 0 Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea let newScaleValue = upper / fromIntegral w (sliceAll, profAll) = treesProfile newScaleValue 0 lastTx hecs -- TODO: verify that no empty lists possible below maxmap l = maximum (0 : map (maxSparkRenderedValue sliceAll) l) maxAll = map maxmap profAll newMaxSpkValue = maximum (0 : maxAll) writeIORef scaleIORef newScaleValue writeIORef maxSpkIORef newMaxSpkValue -- Configure the horizontal scrollbar units to correspond to micro-secs. adjustmentSetLower timelineAdj lower adjustmentSetValue timelineAdj lower adjustmentSetUpper timelineAdj upper adjustmentSetPageSize timelineAdj upper -- TODO: this seems suspicious: adjustmentSetStepIncrement timelineAdj 0 adjustmentSetPageIncrement timelineAdj 0 ------------------------------------------------------------------------------- scrollLeft, scrollRight, scrollToBeginning, scrollToEnd :: TimelineState -> IO () scrollLeft = scroll (\val page l _ -> l `max` (val - page/2)) scrollRight = scroll (\val page _ u -> (u - page) `min` (val + page/2)) scrollToBeginning = scroll (\_ _ l _ -> l) scrollToEnd = scroll (\_ _ _ u -> u) scrollTo :: TimelineState -> Double -> IO () scrollTo s x = scroll (\_ _ _ _ -> x) s centreOnCursor :: TimelineState -> Timestamp -> IO () centreOnCursor state cursor = scroll (\_ page l _u -> max l (fromIntegral cursor - page/2)) state scroll :: (Double -> Double -> Double -> Double -> Double) -> TimelineState -> IO () scroll adjust TimelineState{timelineAdj} = do hadj_value <- adjustmentGetValue timelineAdj hadj_pagesize <- adjustmentGetPageSize timelineAdj hadj_lower <- adjustmentGetLower timelineAdj hadj_upper <- adjustmentGetUpper timelineAdj let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper newValue' = max hadj_lower (min (hadj_upper - hadj_pagesize) newValue) adjustmentSetValue timelineAdj newValue' vscrollDown, vscrollUp :: TimelineState -> IO () vscrollDown = vscroll (\val page _l u -> (u - page) `min` (val + page/8)) vscrollUp = vscroll (\val page l _u -> l `max` (val - page/8)) vscroll :: (Double -> Double -> Double -> Double -> Double) -> TimelineState -> IO () vscroll adjust TimelineState{timelineVAdj} = do hadj_value <- adjustmentGetValue timelineVAdj hadj_pagesize <- adjustmentGetPageSize timelineVAdj hadj_lower <- adjustmentGetLower timelineVAdj hadj_upper <- adjustmentGetUpper timelineVAdj let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper adjustmentSetValue timelineVAdj newValue adjustmentValueChanged timelineVAdj -- ----------------------------------------------------------------------------- ================================================ FILE: GUI/Timeline/Render/Constants.hs ================================================ module GUI.Timeline.Render.Constants ( ox, firstTraceY, tracePad, hecTraceHeight, hecInstantHeight, hecSparksHeight, hecBarOff, hecBarHeight, hecLabelExtra, activityGraphHeight, stdHistogramHeight, histXScaleHeight, ticksHeight, ticksPad ) where ------------------------------------------------------------------------------- -- The standard gap in various graphs ox :: Int ox = 10 -- Origin for traces firstTraceY :: Int firstTraceY = 13 -- Gap between traces in the timeline view tracePad :: Int tracePad = 20 -- HEC bar height hecTraceHeight, hecInstantHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int hecTraceHeight = 40 hecInstantHeight = 25 hecBarHeight = 20 hecBarOff = 10 -- extra space to allow between HECs when labels are on. -- ToDo: should be calculated somehow hecLabelExtra = 80 -- Activity graph activityGraphHeight :: Int activityGraphHeight = 100 -- Height of the spark graphs. hecSparksHeight :: Int hecSparksHeight = activityGraphHeight -- Histogram graph height when displayed with other traces (e.g., in PNG/PDF). stdHistogramHeight :: Int stdHistogramHeight = hecSparksHeight -- The X scale of histogram has this constant height, as opposed -- to the timeline X scale, which takes its height from the .ui file. histXScaleHeight :: Int histXScaleHeight = 30 -- Ticks ticksHeight :: Int ticksHeight = 20 ticksPad :: Int ticksPad = 20 ================================================ FILE: GUI/Timeline/Render.hs ================================================ {-# LANGUAGE CPP #-} module GUI.Timeline.Render ( renderView, renderTraces, updateXScaleArea, renderYScaleArea, updateYScaleArea, calculateTotalTimelineHeight, toWholePixels, ) where import GUI.Timeline.Types import GUI.Timeline.Render.Constants import GUI.Timeline.Ticks import GUI.Timeline.HEC import GUI.Timeline.Sparks import GUI.Timeline.Activity import Events.HECs import GUI.Types import GUI.ViewerColours import GUI.Timeline.CairoDrawing import Graphics.UI.Gtk hiding (rectangle) import Graphics.Rendering.Cairo ( Render , Content(..) , Operator(..) , Surface , liftIO , withTargetSurface , createSimilarSurface , renderWith , surfaceFinish , clip , setSourceSurface , setOperator , paint , setLineWidth , moveTo , lineTo , stroke , rectangle , fill , save , scale , translate , restore , setSourceRGBA ) import Data.IORef import Control.Monad import qualified Data.Text as T import qualified Graphics.UI.Gtk.Cairo as C ------------------------------------------------------------------------------- -- | This function redraws the currently visible part of the -- main trace canvas plus related canvases. -- renderView :: TimelineState -> ViewParameters -> HECs -> TimeSelection -> [Timestamp] -> Rectangle -> IO () renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView} params hecs selection bookmarks rect = do -- Get state information from user-interface components Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea vadj_value <- adjustmentGetValue timelineVAdj prev_view <- readIORef timelinePrevView -- TODO: get rid of this Just Just win <- widgetGetWindow timelineDrawingArea renderWithDrawWindow win $ do let renderToNewSurface = do new_surface <- withTargetSurface $ \surface -> liftIO $ createSimilarSurface surface ContentColor w (height params) renderWith new_surface $ do clearWhite renderTraces params hecs rect return new_surface surface <- case prev_view of Nothing -> renderToNewSurface Just (old_params, surface) | old_params == params -> return surface | width old_params == width params && height old_params == height params -> do if old_params { hadjValue = hadjValue params } == params -- only the hadjValue changed && abs (hadjValue params - hadjValue old_params) < fromIntegral (width params) * scaleValue params -- and the views overlap... then scrollView surface old_params params hecs else do renderWith surface $ do clearWhite; renderTraces params hecs rect return surface | otherwise -> do surfaceFinish surface renderToNewSurface liftIO $ writeIORef timelinePrevView (Just (params, surface)) C.rectangle rect clip setSourceSurface surface 0 (-vadj_value) -- ^^ this is where we adjust for the vertical scrollbar setOperator OperatorSource paint renderBookmarks bookmarks params drawSelection params selection ------------------------------------------------------------------------------- -- Render the bookmarks renderBookmarks :: [Timestamp] -> ViewParameters -> Render () renderBookmarks bookmarks vp@ViewParameters{height} = do setLineWidth 1 setSourceRGBAhex bookmarkColour 1.0 sequence_ [ do moveTo x 0 lineTo x (fromIntegral height) stroke | bookmark <- bookmarks , let x = timestampToView vp bookmark ] ------------------------------------------------------------------------------- drawSelection :: ViewParameters -> TimeSelection -> Render () drawSelection vp@ViewParameters{height} (PointSelection x) = do setLineWidth 3 setOperator OperatorOver setSourceRGBAhex blue 1.0 moveTo xv 0 lineTo xv (fromIntegral height) stroke where xv = timestampToView vp x drawSelection vp@ViewParameters{height} (RangeSelection x x') = do setLineWidth 1.5 setOperator OperatorOver setSourceRGBAhex blue 0.25 rectangle xv 0 (xv' - xv) (fromIntegral height) fill setSourceRGBAhex blue 1.0 moveTo xv 0 lineTo xv (fromIntegral height) moveTo xv' 0 lineTo xv' (fromIntegral height) stroke where xv = timestampToView vp x xv' = timestampToView vp x' ------------------------------------------------------------------------------- -- We currently have two different way of converting from logical units -- (i.e. timestamps in micro-seconds) to device units (i.e. pixels): -- * the first is to set the cairo context to the appropriate scale -- * the second is to do the conversion ourself -- -- While in principle the first is superior due to the simplicity: cairo -- lets us use Double as the logical unit and scaling factor. In practice -- however cairo does not support the full Double range because internally -- it makes use of a 32bit fixed point float format. With very large scaling -- factors we end up with artifacts like lines disappearing. -- -- So sadly we will probably have to convert to using the second method. -- | Use cairo to convert from logical units (timestamps) to device units -- withViewScale :: ViewParameters -> Render () -> Render () withViewScale ViewParameters{scaleValue, hadjValue} inner = do save scale (1/scaleValue) 1.0 translate (-hadjValue) 0 inner restore -- | Manually convert from logical units (timestamps) to device units. -- timestampToView :: ViewParameters -> Timestamp -> Double timestampToView ViewParameters{scaleValue, hadjValue} ts = (fromIntegral ts - hadjValue) / scaleValue ------------------------------------------------------------------------------- -- This function draws the current view of all the HECs with Cairo. renderTraces :: ViewParameters -> HECs -> Rectangle -> Render () renderTraces params@ViewParameters{..} hecs (Rectangle rx _ry rw _rh) = do let scale_rx = fromIntegral rx * scaleValue scale_rw = fromIntegral rw * scaleValue scale_width = fromIntegral width * scaleValue startPos :: Timestamp startPos = fromIntegral $ truncate (scale_rx + hadjValue) endPos :: Timestamp endPos = minimum [ ceiling (hadjValue + scale_width), ceiling (hadjValue + scale_rx + scale_rw), hecLastEventTime hecs ] -- For spark traces, round the start time down, and the end time up, -- to a slice boundary: start = (startPos `div` slice) * slice end = ((endPos + slice) `div` slice) * slice (slice, prof) = treesProfile scaleValue start end hecs withViewScale params $ do -- Render the vertical rulers across all the traces. renderVRulers scaleValue startPos endPos height XScaleTime -- This function helps to render a single HEC. -- Traces are rendered even if the y-region falls outside visible area. -- OTOH, trace rendering function tend to drawn only the visible -- x-region of the graph. let renderTrace trace y = do save translate 0 (fromIntegral y) case trace of TraceHEC c -> let (dtree, etree, _) = hecTrees hecs !! c in renderHEC params startPos endPos (perfNames hecs) (dtree, etree) TraceInstantHEC c -> let (_, etree, _) = hecTrees hecs !! c in renderInstantHEC params startPos endPos (perfNames hecs) etree TraceCreationHEC c -> renderSparkCreation params slice start end (prof !! c) TraceConversionHEC c -> renderSparkConversion params slice start end (prof !! c) TracePoolHEC c -> let maxP = maxSparkPool hecs in renderSparkPool slice start end (prof !! c) maxP TraceHistogram -> renderSparkHistogram params hecs TraceGroup _ -> error "renderTrace" TraceActivity -> renderActivity params hecs startPos endPos restore histTotalHeight = histogramHeight + histXScaleHeight -- Now render all the HECs. zipWithM_ renderTrace viewTraces (traceYPositions labelsMode histTotalHeight viewTraces) ------------------------------------------------------------------------------- -- parameters differ only in the hadjValue, we can scroll ... scrollView :: Surface -> ViewParameters -> ViewParameters -> HECs -> Render Surface scrollView surface old new hecs = do -- scrolling on the same surface seems not to work, I get garbled results. -- Not sure what the best way to do this is. -- let new_surface = surface new_surface <- withTargetSurface $ \surface -> liftIO $ createSimilarSurface surface ContentColor (width new) (height new) renderWith new_surface $ do let scale = scaleValue new old_hadj = hadjValue old new_hadj = hadjValue new w = fromIntegral (width new) h = fromIntegral (height new) off = (old_hadj - new_hadj) / scale -- liftIO $ printf "scrollView: old: %f, new %f, dist = %f (%f pixels)\n" -- old_hadj new_hadj (old_hadj - new_hadj) off -- copy the content from the old surface to the new surface, -- shifted by the appropriate amount. setSourceSurface surface off 0 if old_hadj > new_hadj then rectangle off 0 (w - off) h -- scroll right. else rectangle 0 0 (w + off) h -- scroll left. fill let rect | old_hadj > new_hadj = Rectangle 0 0 (ceiling off) (height new) | otherwise = Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new) case rect of Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) setSourceRGBA 0xffff 0xffff 0xffff 0xffff fill renderTraces new hecs rect surfaceFinish surface return new_surface -------------------------------------------------------------------------------- -- | Update the X scale widget, based on the state of all timeline areas. -- For simplicity, unlike for the traces, we redraw the whole area -- and not only the newly exposed area. This is comparatively very cheap. updateXScaleArea :: TimelineState -> Timestamp -> IO () updateXScaleArea TimelineState{..} lastTx = do -- TODO: get rid of this Just Just win <- widgetGetWindow timelineXScaleArea Rectangle _ _ width _ <- widgetGetAllocation timelineDrawingArea Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea scaleValue <- readIORef scaleIORef -- Snap the view to whole pixels, to avoid blurring. hadjValue0 <- adjustmentGetValue timelineAdj let hadjValue = toWholePixels scaleValue hadjValue0 off y = y + xScaleAreaHeight - 17 renderWithDrawWindow win $ renderXScale scaleValue hadjValue lastTx width off XScaleTime return () -------------------------------------------------------------------------------- -- | Render the Y scale area (an axis, ticks and a label for each graph), -- based on view parameters and hecs. renderYScaleArea :: ViewParameters -> HECs -> DrawingArea -> Render () renderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces, histogramHeight, minterval} hecs yScaleArea = do let maxP = maxSparkPool hecs maxH = fromIntegral $ maxYHistogram hecs Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea drawYScaleArea maxSpkValue maxP maxH minterval (fromIntegral xoffset) 0 labelsMode histogramHeight viewTraces yScaleArea -- | Update the Y scale widget, based on the state of all timeline areas -- and on traces (only for graph labels and relative positions). updateYScaleArea :: TimelineState -> Double -> Double -> Maybe Interval -> Bool -> [Trace] -> IO () updateYScaleArea TimelineState{..} maxSparkPool maxYHistogram minterval labelsMode traces = do -- TODO: get rid of this Just Just win <- widgetGetWindow timelineYScaleArea maxSpkValue <- readIORef maxSpkIORef vadj_value <- adjustmentGetValue timelineVAdj Rectangle _ _ xoffset _ <- widgetGetAllocation timelineYScaleArea renderWithDrawWindow win $ drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval (fromIntegral xoffset) vadj_value labelsMode stdHistogramHeight traces timelineYScaleArea -- | Render the Y scale area, by rendering an axis, ticks and a label -- for each graph-like trace in turn (and only labels for other traces). drawYScaleArea :: Double -> Double -> Double -> Maybe Interval -> Double -> Double -> Bool -> Int -> [Trace] -> DrawingArea -> Render () drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval xoffset vadj_value labelsMode histogramHeight traces yScaleArea = do let histTotalHeight = histogramHeight + histXScaleHeight ys = map (subtract (round vadj_value)) $ traceYPositions labelsMode histTotalHeight traces pcontext <- liftIO $ widgetCreatePangoContext yScaleArea zipWithM_ (drawSingleYScale maxSpkValue maxSparkPool maxYHistogram minterval xoffset histogramHeight pcontext) traces ys -- | Render a single Y scale axis, set of ticks and label, or only a label, -- if the trace is not a graph. drawSingleYScale :: Double -> Double -> Double -> Maybe Interval -> Double -> Int -> PangoContext -> Trace -> Int -> Render () drawSingleYScale maxSpkValue maxSparkPool maxYHistogram minterval xoffset histogramHeight pcontext trace y = do setSourceRGBAhex black 1 move_to (ox, y + 8) layout <- liftIO $ layoutText pcontext (showTrace minterval trace) liftIO $ do layoutSetWidth layout (Just $ xoffset - 50) -- Note: the following does not always work, see the HACK in Timeline.hs layoutSetAttributes layout [AttrSize minBound maxBound 8, AttrFamily minBound maxBound #if MIN_VERSION_gtk3(0,13,0) (T.pack "sans serif")] #else "sans serif"] #endif showLayout layout case traceMaxSpark maxSpkValue maxSparkPool maxYHistogram trace of Just v -> renderYScale (traceHeight histogramHeight trace) 1 v (xoffset - 13) (fromIntegral y) Nothing -> return () -- not a graph-like trace -------------------------------------------------------------------------------- -- | Calculate Y positions of all traces. traceYPositions :: Bool -> Int -> [Trace] -> [Int] traceYPositions labelsMode histTotalHeight traces = scanl (\a b -> a + (height b) + extra + tracePad) firstTraceY traces where height b = traceHeight histTotalHeight b extra = if labelsMode then hecLabelExtra else 0 traceHeight :: Int -> Trace -> Int traceHeight _ TraceHEC{} = hecTraceHeight traceHeight _ TraceInstantHEC{} = hecInstantHeight traceHeight _ TraceCreationHEC{} = hecSparksHeight traceHeight _ TraceConversionHEC{} = hecSparksHeight traceHeight _ TracePoolHEC{} = hecSparksHeight traceHeight h TraceHistogram = h traceHeight _ TraceGroup{} = error "traceHeight" traceHeight _ TraceActivity = activityGraphHeight -- | Calculate the total Y span of all traces. calculateTotalTimelineHeight :: Bool -> Int -> [Trace] -> Int calculateTotalTimelineHeight labelsMode histTotalHeight traces = last (traceYPositions labelsMode histTotalHeight traces) -- | Produce a descriptive label for a trace. showTrace :: Maybe Interval -> Trace -> String showTrace _ (TraceHEC n) = "HEC " ++ show n showTrace _ (TraceInstantHEC n) = "HEC " ++ show n ++ "\nInstant" showTrace _ (TraceCreationHEC n) = "\nHEC " ++ show n ++ "\n\nSpark creation rate (spark/ms)" showTrace _ (TraceConversionHEC n) = "\nHEC " ++ show n ++ "\n\nSpark conversion rate (spark/ms)" showTrace _ (TracePoolHEC n) = "\nHEC " ++ show n ++ "\n\nSpark pool size" showTrace Nothing TraceHistogram = "Sum of spark times\n(" ++ mu ++ "s)" showTrace Just{} TraceHistogram = "Sum of selected spark times\n(" ++ mu ++ "s)" showTrace _ TraceActivity = "Activity" showTrace _ TraceGroup{} = error "Render.showTrace" -- | Calculate the maximal Y value for a graph-like trace, or Nothing. traceMaxSpark :: Double -> Double -> Double -> Trace -> Maybe Double traceMaxSpark maxS _ _ TraceCreationHEC{} = Just $ maxS * 1000 traceMaxSpark maxS _ _ TraceConversionHEC{} = Just $ maxS * 1000 traceMaxSpark _ maxP _ TracePoolHEC{} = Just $ maxP traceMaxSpark _ _ maxH TraceHistogram = Just $ maxH traceMaxSpark _ _ _ _ = Nothing -- | Snap a value to a whole pixel, based on drawing scale. toWholePixels :: Double -> Double -> Double toWholePixels 0 _ = 0 toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale ================================================ FILE: GUI/Timeline/Sparks.hs ================================================ module GUI.Timeline.Sparks ( treesProfile, maxSparkRenderedValue, renderSparkCreation, renderSparkConversion, renderSparkPool, renderSparkHistogram, ) where import GUI.Timeline.Render.Constants import Events.HECs import Events.SparkTree import qualified Events.SparkStats as SparkStats import GUI.Types import GUI.ViewerColours import GUI.Timeline.Ticks import Graphics.Rendering.Cairo import Control.Monad -- Rendering sparks. No approximation nor extrapolation is going on here. -- The sample data, recalculated for a given slice size in sparkProfile, -- before these functions are called, is straightforwardly rendered. maxSparkRenderedValue :: Timestamp -> SparkStats.SparkStats -> Double maxSparkRenderedValue duration c = max (SparkStats.rateDud c + SparkStats.rateCreated c + SparkStats.rateOverflowed c) (SparkStats.rateFizzled c + SparkStats.rateConverted c + SparkStats.rateGCd c) / fromIntegral duration spark_detail :: Int spark_detail = 4 -- in pixels treesProfile :: Double -> Timestamp -> Timestamp -> HECs -> (Timestamp, [[SparkStats.SparkStats]]) treesProfile scale start end hecs = let slice = ceiling (fromIntegral spark_detail * scale) pr trees = let (_, _, stree) = trees in sparkProfile slice start end stree in (slice, map pr (hecTrees hecs)) renderSparkCreation :: ViewParameters -> Timestamp -> Timestamp -> Timestamp -> [SparkStats.SparkStats] -> Render () renderSparkCreation params !slice !start !end prof = do let f1 c = SparkStats.rateCreated c f2 c = f1 c + SparkStats.rateDud c f3 c = f2 c + SparkStats.rateOverflowed c renderSpark params slice start end prof f1 createdConvertedColour f2 fizzledDudsColour f3 overflowedColour renderSparkConversion :: ViewParameters -> Timestamp -> Timestamp -> Timestamp -> [SparkStats.SparkStats] -> Render () renderSparkConversion params !slice !start !end prof = do let f1 c = SparkStats.rateConverted c f2 c = f1 c + SparkStats.rateFizzled c f3 c = f2 c + SparkStats.rateGCd c renderSpark params slice start end prof f1 createdConvertedColour f2 fizzledDudsColour f3 gcColour renderSparkPool :: Timestamp -> Timestamp -> Timestamp -> [SparkStats.SparkStats] -> Double -> Render () renderSparkPool !slice !start !end prof !maxSparkPool = do let f1 c = SparkStats.minPool c f2 c = SparkStats.meanPool c f3 c = SparkStats.maxPool c addSparks outerPercentilesColour maxSparkPool f1 f2 start slice prof addSparks outerPercentilesColour maxSparkPool f2 f3 start slice prof outlineSparks maxSparkPool f2 start slice prof outlineSparks maxSparkPool (const 0) start slice prof renderHRulers hecSparksHeight start end renderSpark :: ViewParameters -> Timestamp -> Timestamp -> Timestamp -> [SparkStats.SparkStats] -> (SparkStats.SparkStats -> Double) -> Color -> (SparkStats.SparkStats -> Double) -> Color -> (SparkStats.SparkStats -> Double) -> Color -> Render () renderSpark ViewParameters{..} slice start end prof f1 c1 f2 c2 f3 c3 = do -- maxSpkValue is maximal spark transition rate, so -- maxSliceSpark is maximal number of sparks per slice for current data. let maxSliceSpark = maxSpkValue * fromIntegral slice outlineSparks maxSliceSpark f3 start slice prof addSparks c1 maxSliceSpark (const 0) f1 start slice prof addSparks c2 maxSliceSpark f1 f2 start slice prof addSparks c3 maxSliceSpark f2 f3 start slice prof renderHRulers hecSparksHeight start end off :: Double -> (SparkStats.SparkStats -> Double) -> SparkStats.SparkStats -> Double off maxSliceSpark f t = let clipped = min 1 (f t / maxSliceSpark) in fromIntegral hecSparksHeight * (1 - clipped) outlineSparks :: Double -> (SparkStats.SparkStats -> Double) -> Timestamp -> Timestamp -> [SparkStats.SparkStats] -> Render () outlineSparks maxSliceSpark f start slice ts = do case ts of [] -> return () ts -> do let dstart = fromIntegral start dslice = fromIntegral slice points = [dstart-dslice/2, dstart+dslice/2 ..] t = zip points (map (off maxSliceSpark f) ts) newPath moveTo (dstart-dslice/2) (snd $ head t) mapM_ (uncurry lineTo) t setSourceRGBAhex black 1.0 setLineWidth 1 stroke addSparks :: Color -> Double -> (SparkStats.SparkStats -> Double) -> (SparkStats.SparkStats -> Double) -> Timestamp -> Timestamp -> [SparkStats.SparkStats] -> Render () addSparks colour maxSliceSpark f0 f1 start slice ts = do case ts of [] -> return () ts -> do -- liftIO $ printf "ts: %s\n" (show (map f1 (ts))) -- liftIO $ printf "off: %s\n" -- (show (map (off maxSliceSpark f1) (ts) :: [Double])) let dstart = fromIntegral start dslice = fromIntegral slice points = [dstart-dslice/2, dstart+dslice/2 ..] t0 = zip points (map (off maxSliceSpark f0) ts) t1 = zip points (map (off maxSliceSpark f1) ts) newPath moveTo (dstart-dslice/2) (snd $ head t1) mapM_ (uncurry lineTo) t1 mapM_ (uncurry lineTo) (reverse t0) setSourceRGBAhex colour 1.0 fill -- | Render the spark duration histogram together with it's X scale and -- horizontal and vertical rulers. renderSparkHistogram :: ViewParameters -> HECs -> Render () renderSparkHistogram ViewParameters{..} hecs = let intDoub :: Integral a => a -> Double intDoub = fromIntegral inR :: Timestamp -> Bool inR = case minterval of Nothing -> const True Just (from, to) -> \ t -> t >= from && t <= to -- TODO: if xs is sorted, we can slightly optimize the filtering inRange :: [(Timestamp, Int, Timestamp)] -> [(Int, (Timestamp, Int))] inRange xs = [(logdur, (dur, 1)) | (start, logdur, dur) <- xs, inR start] xs = durHistogram hecs bars :: [(Double, Double, Int)] bars = [(intDoub t, intDoub height, count) | (t, (height, count)) <- histogramCounts $ inRange xs] -- TODO: data processing up to this point could be done only at interval -- changes (keeping @bars@ in ViewParameters and in probably also in IOref. -- The rest has to be recomputed at each redraw, because resizing -- the window modifies the way the graph is drawn. -- TODO: at least pull the above out into a separate function. -- Define general parameters for visualization. width' = width - 5 -- add a little margin on the right (w, h) = (intDoub width', intDoub histogramHeight) (minX, maxX, maxY) = (intDoub (minXHistogram hecs), intDoub (maxXHistogram hecs), intDoub (maxYHistogram hecs)) nBars = max 5 (maxX - minX + 1) segmentWidth = w / nBars -- Define parameters for drawing the bars. gapWidth = 10 barWidth = segmentWidth - gapWidth sX x = gapWidth / 2 + (x - minX) * segmentWidth sY y = y * h / (max 2 maxY) plotRect (x, y, count) = do -- Draw a single bar. setSourceRGBAhex blue 1.0 rectangle (sX x) (sY maxY) barWidth (sY (-y)) fillPreserve setSourceRGBA 0 0 0 0.7 setLineWidth 1 stroke -- Print the number of sparks in the bar. selectFontFace "sans serif" FontSlantNormal FontWeightNormal setFontSize 10 let above = sY (-y) > -20 if above then setSourceRGBAhex black 1.0 else setSourceRGBAhex white 1.0 moveTo (sX x + 3) (sY (maxY - y) + if above then -3 else 13) showText (show count) drawHist = forM_ bars plotRect -- Define parameters for X scale. off y = 16 - y xScaleMode = XScaleLog minX segmentWidth drawXScale = renderXScale 1 0 maxBound width' off xScaleMode -- Define parameters for vertical rulers. nB = round nBars mult | nB <= 7 = 1 | nB `mod` 5 == 0 = 5 | nB `mod` 4 == 0 = 4 | nB `mod` 3 == 0 = 3 | nB `mod` 2 == 0 = nB `div` 2 | otherwise = nB drawVRulers = renderVRulers 1 0 (fromIntegral width') histogramHeight (XScaleLog undefined (segmentWidth * fromIntegral mult)) -- Define the horizontal rulers call. drawHRulers = renderHRulers histogramHeight 0 (fromIntegral width') in do -- Start the drawing by wiping out timeline vertical rules -- (for PNG/PDF that require clear, transparent background) save translate hadjValue 0 scale scaleValue 1 rectangle 0 (fromIntegral $ - tracePad) (fromIntegral width) (fromIntegral $ histogramHeight + histXScaleHeight + 2 * tracePad) setSourceRGBAhex white 1 op <- getOperator setOperator OperatorAtop -- TODO: fixme: it paints white vertical rulers fill setOperator op -- Draw the bars. drawHist -- Draw the rulers on top of the bars (they are partially transparent). drawVRulers drawHRulers -- Move to the bottom and draw the X scale. The Y scale is drawn -- independently in another drawing area. translate 0 (fromIntegral histogramHeight) drawXScale restore ================================================ FILE: GUI/Timeline/Ticks.hs ================================================ {-# LANGUAGE CPP #-} module GUI.Timeline.Ticks ( renderVRulers, XScaleMode(..), renderXScaleArea, renderXScale, renderHRulers, renderYScale, mu, deZero, ) where import Events.HECs import GUI.Types import GUI.Timeline.CairoDrawing import GUI.ViewerColours import Graphics.Rendering.Cairo import Control.Monad import Text.Printf -- Minor, semi-major and major ticks are drawn and the absolute period of -- the ticks is determined by the zoom level. -- There are ten minor ticks to a major tick and a semi-major tick -- occurs half way through a major tick (overlapping the corresponding -- minor tick). -- The timestamp values are in micro-seconds (1e-6) i.e. -- a timestamp value of 1000000 represents 1s. The position on the drawing -- canvas is in milliseconds (ms) (1e-3). -- scaleValue is used to divide a timestamp value to yield a pixel value. -- NOTE: the code below will crash if the timestampFor100Pixels is 0. -- The zoom factor should be controlled to ensure that this never happens. -- | Render vertical rulers (solid translucent lines), matching scale ticks. renderVRulers :: Double -> Timestamp -> Timestamp -> Int -> XScaleMode -> Render() renderVRulers scaleValue startPos endPos height xScaleMode = do let timestampFor100Pixels = truncate (100 * scaleValue) snappedTickDuration :: Timestamp snappedTickDuration = 10 ^ max 0 (truncate (logBase 10 (fromIntegral timestampFor100Pixels) :: Double)) tickWidthInPixels :: Double tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue firstTick :: Timestamp firstTick = snappedTickDuration * (startPos `div` snappedTickDuration) setSourceRGBAhex black 0.15 setLineWidth scaleValue case xScaleMode of XScaleTime -> drawVRulers tickWidthInPixels scaleValue (fromIntegral $ firstTick + snappedTickDuration) (fromIntegral snappedTickDuration) endPos height (1 + fromIntegral (startPos `div` snappedTickDuration)) XScaleLog _ dx -> drawVRulers 1e1000 1 dx dx endPos height 1 -- | Render a single vertical ruler and then recurse. drawVRulers :: Double -> Double -> Double -> Double -> Timestamp -> Int -> Int -> Render () drawVRulers tickWidthInPixels scaleValue pos incr endPos height i = if floor pos <= endPos then do when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do draw_line (veryRoundedPos, 0) (veryRoundedPos, height) drawVRulers tickWidthInPixels scaleValue (pos + incr) incr endPos height (i + 1) else return () where -- Hack to sync with drawXTicks. veryRoundedPos = round $ scaleValue * fromIntegral (floor (fromIntegral (round pos) / scaleValue)) atMidTick = i `mod` 5 == 0 atMajorTick = i `mod` 10 == 0 -- | Render the X scale, based on view parameters and hecs. renderXScaleArea :: ViewParameters -> HECs -> Render () renderXScaleArea ViewParameters{width, scaleValue, hadjValue, xScaleAreaHeight} hecs = let lastTx = hecLastEventTime hecs off y = y + xScaleAreaHeight - 17 in renderXScale scaleValue hadjValue lastTx width off XScaleTime data XScaleMode = XScaleTime | XScaleLog Double Double deriving Eq -- | Render the X (vertical) scale: render X axis and call ticks rendering. -- TODO: refactor common parts with renderVRulers, in particular to expose -- that ruler positions match tick positions. renderXScale :: Double -> Double -> Timestamp -> Int -> (Int -> Int) -> XScaleMode -> Render () renderXScale scaleValue hadjValue lastTx width off xScaleMode = do let scale_width = fromIntegral width * scaleValue startPos :: Timestamp startPos = floor hadjValue startLine :: Timestamp startLine = floor $ hadjValue / scaleValue endPos :: Timestamp endPos = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx) endLine :: Timestamp endLine = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx) / scaleValue save translate (- fromIntegral startLine) 0 selectFontFace "sans serif" FontSlantNormal FontWeightNormal setFontSize 12 setSourceRGBAhex black 1.0 -- setLineCap LineCapRound -- TODO: breaks rendering currently (see BrokenX.png) setLineWidth 1.0 draw_line (startLine, off 16) (endLine, off 16) let tFor100Pixels = truncate (100 * scaleValue) snappedTickDuration :: Timestamp snappedTickDuration = 10 ^ max 0 (truncate (logBase 10 (fromIntegral tFor100Pixels) :: Double)) tickWidthInPixels :: Double tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue firstTick :: Timestamp firstTick = snappedTickDuration * (startPos `div` snappedTickDuration) case xScaleMode of XScaleTime -> drawXTicks tickWidthInPixels scaleValue (fromIntegral firstTick) (fromIntegral snappedTickDuration) endPos off xScaleMode (fromIntegral (startPos `div` snappedTickDuration)) XScaleLog _ segmentWidth -> drawXTicks 1e1000 1 0 segmentWidth endPos off xScaleMode 0 restore -- | Render a single X scale tick and then recurse. drawXTicks :: Double -> Double -> Double -> Double -> Timestamp -> (Int -> Int) -> XScaleMode -> Int -> Render () drawXTicks tickWidthInPixels scaleValue pos incr endPos off xScaleMode i = if floor pos <= endPos then do when (pos /= 0 || xScaleMode == XScaleTime) $ draw_line (floor $ fromIntegral x1 / scaleValue, off 16) (floor $ fromIntegral x1 / scaleValue, off (16 - tickLength)) when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do tExtent <- textExtents tickTimeText let tExtentWidth = textExtentsWidth tExtent move_to (floor $ fromIntegral textPosX / scaleValue, textPosY) when (floor (pos + incr) <= endPos && (tExtentWidth + tExtentWidth / 3 < width || atMajorTick)) $ showText tickTimeText drawXTicks tickWidthInPixels scaleValue (pos + incr) incr endPos off xScaleMode (i+1) else return () where atMidTick = xScaleMode == XScaleTime && i `mod` 5 == 0 atMajorTick = xScaleMode == XScaleTime && i `mod` 10 == 0 (textPosX, textPosY) = if xScaleMode == XScaleTime then (x1 + ceiling (scaleValue * 3), off (-3)) else (x1 + ceiling (scaleValue * 2), tickLength + 13) tickLength | atMajorTick = 16 | atMidTick = 10 | otherwise = if xScaleMode == XScaleTime then 6 else 8 posTime = case xScaleMode of XScaleTime -> round pos XScaleLog minX _ -> round $ 2 ** (minX + pos / incr) tickTimeText = showMultiTime posTime width = if atMidTick then 5 * tickWidthInPixels else tickWidthInPixels -- We cheat at pos 0, to avoid half covering the tick by the grey label area. lineWidth = scaleValue x1 = round $ if pos == 0 && xScaleMode == XScaleTime then lineWidth else pos -- | Display the micro-second time unit with an appropriate suffix -- depending on the actual time value. -- For times < 1e-6 the time is shown in micro-seconds. -- For times >= 1e-6 and < 0.1 seconds the time is shown in ms -- For times >= 0.5 seconds the time is shown in seconds showMultiTime :: Timestamp -> String showMultiTime pos = if pos == 0 then "0s" else if pos < 1000 then -- Show time as micro-seconds for times < 1e-6 reformatMS posf ++ (mu ++ "s") -- microsecond (1e-6s). else if pos < 100000 then -- Show miliseonds for time < 0.1s reformatMS (posf / 1000) ++ "ms" -- miliseconds 1e-3 else -- Show time in seconds reformatMS (posf / 1000000) ++ "s" where posf :: Double posf = fromIntegral pos reformatMS :: Show a => a -> String reformatMS pos = deZero (show pos) ------------------------------------------------------------------------------- -- | Render horizontal rulers (dashed translucent lines), -- matching scale ticks (visible in the common @incr@ value and starting at 0). renderHRulers :: Int -> Timestamp -> Timestamp -> Render () renderHRulers hecSparksHeight start end = do let dstart = fromIntegral start dend = fromIntegral end incr = fromIntegral hecSparksHeight / 10 -- dashed lines across the graphs setSourceRGBAhex black 0.15 setLineWidth 1 save forM_ [0, 5] $ \h -> do let y = h * incr moveTo dstart y lineTo dend y stroke restore -- | Render one of the Y (horizontal) scales: render the Y axis -- and call ticks rendering. renderYScale :: Int -> Double -> Double -> Double -> Double -> Render () renderYScale hecSparksHeight scaleValue maxSpark xoffset yoffset = do let -- This is slightly off (by 1% at most), but often avoids decimal dot: maxS = if maxSpark < 100 then maxSpark -- too small, would be visible on screen else fromIntegral (2 * (ceiling maxSpark ` div` 2)) incr = fromIntegral hecSparksHeight / 10 save newPath moveTo (xoffset + 12) yoffset lineTo (xoffset + 12) (yoffset + fromIntegral hecSparksHeight) setSourceRGBAhex black 1.0 setLineCap LineCapRound setLineWidth 1.0 -- TODO: it's not really 1 pixel, due to the scale stroke selectFontFace "sans serif" FontSlantNormal FontWeightNormal setFontSize 12 scale scaleValue 1.0 setLineWidth 0.5 -- TODO: it's not really 0.5 pixels, due to the scale drawYTicks maxS 0 incr xoffset yoffset 0 restore -- | Render a single Y scale tick and then recurse. drawYTicks :: Double -> Double -> Double -> Double -> Double -> Int -> Render () drawYTicks maxS pos incr xoffset yoffset i = if i <= 10 then do -- TODO: snap to pixels, currently looks semi-transparent moveTo (xoffset + 12) (yoffset + majorTick - pos) lineTo (xoffset + 12 - tickLength) (yoffset + majorTick - pos) stroke when (atMajorTick || atMidTick) $ do tExtent <- textExtents tickText (fewPixels, yPix) <- deviceToUserDistance 3 4 moveTo (xoffset - textExtentsWidth tExtent - fewPixels) (yoffset + majorTick - pos + yPix) when (atMidTick || atMajorTick) $ showText tickText drawYTicks maxS (pos + incr) incr xoffset yoffset (i + 1) else return () where atMidTick = i `mod` 5 == 0 atMajorTick = i `mod` 10 == 0 majorTick = 10 * incr tickText = reformatV (fromIntegral i * maxS / 10) tickLength | atMajorTick = 11 | atMidTick = 9 | otherwise = 6 reformatV :: Double -> String reformatV v = if v < 0.01 && v > 0 then eps else deZero (printf "%.2f" v) ------------------------------------------------------------------------------- -- | The \'micro\' symbol. mu :: String #if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1) -- this version of cairo doesn't handle Unicode properly. -- Thus, we do the encoding by hand: mu = "\194\181" #else -- Haskell cairo bindings 0.12.1 have proper Unicode support mu = "\x00b5" #endif -- | The \'epsilon\' symbol. eps :: String #if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1) -- this version of cairo doesn't handle Unicode properly. -- Thus, we do the encoding by hand: eps = "\206\181" #else -- Haskell cairo bindings 0.12.1 have proper Unicode support eps = "\x03b5" #endif -- | Remove all meaningless trailing zeroes. deZero :: String -> String deZero s | '.' `elem` s = reverse . dropWhile (=='.') . dropWhile (=='0') . reverse $ s | otherwise = s ================================================ FILE: GUI/Timeline/Types.hs ================================================ module GUI.Timeline.Types ( TimelineState(..), TimeSelection(..), ) where import GUI.Types import Graphics.UI.Gtk import Graphics.Rendering.Cairo import Data.IORef ----------------------------------------------------------------------------- data TimelineState = TimelineState { timelineDrawingArea :: DrawingArea, timelineYScaleArea :: DrawingArea, timelineXScaleArea :: DrawingArea, timelineAdj :: Adjustment, timelineVAdj :: Adjustment, timelinePrevView :: IORef (Maybe (ViewParameters, Surface)), -- This scale value is used to map a micro-second value to a pixel unit. -- To convert a timestamp value to a pixel value, multiply it by scale. -- To convert a pixel value to a micro-second value, divide it by scale. scaleIORef :: IORef Double, -- Maximal number of sparks/slice measured after every zoom to fit. maxSpkIORef :: IORef Double } data TimeSelection = PointSelection Timestamp | RangeSelection Timestamp Timestamp ----------------------------------------------------------------------------- ================================================ FILE: GUI/Timeline.hs ================================================ {-# LANGUAGE CPP #-} module GUI.Timeline ( TimelineView, timelineViewNew, TimelineViewActions(..), timelineSetBWMode, timelineSetLabelsMode, timelineGetViewParameters, timelineGetYScaleArea, timelineWindowSetHECs, timelineWindowSetTraces, timelineWindowSetBookmarks, timelineSetSelection, TimeSelection(..), timelineZoomIn, timelineZoomOut, timelineZoomToFit, timelineScrollLeft, timelineScrollRight, timelineScrollToBeginning, timelineScrollToEnd, timelineCentreOnCursor, ) where import GUI.Types import GUI.Timeline.Types import GUI.Timeline.Motion import GUI.Timeline.Render import GUI.Timeline.Render.Constants import Events.HECs import Graphics.UI.Gtk import Data.IORef import Data.Ord import Control.Monad import Control.Monad.Trans import qualified Data.Text as T ----------------------------------------------------------------------------- -- The CPUs view data TimelineView = TimelineView { timelineState :: TimelineState, hecsIORef :: IORef (Maybe HECs), tracesIORef :: IORef [Trace], bookmarkIORef :: IORef [Timestamp], selectionRef :: IORef TimeSelection, labelsModeIORef :: IORef Bool, bwmodeIORef :: IORef Bool, cursorIBeam :: Cursor, cursorMove :: Cursor } data TimelineViewActions = TimelineViewActions { timelineViewSelectionChanged :: TimeSelection -> IO () } -- | Draw some parts of the timeline in black and white rather than colour. timelineSetBWMode :: TimelineView -> Bool -> IO () timelineSetBWMode timelineWin bwmode = do writeIORef (bwmodeIORef timelineWin) bwmode widgetQueueDraw (timelineDrawingArea (timelineState timelineWin)) timelineSetLabelsMode :: TimelineView -> Bool -> IO () timelineSetLabelsMode timelineWin labelsMode = do writeIORef (labelsModeIORef timelineWin) labelsMode widgetQueueDraw (timelineDrawingArea (timelineState timelineWin)) updateTimelineVScroll timelineWin timelineGetViewParameters :: TimelineView -> IO ViewParameters timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef, timelineState=TimelineState{..}} = do Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea scaleValue <- readIORef scaleIORef maxSpkValue <- readIORef maxSpkIORef -- snap the view to whole pixels, to avoid blurring hadj_value0 <- adjustmentGetValue timelineAdj let hadj_value = toWholePixels scaleValue hadj_value0 traces <- readIORef tracesIORef bwmode <- readIORef bwmodeIORef labelsMode <- readIORef labelsModeIORef Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea let histTotalHeight = stdHistogramHeight + histXScaleHeight timelineHeight = calculateTotalTimelineHeight labelsMode histTotalHeight traces return ViewParameters { width = w , height = timelineHeight , viewTraces = traces , hadjValue = hadj_value , scaleValue = scaleValue , maxSpkValue = maxSpkValue , detail = 3 --for now , bwMode = bwmode , labelsMode = labelsMode , histogramHeight = stdHistogramHeight , minterval = Nothing , xScaleAreaHeight = xScaleAreaHeight } timelineGetYScaleArea :: TimelineView -> DrawingArea timelineGetYScaleArea timelineWin = timelineYScaleArea $ timelineState timelineWin timelineWindowSetHECs :: TimelineView -> Maybe HECs -> IO () timelineWindowSetHECs timelineWin@TimelineView{..} mhecs = do writeIORef hecsIORef mhecs zoomToFit timelineState mhecs timelineParamsChanged timelineWin timelineWindowSetTraces :: TimelineView -> [Trace] -> IO () timelineWindowSetTraces timelineWin@TimelineView{tracesIORef} traces = do writeIORef tracesIORef traces timelineParamsChanged timelineWin timelineWindowSetBookmarks :: TimelineView -> [Timestamp] -> IO () timelineWindowSetBookmarks timelineWin@TimelineView{bookmarkIORef} bookmarks = do writeIORef bookmarkIORef bookmarks timelineParamsChanged timelineWin ----------------------------------------------------------------------------- timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView timelineViewNew builder actions = do let getWidget cast = builderGetObject builder cast timelineViewport <- getWidget castToWidget "timeline_viewport" timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea" timelineYScaleArea <- getWidget castToDrawingArea "timeline_yscale_area" timelineXScaleArea <- getWidget castToDrawingArea "timeline_xscale_area" timelineHScrollbar <- getWidget castToHScrollbar "timeline_hscroll" timelineVScrollbar <- getWidget castToVScrollbar "timeline_vscroll" timelineAdj <- rangeGetAdjustment timelineHScrollbar timelineVAdj <- rangeGetAdjustment timelineVScrollbar -- HACK: layoutSetAttributes does not work for \mu, so let's work around fd <- fontDescriptionNew fontDescriptionSetSize fd 8 fontDescriptionSetFamily fd "sans serif" widgetModifyFont timelineYScaleArea (Just fd) cursorIBeam <- cursorNew Xterm cursorMove <- cursorNew Fleur hecsIORef <- newIORef Nothing tracesIORef <- newIORef [] bookmarkIORef <- newIORef [] scaleIORef <- newIORef 0 maxSpkIORef <- newIORef 0 selectionRef <- newIORef (PointSelection 0) bwmodeIORef <- newIORef False labelsModeIORef <- newIORef False timelinePrevView <- newIORef Nothing let timelineState = TimelineState{..} timelineWin = TimelineView{..} ------------------------------------------------------------------------ -- Redrawing labelDrawingArea timelineYScaleArea `on` draw $ liftIO $ do maybeEventArray <- readIORef hecsIORef -- Check to see if an event trace has been loaded case maybeEventArray of Nothing -> return () Just hecs -> do traces <- readIORef tracesIORef labelsMode <- readIORef labelsModeIORef let maxP = maxSparkPool hecs maxH = fromIntegral (maxYHistogram hecs) updateYScaleArea timelineState maxP maxH Nothing labelsMode traces return () ------------------------------------------------------------------------ -- Redrawing XScaleArea timelineXScaleArea `on` draw $ liftIO $ do maybeEventArray <- readIORef hecsIORef -- Check to see if an event trace has been loaded case maybeEventArray of Nothing -> return () Just hecs -> do let lastTx = hecLastEventTime hecs updateXScaleArea timelineState lastTx return () ------------------------------------------------------------------------ -- Allow mouse wheel to be used for zoom in/out on timelineViewport scrollEvent $ tryEvent $ do dir <- eventScrollDirection mods <- eventModifier (x, _y) <- eventCoordinates x_ts <- liftIO $ viewPointToTime timelineWin x liftIO $ case (dir,mods) of (ScrollUp, [Control]) -> zoomIn timelineState x_ts (ScrollDown, [Control]) -> zoomOut timelineState x_ts (ScrollUp, []) -> vscrollUp timelineState (ScrollDown, []) -> vscrollDown timelineState _ -> return () ------------------------------------------------------------------------ -- Mouse button and selection widgetSetCursor timelineDrawingArea (Just cursorIBeam) mouseStateVar <- newIORef None let withMouseState action = liftIO $ do st <- readIORef mouseStateVar st' <- action st writeIORef mouseStateVar st' on timelineDrawingArea buttonPressEvent $ do (x,_y) <- eventCoordinates button <- eventButton liftIO $ widgetGrabFocus timelineViewport withMouseState (\st -> mousePress timelineWin st button x) return False on timelineDrawingArea buttonReleaseEvent $ do (x,_y) <- eventCoordinates button <- eventButton withMouseState (\st -> mouseRelease timelineWin actions st button x) return False widgetAddEvents timelineDrawingArea [Button1MotionMask, Button2MotionMask] on timelineDrawingArea motionNotifyEvent $ do (x, _y) <- eventCoordinates withMouseState (\st -> mouseMove timelineWin st x) return False on timelineDrawingArea grabBrokenEvent $ do withMouseState (mouseMoveCancel timelineWin actions) return False -- Escape key to cancel selection or drag on timelineViewport keyPressEvent $ do let liftNoMouse a = let whenNoMouse None = a >> return None whenNoMouse st = return st in withMouseState whenNoMouse >> return True keyName <- eventKeyName keyVal <- eventKeyVal #if MIN_VERSION_gtk3(0,13,0) case (T.unpack keyName, keyToChar keyVal, keyVal) of #else case (keyName, keyToChar keyVal, keyVal) of #endif ("Right", _, _) -> liftNoMouse $ scrollRight timelineState ("Left", _, _) -> liftNoMouse $ scrollLeft timelineState (_ , Just '+', _) -> liftNoMouse $ timelineZoomIn timelineWin (_ , Just '-', _) -> liftNoMouse $ timelineZoomOut timelineWin (_, _, 0xff1b) -> withMouseState (mouseMoveCancel timelineWin actions) >> return True _ -> return False ------------------------------------------------------------------------ -- Scroll bars onValueChanged timelineAdj $ queueRedrawTimelines timelineState onValueChanged timelineVAdj $ queueRedrawTimelines timelineState onAdjChanged timelineAdj $ queueRedrawTimelines timelineState onAdjChanged timelineVAdj $ queueRedrawTimelines timelineState ------------------------------------------------------------------------ -- Redrawing on timelineDrawingArea draw $ do liftIO $ do maybeEventArray <- readIORef hecsIORef -- Check to see if an event trace has been loaded case maybeEventArray of Nothing -> return () Just hecs -> do params <- timelineGetViewParameters timelineWin -- render either the whole height of the timeline, or the window, whichever -- is larger (this just ensure we fill the background if the timeline is -- smaller than the window). (Rectangle _ _ w h)<- widgetGetAllocation timelineDrawingArea let params' = params { height = max (height params) h } selection <- readIORef selectionRef bookmarks <- readIORef bookmarkIORef renderView timelineState params' hecs selection bookmarks (Rectangle 0 0 w h) return () on timelineDrawingArea configureEvent $ do liftIO $ configureTimelineDrawingArea timelineWin return True return timelineWin ------------------------------------------------------------------------------- viewPointToTime :: TimelineView -> Double -> IO Timestamp viewPointToTime TimelineView{timelineState=TimelineState{..}} x = do hadjValue <- adjustmentGetValue timelineAdj scaleValue <- readIORef scaleIORef let ts = round (max 0 (hadjValue + x * scaleValue)) return $! ts viewPointToTimeNoClamp :: TimelineView -> Double -> IO Double viewPointToTimeNoClamp TimelineView{timelineState=TimelineState{..}} x = do hadjValue <- adjustmentGetValue timelineAdj scaleValue <- readIORef scaleIORef let ts = hadjValue + x * scaleValue return $! ts viewRangeToTimeRange :: TimelineView -> (Double, Double) -> IO (Timestamp, Timestamp) viewRangeToTimeRange view (x, x') = do let xMin = min x x' xMax = max x x' xv <- viewPointToTime view xMin xv' <- viewPointToTime view xMax return (xv, xv') ------------------------------------------------------------------------------- -- Update the internal state and the timeline view after changing which -- traces are displayed, or the order of traces. queueRedrawTimelines :: TimelineState -> IO () queueRedrawTimelines TimelineState{..} = do widgetQueueDraw timelineDrawingArea widgetQueueDraw timelineYScaleArea widgetQueueDraw timelineXScaleArea --FIXME: we are still unclear about which state changes involve which updates timelineParamsChanged :: TimelineView -> IO () timelineParamsChanged timelineWin@TimelineView{timelineState} = do queueRedrawTimelines timelineState updateTimelineVScroll timelineWin configureTimelineDrawingArea :: TimelineView -> IO () configureTimelineDrawingArea timelineWin@TimelineView{timelineState} = do updateTimelineVScroll timelineWin updateTimelineHPageSize timelineState updateTimelineVScroll :: TimelineView -> IO () updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=TimelineState{..}} = do traces <- readIORef tracesIORef labelsMode <- readIORef labelsModeIORef let histTotalHeight = stdHistogramHeight + histXScaleHeight h = calculateTotalTimelineHeight labelsMode histTotalHeight traces Rectangle _ _ _ winh <- widgetGetAllocation timelineDrawingArea let winh' = fromIntegral winh; h' = fromIntegral h adjustmentSetLower timelineVAdj 0 adjustmentSetUpper timelineVAdj h' val <- adjustmentGetValue timelineVAdj when (val > h') $ adjustmentSetValue timelineVAdj h' set timelineVAdj [ adjustmentPageSize := winh', adjustmentStepIncrement := winh' * 0.1, adjustmentPageIncrement := winh' * 0.9 ] -- when the drawing area is resized, we update the page size of the -- adjustment. Everything else stays the same: we don't scale or move -- the view at all. updateTimelineHPageSize :: TimelineState -> IO () updateTimelineHPageSize TimelineState{..} = do Rectangle _ _ winw _ <- widgetGetAllocation timelineDrawingArea scaleValue <- readIORef scaleIORef adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue) ------------------------------------------------------------------------------- -- Cursor / selection and mouse interaction timelineSetSelection :: TimelineView -> TimeSelection -> IO (Maybe TimeSelection) timelineSetSelection TimelineView{..} selection = do mhecs <- readIORef hecsIORef case mhecs >>= (adjustSelection selection . hecLastEventTime) of Nothing -> return Nothing Just selection' -> do writeIORef selectionRef selection' queueRedrawTimelines timelineState return $ Just selection' where -- Prevent selections that are out of bounds. adjustSelection (PointSelection timestamp) lastTx | timestamp < 0 || timestamp > lastTx = Nothing | otherwise = Just $ PointSelection timestamp adjustSelection (RangeSelection start end) lastTx | start < 0 && end < 0 || start > lastTx && end > lastTx = Nothing | otherwise = Just $ RangeSelection (clampSelection lastTx start) (clampSelection lastTx end) clampSelection lastTx = clamp (0, lastTx) -- little state machine data MouseState = None | PressLeft !Double -- left mouse button is currently pressed -- but not over threshold for dragging | DragLeft !Double -- dragging with left mouse button | DragMiddle !Double !Double -- dragging with middle mouse button mousePress :: TimelineView -> MouseState -> MouseButton -> Double -> IO MouseState mousePress view@TimelineView{..} state button x = case (state, button) of (None, LeftButton) -> do xv <- viewPointToTime view x -- update the view without notifying the client selection <- timelineSetSelection view (PointSelection xv) case selection of Nothing -> return None Just _ -> return (PressLeft x) (None, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorMove) v <- adjustmentGetValue timelineAdj return (DragMiddle x v) _ -> return state where TimelineState{timelineAdj, timelineDrawingArea} = timelineState mouseMove :: TimelineView -> MouseState -> Double -> IO MouseState mouseMove view@TimelineView{..} state x = case state of None -> return None PressLeft x0 | dragThreshold -> mouseMove view (DragLeft x0) x | otherwise -> return (PressLeft x0) where dragThreshold = abs (x - x0) > 5 DragLeft x0 -> do (xv, xv') <- viewRangeToTimeRange view (x0, x) -- update the view without notifying the client selection <- timelineSetSelection view (RangeSelection xv xv') case selection of Nothing -> return None Just _ -> return (DragLeft x0) DragMiddle x0 v -> do xv <- viewPointToTimeNoClamp view x xv' <- viewPointToTimeNoClamp view x0 scrollTo timelineState (v + (xv' - xv)) return (DragMiddle x0 v) mouseMoveCancel :: TimelineView -> TimelineViewActions -> MouseState -> IO MouseState mouseMoveCancel view@TimelineView{..} TimelineViewActions{..} state = case state of PressLeft x0 -> do xv <- viewPointToTime view x0 timelineViewSelectionChanged (PointSelection xv) return None DragLeft x0 -> do xv <- viewPointToTime view x0 timelineViewSelectionChanged (PointSelection xv) return None DragMiddle _ _ -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam) return None None -> return None where TimelineState{timelineDrawingArea} = timelineState mouseRelease :: TimelineView -> TimelineViewActions -> MouseState -> MouseButton -> Double -> IO MouseState mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x = case (state, button) of (PressLeft x0, LeftButton) -> do xv <- viewPointToTime view x0 timelineViewSelectionChanged (PointSelection xv) return None (DragLeft x0, LeftButton) -> do (xv, xv') <- viewRangeToTimeRange view (x0, x) timelineViewSelectionChanged (RangeSelection xv xv') return None (DragMiddle{}, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam) return None _ -> return state where TimelineState{timelineDrawingArea} = timelineState widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO () widgetSetCursor widget cursor = do #if MIN_VERSION_gtk3(0,12,1) -- TODO: get rid of this Just Just dw <- widgetGetWindow widget drawWindowSetCursor dw cursor #endif return () ------------------------------------------------------------------------------- timelineZoomIn :: TimelineView -> IO () timelineZoomIn TimelineView{..} = do selection <- readIORef selectionRef zoomIn timelineState (selectionPoint selection) timelineZoomOut :: TimelineView -> IO () timelineZoomOut TimelineView{..} = do selection <- readIORef selectionRef zoomOut timelineState (selectionPoint selection) timelineZoomToFit :: TimelineView -> IO () timelineZoomToFit TimelineView{..} = do mhecs <- readIORef hecsIORef zoomToFit timelineState mhecs timelineScrollLeft :: TimelineView -> IO () timelineScrollLeft TimelineView{timelineState} = scrollLeft timelineState timelineScrollRight :: TimelineView -> IO () timelineScrollRight TimelineView{timelineState} = scrollRight timelineState timelineScrollToBeginning :: TimelineView -> IO () timelineScrollToBeginning TimelineView{timelineState} = scrollToBeginning timelineState timelineScrollToEnd :: TimelineView -> IO () timelineScrollToEnd TimelineView{timelineState} = scrollToEnd timelineState -- This one is especially evil since it relies on a shared cursor IORef timelineCentreOnCursor :: TimelineView -> IO () timelineCentreOnCursor TimelineView{..} = do selection <- readIORef selectionRef centreOnCursor timelineState (selectionPoint selection) selectionPoint :: TimeSelection -> Timestamp selectionPoint (PointSelection x) = x selectionPoint (RangeSelection x x') = midpoint x x' where midpoint a b = a + (b - a) `div` 2 ================================================ FILE: GUI/TraceView.hs ================================================ module GUI.TraceView ( TraceView, traceViewNew, TraceViewActions(..), traceViewSetHECs, traceViewGetTraces, ) where import Events.HECs import GUI.Types import Graphics.UI.Gtk import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat import Data.Tree -- | Abstract trace view object. -- data TraceView = TraceView { tracesStore :: TreeStore (Trace, Visibility) } data Visibility = Visible | Hidden | MixedVisibility deriving Eq -- | The actions to take in response to TraceView events. -- data TraceViewActions = TraceViewActions { traceViewTracesChanged :: [Trace] -> IO () } traceViewNew :: Builder -> TraceViewActions -> IO TraceView traceViewNew builder actions = do tracesTreeView <- builderGetObject builder castToTreeView "traces_tree" tracesStore <- treeStoreNew [] traceColumn <- treeViewColumnNew textcell <- cellRendererTextNew togglecell <- cellRendererToggleNew let traceview = TraceView {..} treeViewColumnPackStart traceColumn textcell True treeViewColumnPackStart traceColumn togglecell False treeViewAppendColumn tracesTreeView traceColumn Compat.treeViewSetModel tracesTreeView (Just tracesStore) cellLayoutSetAttributes traceColumn textcell tracesStore $ \(tr, _) -> [ cellText := renderTrace tr ] cellLayoutSetAttributes traceColumn togglecell tracesStore $ \(_, vis) -> [ cellToggleActive := vis == Visible , cellToggleInconsistent := vis == MixedVisibility ] on togglecell cellToggled $ \str -> do let path = stringToTreePath str Node (trace, visibility) subtrees <- treeStoreGetTree tracesStore path let visibility' = invertVisibility visibility treeStoreSetValue tracesStore path (trace, visibility') updateChildren tracesStore path subtrees visibility' updateParents tracesStore (init path) traceViewTracesChanged actions =<< traceViewGetTraces traceview return traceview where renderTrace (TraceHEC hec) = "HEC " ++ show hec renderTrace (TraceInstantHEC hec) = "HEC " ++ show hec renderTrace (TraceCreationHEC hec) = "HEC " ++ show hec renderTrace (TraceConversionHEC hec) = "HEC " ++ show hec renderTrace (TracePoolHEC hec) = "HEC " ++ show hec renderTrace (TraceHistogram) = "Spark Histogram" renderTrace (TraceGroup label) = label renderTrace (TraceActivity) = "Activity Profile" updateChildren tracesStore path subtrees visibility' = sequence_ [ do treeStoreSetValue tracesStore path' (trace, visibility') updateChildren tracesStore path' subtrees' visibility' | (Node (trace, _) subtrees', n) <- zip subtrees [0..] , let path' = path ++ [n] ] updateParents :: TreeStore (Trace, Visibility) -> TreePath -> IO () updateParents _ [] = return () updateParents tracesStore path = do Node (trace, _) subtrees <- treeStoreGetTree tracesStore path let visibility = accumVisibility [ vis | subtree <- subtrees , (_, vis) <- flatten subtree ] treeStoreSetValue tracesStore path (trace, visibility) updateParents tracesStore (init path) invertVisibility Hidden = Visible invertVisibility _ = Hidden accumVisibility = foldr1 (\a b -> if a == b then a else MixedVisibility) -- Find the HEC traces in the treeStore and replace them traceViewSetHECs :: TraceView -> HECs -> IO () traceViewSetHECs TraceView{tracesStore} hecs = do treeStoreClear tracesStore -- for testing only (e.g., to compare with histogram of data from interval -- or to compare visually with other traces): -- treeStoreInsert tracesStore [] 0 (TraceHistogram, Visible) go 0 treeStoreInsert tracesStore [] 0 (TraceActivity, Visible) where newT = Node { rootLabel = (TraceGroup "HEC Traces", Visible), subForest = [ Node { rootLabel = (TraceHEC k, Visible), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } newI = Node { rootLabel = (TraceGroup "Instant Events", Hidden), subForest = [ Node { rootLabel = (TraceInstantHEC k, Hidden), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } nCre = Node { rootLabel = (TraceGroup "Spark Creation", Hidden), subForest = [ Node { rootLabel = (TraceCreationHEC k, Hidden), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } nCon = Node { rootLabel = (TraceGroup "Spark Conversion", Hidden), subForest = [ Node { rootLabel = (TraceConversionHEC k, Hidden), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } nPoo = Node { rootLabel = (TraceGroup "Spark Pool", Hidden), subForest = [ Node { rootLabel = (TracePoolHEC k, Hidden), subForest = [] } | k <- [ 0 .. hecCount hecs - 1 ] ] } go n = do m <- treeStoreLookup tracesStore [n] case m of Nothing -> do treeStoreInsertTree tracesStore [] 0 nPoo treeStoreInsertTree tracesStore [] 0 nCon treeStoreInsertTree tracesStore [] 0 nCre treeStoreInsertTree tracesStore [] 0 newI treeStoreInsertTree tracesStore [] 0 newT Just t -> case t of Node { rootLabel = (TraceGroup "HEC Traces", _) } -> do treeStoreRemove tracesStore [n] treeStoreInsertTree tracesStore [] n newT go (n+1) Node { rootLabel = (TraceGroup "HEC Instant Events", _) } -> do treeStoreRemove tracesStore [n] treeStoreInsertTree tracesStore [] n newI go (n+1) Node { rootLabel = (TraceGroup "Spark Creation", _) } -> do treeStoreRemove tracesStore [n] treeStoreInsertTree tracesStore [] n nCre go (n+1) Node { rootLabel = (TraceGroup "Spark Conversion", _) } -> do treeStoreRemove tracesStore [n] treeStoreInsertTree tracesStore [] n nCon go (n+1) Node { rootLabel = (TraceGroup "Spark Pool", _) } -> do treeStoreRemove tracesStore [n] treeStoreInsertTree tracesStore [] n nPoo go (n+1) Node { rootLabel = (TraceActivity, _) } -> do treeStoreRemove tracesStore [n] go (n+1) _ -> go (n+1) traceViewGetTraces :: TraceView -> IO [Trace] traceViewGetTraces TraceView{tracesStore} = do f <- getTracesStoreContents tracesStore return [ t | (t, Visible) <- concatMap flatten f, notGroup t ] where notGroup (TraceGroup _) = False notGroup _ = True getTracesStoreContents :: TreeStore a -> IO (Forest a) getTracesStoreContents tracesStore = go 0 where go !n = do m <- treeStoreLookup tracesStore [n] case m of Nothing -> return [] Just t -> do ts <- go (n+1) return (t:ts) ================================================ FILE: GUI/Types.hs ================================================ module GUI.Types ( ViewParameters(..), Trace(..), Timestamp, Interval, ) where import GHC.RTS.Events ----------------------------------------------------------------------------- data Trace = TraceHEC Int | TraceInstantHEC Int | TraceCreationHEC Int | TraceConversionHEC Int | TracePoolHEC Int | TraceHistogram | TraceGroup String | TraceActivity -- more later ... -- | TraceThread ThreadId deriving Eq type Interval = (Timestamp, Timestamp) -- the parameters for a timeline render; used to figure out whether -- we're drawing the same thing twice. data ViewParameters = ViewParameters { width, height :: Int, viewTraces :: [Trace], hadjValue :: Double, scaleValue :: Double, maxSpkValue :: Double, detail :: Int, bwMode, labelsMode :: Bool, histogramHeight :: Int, minterval :: Maybe Interval, xScaleAreaHeight :: Int } deriving Eq ================================================ FILE: GUI/ViewerColours.hs ================================================ ------------------------------------------------------------------------------- --- $Id: ViewerColours.hs#2 2009/07/18 22:48:30 REDMOND\\satnams $ --- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $ ------------------------------------------------------------------------------- module GUI.ViewerColours (Color, module GUI.ViewerColours) where import Graphics.UI.Gtk import Graphics.Rendering.Cairo ------------------------------------------------------------------------------- -- Colours runningColour :: Color runningColour = darkGreen gcColour :: Color gcColour = orange gcWaitColour :: Color gcWaitColour = lightOrange gcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color gcStartColour = lightOrange gcWorkColour = orange gcIdleColour = lightOrange gcEndColour = lightOrange createThreadColour :: Color createThreadColour = lightBlue seqGCReqColour :: Color seqGCReqColour = cyan parGCReqColour :: Color parGCReqColour = darkBlue migrateThreadColour :: Color migrateThreadColour = darkRed threadWakeupColour :: Color threadWakeupColour = green shutdownColour :: Color shutdownColour = darkBrown labelTextColour :: Color labelTextColour = white bookmarkColour :: Color bookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish fizzledDudsColour, createdConvertedColour, overflowedColour :: Color fizzledDudsColour = grey createdConvertedColour = darkGreen overflowedColour = red userMessageColour :: Color userMessageColour = darkRed outerPercentilesColour :: Color outerPercentilesColour = lightGrey ------------------------------------------------------------------------------- black :: Color black = Color 0 0 0 grey :: Color grey = Color 0x8000 0x8000 0x8000 lightGrey :: Color lightGrey = Color 0xD000 0xD000 0xD000 gtkBorderGrey :: Color gtkBorderGrey = Color 0xF200 0xF100 0xF000 red :: Color red = Color 0xFFFF 0 0 green :: Color green = Color 0 0xFFFF 0 darkGreen :: Color darkGreen = Color 0x0000 0x6600 0x0000 blue :: Color blue = Color 0 0 0xFFFF cyan :: Color cyan = Color 0 0xFFFF 0xFFFF magenta :: Color magenta = Color 0xFFFF 0 0xFFFF lightBlue :: Color lightBlue = Color 0x6600 0x9900 0xFF00 darkBlue :: Color darkBlue = Color 0 0 0xBB00 purple :: Color purple = Color 0x9900 0x0000 0xcc00 darkPurple :: Color darkPurple = Color 0x6600 0 0x6600 darkRed :: Color darkRed = Color 0xcc00 0x0000 0x0000 orange :: Color orange = Color 0xE000 0x7000 0x0000 -- orange lightOrange :: Color lightOrange = Color 0xE000 0xD000 0xB000 -- orange profileBackground :: Color profileBackground = Color 0xFFFF 0xFFFF 0xFFFF tickColour :: Color tickColour = Color 0x3333 0x3333 0xFFFF darkBrown :: Color darkBrown = Color 0x6600 0 0 yellow :: Color yellow = Color 0xff00 0xff00 0x3300 white :: Color white = Color 0xffff 0xffff 0xffff ------------------------------------------------------------------------------- setSourceRGBAhex :: Color -> Double -> Render () setSourceRGBAhex (Color r g b) t = setSourceRGBA (fromIntegral r/0xFFFF) (fromIntegral g/0xFFFF) (fromIntegral b/0xFFFF) t ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- setSourceRGBAForStyle :: (Style -> StateType -> IO Color) -> Style -> StateType -> Render () setSourceRGBAForStyle getColor style state = do color <- liftIO $ getColor style state setSourceRGBAhex color 1 ------------------------------------------------------------------------------- ================================================ FILE: Graphics/UI/Gtk/ModelView/TreeView/Compat.hs ================================================ {-# LANGUAGE CPP #-} module Graphics.UI.Gtk.ModelView.TreeView.Compat ( treeViewSetModel ) where import Graphics.UI.Gtk hiding (treeViewSetModel) import qualified Graphics.UI.Gtk.ModelView.TreeView as Gtk #if !MIN_VERSION_gtk3(0, 14, 9) import qualified System.Glib.FFI as Glib import qualified Graphics.UI.GtkInternals as Gtk #endif treeViewSetModel :: (TreeViewClass self, TreeModelClass model) => self -> Maybe model -> IO () #if MIN_VERSION_gtk3(0, 14, 9) treeViewSetModel = Gtk.treeViewSetModel #else treeViewSetModel self model = Gtk.treeViewSetModel self (maybe (Gtk.TreeModel Glib.nullForeignPtr) toTreeModel model) #endif ================================================ FILE: LICENSE ================================================ The Glasgow Haskell Compiler License Copyright 2002-2012, The University Court of the University of Glasgow and others. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: Main.hs ================================================ module Main where import GUI.Main (runGUI) import System.Environment import System.Exit import System.Console.GetOpt import Data.Version (showVersion) import Paths_threadscope (version) ------------------------------------------------------------------------------- main :: IO () main = do args <- getArgs (flags, args') <- parseArgs args handleArgs flags args' handleArgs :: Flags -> [String] -> IO () handleArgs flags args | flagHelp flags = printHelp | flagVersion flags = printVersion | otherwise = do initialTrace <- case (args, flagTest flags) of ([filename], Nothing) -> return (Just (Left filename)) ([], Just tracename) -> return (Just (Right tracename)) ([], Nothing) -> return Nothing _ -> printUsage >> exitFailure runGUI initialTrace where printVersion = putStrLn ("ThreadScope version " ++ showVersion version) printUsage = putStrLn usageHeader usageHeader = "Usage: threadscope [eventlog]\n" ++ " or: threadscope [FLAGS]" helpHeader = usageHeader ++ "\n\nFlags: " printHelp = putStrLn (usageInfo helpHeader flagDescrs ++ "\nFor more details see http://www.haskell.org/haskellwiki/ThreadScope_Tour\n") ------------------------------------------------------------------------------- data Flags = Flags { flagTest :: Maybe FilePath, flagVersion :: Bool, flagHelp :: Bool } defaultFlags :: Flags defaultFlags = Flags Nothing False False flagDescrs :: [OptDescr (Flags -> Flags)] flagDescrs = [ Option ['h'] ["help"] (NoArg (\flags -> flags { flagHelp = True })) "Show this help text" , Option ['v'] ["version"] (NoArg (\flags -> flags { flagVersion = True })) "Program version" , Option ['t'] ["test"] (ReqArg (\name flags -> flags { flagTest = Just name }) "NAME") "Load a named internal test (see Events/TestEvents.hs)" ] parseArgs :: [String] -> IO (Flags, [String]) parseArgs args | flagHelp flags = return (flags, args') | not (null errs) = printErrors errs | otherwise = return (flags, args') where (flags0, args', errs) = getOpt Permute flagDescrs args flags = foldr (flip (.)) id flags0 defaultFlags printErrors errs = do putStrLn $ concat errs ++ "Try --help." exitFailure ================================================ FILE: Makefile ================================================ # Makefile for ThreadScope GHC = c:/ghc/ghc-6.10.3/bin/ghc cabal: cabal install -w $(GHC) --user --prefix=$(HOME)/haskell sdist: cabal sdist haddock: cabal haddock --executables clean: cabal clean ================================================ FILE: README.md ================================================ # ThreadScope [![Hackage](https://img.shields.io/hackage/v/threadscope.svg)](https://hackage.haskell.org/package/threadscope) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/threadscope.svg)](http://packdeps.haskellers.com/feed?needle=threadscope) ![CI](https://github.com/haskell/ThreadScope/workflows/CI/badge.svg?branch=master) ## Using pre-built binaries Currently [pre-built binaries](https://github.com/haskell/ThreadScope/releases) for the following platforms are provided: * Ubuntu 24.04 (64-bit) * macOS 14.7 * Windows Server 2022 (x64) GTK+3 needs to be installed for these binaries to work. On Windows, the [MSYS2](http://www.msys2.org) is the recommended way to install GTK+3. In MSYS2 MINGW64 shell: ```sh pacman -S $MINGW_PACKAGE_PREFIX-gtk3 ``` then you can run the threadscope binary from the shell. ## Building from source Use `git clone` or `cabal get threadscope` to get the source and move into the threadscope directory. The code for the Github Actions is a good guide for building from source. ### Linux GTK+3 is required to be installed. On Ubuntu-like systems: ```sh sudo apt install libgtk-3-dev ``` Then you can build threadscope using cabal: ```sh cabal v2-build # to only build the project, or cabal v2-install # to build and install the binary ``` Or using stack: ```sh stack build # to only build the project, or stack install # to build and install the binary ``` ### macOS GTK+ is required: ```sh brew install cairo gtk+3 pkg-config ``` Then you can build threadscope using cabal: ```sh cabal --project-file=cabal.project.osx v2-build # to only build the project, or cabal --project-file=cabal.project.osx v2-install # to build and install the binary ``` Or using stack: ```sh stack --stack-yaml=stack.osx.yaml build # to only build the project, or stack --stack-yaml=stack.osx.yaml install # to install the binary ``` ### Windows > [!CAUTION] > The Windows instructions may be out of date. Contributions to update them would be welcome. [Chocolatey](https://chocolatey.org/) can be used to install GHC and [MSYS2](https://www.msys2.org/) is the recommended way to install GTK+. ```sh choco install ghc refreshenv set PATH=C:\\msys64\\mingw64\\bin;C:\\msys64\\usr\\bin;%PATH% pacman -Sy mingw-w64-x86_64-gtk3 ``` then you can build threadscope using cabal: ```sh cabal v2-build ``` Or you can use stack instead. CAVEAT: gtk3 needs to be installed twice: one for stack's MSYS2 environment and another for local MSYS2 environment. In command prompt: ```sh stack setup stack exec -- pacman --needed -Sy bash pacman pacman-mirrors msys2-runtime msys2-runtime-devel stack exec -- pacman -Syu stack exec -- pacman -Syuu stack exec -- pacman -S base-devel mingw-w64-x86_64-pkg-config mingw-w64-x86_64-toolchain mingw-w64-x86_64-gtk3 stack install ``` Then in MSYS2 MINGW64 shell: ```sh pacman -S $MINGW_PACKAGE_PREFIX-gtk3 echo 'export PATH=$APPDATA/local/bin:$PATH' >> .profile source .profile threadscope ``` Building using stack is not tested in CI. If you find any issues with building with stack, please update the instructions and send a PR. ================================================ FILE: Setup.hs ================================================ import Distribution.Simple main = defaultMain ================================================ FILE: TODO ================================================ BUGS: - ThreadScope DEADLOCKs occasionally, more often with --debug, why? - X Window System error sometimes? - background of some widgets on Windows are white when they are grey in Linux - Make ^C work on Windows - resizing the panes causes a grab lockup? Happened to Mikolaj on 7.11.2011, too. - fix, rewrite or disable partial redrawing of the graphs pane that causes many of the graphical bugs reported below - rewrite lots of drawing code to sidestep the fixed point precision problem of cairo - scrolling to the right, we get some over-rendering at the boundary causing a thick line - (probably the same as above) the gray vertical lines get sometimes randomly darker when scrolling by moving the scrollbar handle slowly to the right (probably caused by testing an x coordinate up to integral division by slice or without taking into account the hadj_value, so the line is drawn many times when scrolling) - scrolling when event labels are on chops off some labels - rendering bug when scrolling: we need to clip to the rectangle being drawn, otherwise we overwrite other parts of the window when there are long bars being drawn, which makes some events disappear. - sideways scrolling leaves curve rendering artifacts (e.g., the thicker fragments of the flat line at the end of the Activity graph) - sometimes 2 labels are written on top of each other even at max zoom, e.g. "thread 3 yielding" and "thread 3 is runnable" - some sequence of enabling/disabling labels and traces leave the timeline too short to display all traces; refreshing fixed this - may be a feature: filling graphs with colours is from line 1 upwards, not line 0, so lines at level 0 seem under the filled area, not level with it - a few levels of zoom in and then zoom out sometimes results in only the rightmost fragment of the timeline shown, no indication in the scrollbar that scroll is possible, but scrolling indeed fixes the view - ticking the trace boxes off sometimes shows a black rectangle in place of the switched off graph OTHER: - sort bookmark view by time? - Delete key deletes bookmarks? - hotkey to add a bookmark? - 25%/50%/75% percentiles for pool size, see http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.10.6199 figure 15 WARNING: unlike mean, the median and other percentiles can't be computed from percentiles of subnodes of the trees --- they need the whole data for the interval in question at each level of the tree. This increases the cost from O(n) to O(n * log n), where n is the total number of samples. Additional log n factor, in comparison with mean, is probably inevitable unless we put the data in an array, because otherwise we have to sort the data for each interval to find the k-th element. An extra problem is that to get accurate percentiles for splices that do not match a single subtree node, we have to get the whole data for the splice again, completely repeating the calculations. Then the preprocessing via creating the tree would only be useful if the tree stores the whole data at each tree level, already partitioned and the data for each slice may be gathered cheaply (but a bit inaccurately, see the use of SparkStats.rescale in the current code) by only looking at a few nodes of the tree at a single level, instead of traversing a very long list. There are better data structures than the spark tree for quick lookup of sorted data, so let's remove the pool sizes from the spark tree altogether and hack them separately (or use the better structures for everything). Use the trick with calculating percentiles from all raw data, but after quantizing it into a histogram, to make it tractable; the trick is orthogonal to the change of data representation to multi-level array aggregates, but with old data representation it may be too slow - resample the data (morally) uniformly, unless the sampling is changed from GC time points to equal intervals (note that with resampling, with enough extra inserted sample points, the median approaches the mean, so calculating the median for pool size does not make sense; however, percentiles still make sense --- they are not just mean*(n/m), e.g., for y=5, all percentiles are 5, while for y=x, from 0 to 10, they differ, regardless of sample density and uniformity, except trivial cases) - remove the grey halo in trivial cases of pool size, like the line: ___/----, but keep min/max for ___/\___ - make sure the user understands that the _areas_ are proportional to the total number and curve points to rates and that the green area in spark creation and the total area in spark conversion are equal; perhaps tell so in the help tab or in the timeline text summary tab - the same aggregate style for the activity graph, to see min/max (the green area does convey the total runtime, so perhaps mark min just as a line, no grey shadow); or just redo it completely as the pool graphs - test, in particular the quality of sampling, on the parfib suite; ideally generate sampled events from accurate events and compare visually and/or numerically - either change scale together with zoom level (and keep a colored box showing how much pictures space corresponds to how many sparks (should be probably constant)) or (this one implemented currently:) start with the best scale for the complete view and the let the peaks be clipped, let the user manually readjust scale then - limit the use of save/restore and similar crude hacks - in zoom out, activity and spark graphs seem cut off at the ends, which is mathematically correct, but one more slice or even pixel on each end would make it look better, without compromising correctness too much (just make sure the extra space does not grow with zoom level!); the sparks and Activity are already rendered with (up to?) one extra slice at the ends, but somehow this does not show (perhaps one is not enough) - perhaps enlarge the main timeline canvas to the right to the nearest tick - perhaps draw the trace labels vertically and reduce the size of the Y axis area - click and drag the view (or the selected interval, perhaps shift-click or control-click when starting to drag) - draw the detailed view in the background - bookmarks - save - measure the time between two markers - search for events in the event window, also filter events using regexps; alternatively, adding more categories of events to the RTS could help so that the user can enable only the needed events - indicate when one thread wakes up another thread, or a thread is migrated; perhaps draw lines/arrows between the events? - event list view - respond to page up / page down / arrows (FOCUS) - interact with bookmarks - left pane for - bookmarks - list of traces - traces would be a tree-view, e.g. * HECs * 0 * 1 etc. * Threads * 0 * 1 etc. * RTS * live heap * ETW / Linux Performance counters * cache misses * stalls * etc. - some way to reorder the traces? dragging and dropping? - when rendering threads, we want some way to indicate the time between creation and death - colour grey? - a better progress bar - animate zoom level transitions: ways to make the zoom in/out less confusing for users (e.g. the sudden appearance of spikiness once thresholds) animating the transitions would make it clearer generate the bitmap of the higher resolution new view, and animate it expanding to cover the new view it'd be quick since it's just bitmap scaling so the user can see the region in the old view that is expanding out to become the new view - let the user set the interval size/scale, as an advanced option, _separately_ for each graph stack, each HEC, each visible region at the current zoom level, each selected region (if they are implemented) - a button for vertical zoom (clip graphs if they don't fit at that zoom) and/or select regions of time in the view and zoom only that region of display; - an option to automatically change scale at zoom in to take into account only the visible and smoothed part of the graphs - label coloured areas with a mouseover, according to what they represent - move the text entents stuff out of drawing ThreadRuns - overlay ETW events - integrate strace events in the event view on Linux (note that linux perf events are already available in TS) - colour threads differently - thread names rather than numbers - live heap graph - summary analysis - perhaps draw the graphs even if only the fully-accurate, per-spark events are present in the logs (by transforming them to the sampled format) - and/or extrapolate data for large zoom levels with scarce samples by slated lines, not just horizontal lines (which work great with numerous enough samples, though) - merge adjacent 0 samples: if we have equal adjacent samples we just take the second/last can be done when it's still a list, before making the tree; simple linear pass, and lazy too; does not make sense in per-spark events mode - use the extra info about when the spark pool gets full and empty; we know when the spark pool becomes empty because we can observe that the threads evaluating sparks terminate; similarly, we know overflow only occurs when the pool is full; but note the following: "dcoutts: also noticed that we cannot currently reliably discover when the spark queue is empty. I had thought that "the" spark thread terminating implied that the queue is empty, however there can be multiple spark threads and they can also terminate when there are other threads on that capability's run queue (normal forkIO work takes precedence over evaluating sparks)" - consider making the graphs more accurate by drilling down the tree to the base events at each slice borders: they don't go down to the base events at each slice boundary but only at the two viewport borders (hence the extra slices at the ends dcoutts noticed). The current state generally this results in smoothing the curve, but a side-effect is that the graphs grow higher visually (the max is higher) as the zoom level increases. - or increase the accuracy by dividing increments not by the slice length (implicitly), but the length of the sum of tree node spans that cover the slice, similarly as in gnuplot graphs - perhaps we should change the spark event sampling to emit events every N sparks rather than at GC; but only if experiments (do more accurate sampling and compare the general look of the graphs) show that linear extrapolation of the GC data is not correct (large spark transitions happen in the long periods between GC and we don't know when exactly) (the 4K pool size guarantees that at least with large visible absolute spark transition, the invisible transitions can't be huge in proportion to the visible ones, so then linear extrapolation is correct)) - use adaptive interval, depending on the sample density at the viewed fragment - perhaps, depending on sample density, alternate between raw data, min/max, percentiles; so the raw data line slowly explodes into a band, a big smudge, like a string of beads, that gets even more detailed and perhaps wider, when data density/uniformity allows it; in other words: a thin line means we only guess that's where the data might be a thicker one, with mix/max means we have some data, but too irregular/scarce to say more, and full thickness line, with percentiles means we have enough data or evenly distributed enough to say all - have *configurable* colors, like in Eden; where to save them? - Eden TV has good visualisation for messages between processes & nodes, (steal it, when we do more work on Cloud Haskell) - show time corresponding to the eventlog buffer flushing, after the event for this introduced - verify correctness of the input eventlog before visualizing; define a method of passing the error report from ghc-events to TS and displaying it; have a grace period when that can be disabled via an option, until RTS and validation stabilize - perhaps the far left and far right bars on the histogram should be in red, since extreme spark sizes are usually bad (or mark it in some other way) - or colour stacked bars of the histogram according to strategy label - determine which bars represent too small and too large sparks based on the estimation of spark overhead divided by spark duration, etc. - dynamic strategy labelling (lots of stuff has to be done elsewhere, first) - mousing over or clicking a bar should tell "1.3s worth of sparks (28 total) that took between 16--64ms to evaluate"; people want to know the number of sparks as well as the total eval time, in particular kosmikus wants to know this - either show "Loading" when calculating spark duration histogram for a selected range on the timeline graph, or store precomputed data in the data structures for speedy drawing of the main timeline graphs, however they are (re)implemented in the end (mipmap or tress or anything) - manage histogram interval selection as gimp does: drag to create a selection, then move the selection, etc. - extend the selection stuff, e.g. keep bookmarks sorted and let you select multiple bookmarks which would then give you a range selection - add a new info / stats tab giving numeric info about the current selection, e.g., the amount of cpu time used on each hec, mutator, gc, also sparks, basically all the things that ./prog +RTS --blah can give you, but for any time period, not just whole run - perhaps the current "reset zoom" button could change the x and y scale of timeline and histogram to fit the current region (which initially and most of the time later on is just the whole eventlog)? - perhaps we need a floating "resize me" button to pop up on the graph whenever your current view ought to be resized , e.g. clipping at the top, or tallest bar taking up less than half the vertical space, or put that in red letters into the popups that we'll have at some point, or mark the upper or lower edge of the graph red (depending if it's clipped or too small) and blink the y-zoom reset button (to the right of the x-zoom reset button) in red, too - select a region and display it in a separate tab (e.g. next to the events tab) - scroll around the graph image via a small zoomed out window "The Information Mural: A Technique for Displaying and Navigating Large Information Spaces" - zoom histogram for granularity: increase the number of bars, keeping the min/max unchanged; that requires log with base other than 2 - zoom histogram for detail: keep the number of bars the same, but change the scale to only show sparks between a narrower min/max; for this log 2 is enough, with a constant offset - compare any of the graphs for the whole time and for the interval: either by opening/detaching window/pane dedicated to the interval data or by a permanent tab in the bottom pane with selectable traces that only ever show the data from the selected interval and when you zoom it, the interval changes in the upper pane (but histogram should not be among those traces, because it does not scroll, does not have the time X axis, and generally does not fit and is confusing) - perhaps use the tab with traces to guide what is exported to PDF/PNG; also, since histogram is not among the traces, use some other UI element to specify in the histogram should be shown (currently disabled permanently) - events in the info pane should be searchable, and possibly numbered - selecting a range of events (via a shift-click) in the info pane should create a selection as might be done with the mouse. - select and copy events from the info pane to the OS clipboard - perhaps, on the X scale of timeline, show only offsets, to save space: that is, only give the full time for the left point of the view and all other times relative to that, e.g., 2.356 s, +1ms, +2ms, etc. - and add a way to add a bookmark for a user-specified event, or a kind of events - medium-term: let the user configure which instant events shown in the trace - medium-term: user-defined visualisation frequency for the new trace (at least) and any other tricks needed to visualize instant events well (show density even if many events at almost the same spot and so the shades of green cue is not possible) and fast (in particular, don't draw many lines at the same spot) some random user feedback on the "lots of events" use case of traceEvents: 1. I don't need/use bookmarking (I can use the visual clues to jump), or even grep the event log 2. I find the visualization helpful, but disturbing, because it hides other information 3. it would be great to be able to visually distinguish different "messages" 4. it would be nice if drawing wouldn't slow down significantly even for a relatively small number of events (i.e., 100 is noticeable slowdown already) - make TS useful for par-monad: generate and visualize user code / libs events, make the same kind of granularity histogram as for sparks, etc. - make TS useful for concurrent code: forkIO concurrency events, properly implement the event merging for the cluster use case - make TS useful for sequential code, in addition to showing the GC pattern - make TS useful for the cloud haskell use cases - add finite machines for the GC and other events (after new events are added and/or extended) and use validation profiles to count some of the summary data that is calculated by hand right now - another possibility to visualize sparks when there are not many of them would be to show an activity graph purely for spark evaluation, ie only counting those threads that are doing spark evaluation - a button to snap scale to a power of 10, that'd solve: I need a way to show two different eventlog files with the same time scale. The attached picture was generated from two different files, but I couldn't find a way to make the time scale consistent. I expect this is because the 'zoom' button scales the plot based on the total length of the eventlog file, instead of using a fixed pixels/second ratio, which it what I really need. Alternatively, have dialog to set the time scale specifically, as in an electronic oscilloscope, but in our case, with zoom levels that multiply/divide the scale by 2, detailed settings are rather irrelevant. - another idea illustrated by an electronic oscilloscope: folding a graph at all occurrences of an event and showing the overlaid plot Given a regex named "compute iteration N start", find all instances of of this event within a user-defined time interval, and overlay the plots on top of each other. Ideally, each plot would be drawn partially transparent, so the color would be brighter when most instances were active at the same time since the event start. Alternatively, could could just average all the instances. I want to see if different iterations behave similarly. On an electronic oscilloscope this would be done the "trigger" setting. On an oscilloscope the beam traces from left to right on the display. When it runs off the right-hand-side it waits for a particular event in the signal before it starts tracing again. For a continuous signal the event would be that signal reaching a given threshold -- and the trigger knob on the bottom right-hand-side sets this threshold. Due to persistence-of-vision, you'd see many separate traces overlaid on the display. For ThreadScope the trigger should be a particular event selected with a regex. - show a histogram of the time difference between non-overlapping event pairs. Specifically, If I have events named "image filter iteration N start" and "image filter iteration N end" I want a histogram of how long those iterations took. - highlight the HEC of the current event selected in the Raw Events view (in the timeline) - for small screens with many HECs, make it possible to zoom the canvas vertically (perhaps via M-mouse wheel?) ================================================ FILE: cabal.project ================================================ -- see http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html for more information packages: . ================================================ FILE: cabal.project.osx ================================================ packages: . constraints: gtk +have-quartz-gtk ================================================ FILE: include/windows_cconv.h ================================================ #ifndef __WINDOWS_CCONV_H #define __WINDOWS_CCONV_H #if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall #elif defined(x86_64_HOST_ARCH) # define WINDOWS_CCONV ccall #else # error Unknown mingw32 arch #endif #endif ================================================ FILE: index.html ================================================  ThreadScope: A Graphical Profiler for Parallel and Concurrent Haskell Programs

ThreadScope

Please see

http://www.haskell.org/haskellwiki/ThreadScope

and the guided tour at

http://www.haskell.org/haskellwiki/ThreadScope_Tour

================================================ FILE: papers/haskell_symposium_2009/Makefile ================================================ # $Id: Makefile#3 2009/07/18 22:48:30 REDMOND\\satnams $ # $Source: //depot/satnams/haskell/ThreadScope/papers/haskell_symposium_2009/Makefile $ DOC = ghc-parallel-tuning all: pdflatex $(DOC).tex bibtex $(DOC) pdflatex $(DOC).tex pdflatex $(DOC).tex spell: aspell -c ghc-parallel-tuning.tex aspell -c motivation.tex aspell -c threadring.tex aspell -c bsort.tex aspell -c related-work.tex clean: rm -rf *.bbl *.blg *.log *.aux *.dvi ================================================ FILE: papers/haskell_symposium_2009/bsort/BSort.hs ================================================ ------------------------------------------------------------------------------- --- $Id: BSort.hs#1 2009/03/06 10:53:15 REDMOND\\satnams $ ------------------------------------------------------------------------------- module Main where import System.Mem import System.Random import System.Time ------------------------------------------------------------------------------- infixr 5 >-> ------------------------------------------------------------------------------- (>->) :: (a-> b) -> (b-> c) -> (a-> c) (>->) circuit1 circuit2 input1 = circuit2 (circuit1 input1) ------------------------------------------------------------------------------- halve :: [a] -> ([a], [a]) halve l = (take n l, drop n l) where n = length l `div` 2 ------------------------------------------------------------------------------- unhalve :: ([a], [a]) -> [a] unhalve (a, b) = a ++ b ------------------------------------------------------------------------------- pair :: [a] -> [[a]] pair [] = [] pair lst | odd (length lst) = error ("pair given odd length list of size " ++ show (length lst)) pair (a:b:cs) = [a,b]:rest where rest = pair cs ------------------------------------------------------------------------------- unpair :: [[a]] -> [a] unpair list = concat list ------------------------------------------------------------------------------- par2 :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) par2 circuit1 circuit2 (input1, input2) = (output1, output2) where output1 = circuit1 input1 output2 = circuit2 input2 ------------------------------------------------------------------------------- halveList :: [a] -> [[a]] halveList l = [take n l, drop n l] where n = length l `div` 2 ------------------------------------------------------------------------------- unhalveList :: [[a]] -> [a] unhalveList [a, b] = a ++ b ------------------------------------------------------------------------------- chop :: Int -> [a] -> [[a]] chop n [] = [] chop n l = (take n l) : chop n (drop n l) ------------------------------------------------------------------------------- zipList :: [[a]] -> [[a]] zipList [[], _] = [] zipList [_, []] = [] zipList [a:as, b:bs] = [a,b] : zipList [as, bs] ------------------------------------------------------------------------------- unzipList :: [[a]] -> [[a]] unzipList list = [map fstListPair list, map sndListPair list] ------------------------------------------------------------------------------- fsT :: (a -> b) -> (a, c) -> (b, c) fsT f (a, b) = (f a, b) ------------------------------------------------------------------------------- snD :: (b -> c) -> (a, b) -> (a, c) snD f (a, b) = (a, f b) ------------------------------------------------------------------------------- sndList :: ([a] -> [a]) -> [a] -> [a] sndList f = halve >-> snD f >-> unhalve ------------------------------------------------------------------------------- fstListPair :: [a] -> a fstListPair [a, _] = a ------------------------------------------------------------------------------- sndListPair :: [a] -> a sndListPair [_, b] = b ------------------------------------------------------------------------------- two :: ([a] -> [b]) -> [a] -> [b] two r = halve >-> par2 r r >-> unhalve ------------------------------------------------------------------------------- -- Many twos. twoN :: Int -> ([a] -> [b]) -> [a] -> [b] twoN 0 r = r twoN n r = two (twoN (n-1) r) ------------------------------------------------------------------------------- riffle :: [a] -> [a] riffle = halveList >-> zipList >-> unpair ------------------------------------------------------------------------------- unriffle :: [a] -> [a] unriffle = pair >-> unzipList >-> unhalveList ------------------------------------------------------------------------------- ilv :: ([a] -> [b]) -> [a] -> [b] ilv r = unriffle >-> two r >-> riffle ------------------------------------------------------------------------------- ilvN :: Int -> ([a] -> [b]) -> [a] -> [b] ilvN 0 r = r ilvN n r = ilv (ilvN (n-1) r) ------------------------------------------------------------------------------- evens :: ([a] -> [b]) -> [a] -> [b] evens f = chop 2 >-> map f >-> concat ------------------------------------------------------------------------------- type ButterflyElement a = [a] -> [a] type Butterfly a = [a] -> [a] ------------------------------------------------------------------------------- butterfly :: ButterflyElement a -> Butterfly a butterfly circuit [x,y] = circuit [x,y] butterfly circuit input = (ilv (butterfly circuit) >-> evens circuit) input ------------------------------------------------------------------------------- sortB cmp [x, y] = cmp [x, y] sortB cmp input = (two (sortB cmp) >-> sndList reverse >-> butterfly cmp) input ------------------------------------------------------------------------------- twoSorter :: [Int] -> [Int] twoSorter [a, b] = if a <= b then [a, b] else [b, a] ------------------------------------------------------------------------------- bsort :: [Int] -> [Int] bsort = sortB twoSorter ------------------------------------------------------------------------------- main :: IO () main = do nums <- sequence (replicate (2^14) (getStdRandom (randomR (1,255)))) tStart <- getClockTime performGC let r = bsort nums seq r (return ()) tEnd <- getClockTime putStrLn (show (sum r)) putStrLn ("Time: " ++ show (secDiff tStart tEnd) ++ " seconds.") ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/bsort/BSortPar.hs ================================================ ------------------------------------------------------------------------------- --- $Id: BSort.hs#1 2009/03/06 10:53:15 REDMOND\\satnams $ ------------------------------------------------------------------------------- module Main where import System.Mem import System.Random import System.Time import Control.Parallel ------------------------------------------------------------------------------- infixr 5 >-> ------------------------------------------------------------------------------- (>->) :: (a-> b) -> (b-> c) -> (a-> c) (>->) circuit1 circuit2 input1 = circuit2 (circuit1 input1) ------------------------------------------------------------------------------- halve :: [a] -> ([a], [a]) halve l = (take n l, drop n l) where n = length l `div` 2 ------------------------------------------------------------------------------- unhalve :: ([a], [a]) -> [a] unhalve (a, b) = a ++ b ------------------------------------------------------------------------------- pair :: [a] -> [[a]] pair [] = [] pair lst | odd (length lst) = error ("pair given odd length list of size " ++ show (length lst)) pair (a:b:cs) = [a,b]:rest where rest = pair cs ------------------------------------------------------------------------------- unpair :: [[a]] -> [a] unpair list = concat list ------------------------------------------------------------------------------- par2 :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) par2 circuit1 circuit2 (input1, input2) = output1 `par` (output2 `pseq` (output1, output2)) where output1 = circuit1 input1 output2 = circuit2 input2 ------------------------------------------------------------------------------- halveList :: [a] -> [[a]] halveList l = [take n l, drop n l] where n = length l `div` 2 ------------------------------------------------------------------------------- unhalveList :: [[a]] -> [a] unhalveList [a, b] = a ++ b ------------------------------------------------------------------------------- chop :: Int -> [a] -> [[a]] chop n [] = [] chop n l = (take n l) : chop n (drop n l) ------------------------------------------------------------------------------- zipList :: [[a]] -> [[a]] zipList [[], _] = [] zipList [_, []] = [] zipList [a:as, b:bs] = [a,b] : zipList [as, bs] ------------------------------------------------------------------------------- unzipList :: [[a]] -> [[a]] unzipList list = [map fstListPair list, map sndListPair list] ------------------------------------------------------------------------------- fsT :: (a -> b) -> (a, c) -> (b, c) fsT f (a, b) = (f a, b) ------------------------------------------------------------------------------- snD :: (b -> c) -> (a, b) -> (a, c) snD f (a, b) = (a, f b) ------------------------------------------------------------------------------- sndList :: ([a] -> [a]) -> [a] -> [a] sndList f = halve >-> snD f >-> unhalve ------------------------------------------------------------------------------- fstListPair :: [a] -> a fstListPair [a, _] = a ------------------------------------------------------------------------------- sndListPair :: [a] -> a sndListPair [_, b] = b ------------------------------------------------------------------------------- two :: ([a] -> [b]) -> [a] -> [b] two r = halve >-> par2 r r >-> unhalve ------------------------------------------------------------------------------- -- Many twos. twoN :: Int -> ([a] -> [b]) -> [a] -> [b] twoN 0 r = r twoN n r = two (twoN (n-1) r) ------------------------------------------------------------------------------- riffle :: [a] -> [a] riffle = halveList >-> zipList >-> unpair ------------------------------------------------------------------------------- unriffle :: [a] -> [a] unriffle = pair >-> unzipList >-> unhalveList ------------------------------------------------------------------------------- ilv :: ([a] -> [b]) -> [a] -> [b] ilv r = unriffle >-> two r >-> riffle ------------------------------------------------------------------------------- ilvN :: Int -> ([a] -> [b]) -> [a] -> [b] ilvN 0 r = r ilvN n r = ilv (ilvN (n-1) r) ------------------------------------------------------------------------------- evens :: ([a] -> [b]) -> [a] -> [b] evens f = chop 2 >-> map f >-> concat ------------------------------------------------------------------------------- type ButterflyElement a = [a] -> [a] type Butterfly a = [a] -> [a] ------------------------------------------------------------------------------- butterfly :: ButterflyElement a -> Butterfly a butterfly circuit [x,y] = circuit [x,y] butterfly circuit input = (ilv (butterfly circuit) >-> evens circuit) input ------------------------------------------------------------------------------- sortB cmp [x, y] = cmp [x, y] sortB cmp input = (two (sortB cmp) >-> sndList reverse >-> butterfly cmp) input ------------------------------------------------------------------------------- twoSorter :: [Int] -> [Int] twoSorter [a, b] = if a <= b then [a, b] else [b, a] ------------------------------------------------------------------------------- bsort :: [Int] -> [Int] bsort = sortB twoSorter ------------------------------------------------------------------------------- main :: IO () main = do nums <- sequence (replicate (2^14) (getStdRandom (randomR (1,255)))) tStart <- getClockTime performGC let r = bsort nums seq r (return ()) tEnd <- getClockTime putStrLn (show (sum r)) putStrLn ("Time: " ++ show (secDiff tStart tEnd) ++ " seconds.") ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/bsort/BSortPar2.hs ================================================ ------------------------------------------------------------------------------- --- $Id: BSort.hs#1 2009/03/06 10:53:15 REDMOND\\satnams $ ------------------------------------------------------------------------------- module Main where import System.Mem import System.Random import System.Time import Control.Parallel import Control.Parallel.Strategies ------------------------------------------------------------------------------- infixr 5 >-> ------------------------------------------------------------------------------- (>->) :: (a-> b) -> (b-> c) -> (a-> c) (>->) circuit1 circuit2 input1 = circuit2 (circuit1 input1) ------------------------------------------------------------------------------- halve :: [a] -> ([a], [a]) halve l = (take n l, drop n l) where n = length l `div` 2 ------------------------------------------------------------------------------- unhalve :: ([a], [a]) -> [a] unhalve (a, b) = a ++ b ------------------------------------------------------------------------------- pair :: [a] -> [[a]] pair [] = [] pair lst | odd (length lst) = error ("pair given odd length list of size " ++ show (length lst)) pair (a:b:cs) = [a,b]:rest where rest = pair cs ------------------------------------------------------------------------------- unpair :: [[a]] -> [a] unpair list = concat list ------------------------------------------------------------------------------- par2 :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) par2 circuit1 circuit2 (input1, input2) = output1 `par` (output2 `pseq` (output1, output2)) where output1 = circuit1 input1 output2 = circuit2 input2 ------------------------------------------------------------------------------- halveList :: [a] -> [[a]] halveList l = [take n l, drop n l] where n = length l `div` 2 ------------------------------------------------------------------------------- unhalveList :: [[a]] -> [a] unhalveList [a, b] = a ++ b ------------------------------------------------------------------------------- chop :: Int -> [a] -> [[a]] chop n [] = [] chop n l = (take n l) : chop n (drop n l) ------------------------------------------------------------------------------- zipList :: [[a]] -> [[a]] zipList [[], _] = [] zipList [_, []] = [] zipList [a:as, b:bs] = [a,b] : zipList [as, bs] ------------------------------------------------------------------------------- unzipList :: [[a]] -> [[a]] unzipList list = [map fstListPair list, map sndListPair list] ------------------------------------------------------------------------------- fsT :: (a -> b) -> (a, c) -> (b, c) fsT f (a, b) = (f a, b) ------------------------------------------------------------------------------- snD :: (b -> c) -> (a, b) -> (a, c) snD f (a, b) = (a, f b) ------------------------------------------------------------------------------- sndList :: ([a] -> [a]) -> [a] -> [a] sndList f = halve >-> snD f >-> unhalve ------------------------------------------------------------------------------- fstListPair :: [a] -> a fstListPair [a, _] = a ------------------------------------------------------------------------------- sndListPair :: [a] -> a sndListPair [_, b] = b ------------------------------------------------------------------------------- two :: ([a] -> [b]) -> [a] -> [b] two r = halve >-> par2 r r >-> unhalve ------------------------------------------------------------------------------- -- Many twos. twoN :: Int -> ([a] -> [b]) -> [a] -> [b] twoN 0 r = r twoN n r = two (twoN (n-1) r) ------------------------------------------------------------------------------- riffle :: [a] -> [a] riffle = halveList >-> zipList >-> unpair ------------------------------------------------------------------------------- unriffle :: [a] -> [a] unriffle = pair >-> unzipList >-> unhalveList ------------------------------------------------------------------------------- ilv :: ([a] -> [b]) -> [a] -> [b] ilv r = unriffle >-> two r >-> riffle ------------------------------------------------------------------------------- ilvN :: Int -> ([a] -> [b]) -> [a] -> [b] ilvN 0 r = r ilvN n r = ilv (ilvN (n-1) r) ------------------------------------------------------------------------------- evens :: ([a] -> [b]) -> [a] -> [b] evens f = chop 2 >-> parMap rwhnf f >-> concat ------------------------------------------------------------------------------- type ButterflyElement a = [a] -> [a] type Butterfly a = [a] -> [a] ------------------------------------------------------------------------------- butterfly :: ButterflyElement a -> Butterfly a butterfly circuit [x,y] = circuit [x,y] butterfly circuit input = (ilv (butterfly circuit) >-> evens circuit) input ------------------------------------------------------------------------------- sortB cmp [x, y] = cmp [x, y] sortB cmp input = (two (sortB cmp) >-> sndList reverse >-> butterfly cmp) input ------------------------------------------------------------------------------- twoSorter :: [Int] -> [Int] twoSorter [a, b] = if a <= b then [a, b] else [b, a] ------------------------------------------------------------------------------- bsort :: [Int] -> [Int] bsort = sortB twoSorter ------------------------------------------------------------------------------- main :: IO () main = do nums <- sequence (replicate (2^14) (getStdRandom (randomR (1,255)))) tStart <- getClockTime performGC let r = bsort nums seq r (return ()) tEnd <- getClockTime putStrLn (show (sum r)) putStrLn ("Time: " ++ show (secDiff tStart tEnd) ++ " seconds.") ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/bsort/BSortStreaming.hs ================================================ ------------------------------------------------------------------------------- --- $Id: BSortStreaming.hs#1 2009/03/06 10:53:15 REDMOND\\satnams $ ------------------------------------------------------------------------------- module Main where import Data.List import System.Mem import System.Random import System.Time ------------------------------------------------------------------------------- infixr 5 >-> ------------------------------------------------------------------------------- (>->) :: (a-> b) -> (b-> c) -> (a-> c) (>->) circuit1 circuit2 input1 = circuit2 (circuit1 input1) ------------------------------------------------------------------------------- halve :: [a] -> ([a], [a]) halve l = (take n l, drop n l) where n = length l `div` 2 ------------------------------------------------------------------------------- unhalve :: ([a], [a]) -> [a] unhalve (a, b) = a ++ b ------------------------------------------------------------------------------- pair :: [a] -> [[a]] pair [] = [] pair lst | odd (length lst) = error ("pair given odd length list of size " ++ show (length lst)) pair (a:b:cs) = [a,b]:rest where rest = pair cs ------------------------------------------------------------------------------- unpair :: [[a]] -> [a] unpair list = concat list ------------------------------------------------------------------------------- par2 :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) par2 circuit1 circuit2 (input1, input2) = (output1, output2) where output1 = circuit1 input1 output2 = circuit2 input2 ------------------------------------------------------------------------------- halveList :: [a] -> [[a]] halveList l = [take n l, drop n l] where n = length l `div` 2 ------------------------------------------------------------------------------- unhalveList :: [[a]] -> [a] unhalveList [a, b] = a ++ b ------------------------------------------------------------------------------- chop :: Int -> [a] -> [[a]] chop n [] = [] chop n l = (take n l) : chop n (drop n l) ------------------------------------------------------------------------------- zipList :: [[a]] -> [[a]] zipList [[], _] = [] zipList [_, []] = [] zipList [a:as, b:bs] = [a,b] : zipList [as, bs] ------------------------------------------------------------------------------- unzipList :: [[a]] -> [[a]] unzipList list = [map fstListPair list, map sndListPair list] ------------------------------------------------------------------------------- fsT :: (a -> b) -> (a, c) -> (b, c) fsT f (a, b) = (f a, b) ------------------------------------------------------------------------------- snD :: (b -> c) -> (a, b) -> (a, c) snD f (a, b) = (a, f b) ------------------------------------------------------------------------------- sndList :: ([a] -> [a]) -> [a] -> [a] sndList f = halve >-> snD f >-> unhalve ------------------------------------------------------------------------------- fstListPair :: [a] -> a fstListPair [a, _] = a ------------------------------------------------------------------------------- sndListPair :: [a] -> a sndListPair [_, b] = b ------------------------------------------------------------------------------- two :: ([a] -> [b]) -> [a] -> [b] two r = halve >-> par2 r r >-> unhalve ------------------------------------------------------------------------------- -- Many twos. twoN :: Int -> ([a] -> [b]) -> [a] -> [b] twoN 0 r = r twoN n r = two (twoN (n-1) r) ------------------------------------------------------------------------------- riffle :: [a] -> [a] riffle = halveList >-> zipList >-> unpair ------------------------------------------------------------------------------- unriffle :: [a] -> [a] unriffle = pair >-> unzipList >-> unhalveList ------------------------------------------------------------------------------- ilv :: ([a] -> [b]) -> [a] -> [b] ilv r = unriffle >-> two r >-> riffle ------------------------------------------------------------------------------- ilvN :: Int -> ([a] -> [b]) -> [a] -> [b] ilvN 0 r = r ilvN n r = ilv (ilvN (n-1) r) ------------------------------------------------------------------------------- evens :: ([a] -> [b]) -> [a] -> [b] evens f = chop 2 >-> map f >-> concat ------------------------------------------------------------------------------- type ButterflyElement a = [a] -> [a] type Butterfly a = [a] -> [a] ------------------------------------------------------------------------------- butterfly :: ButterflyElement a -> Butterfly a butterfly circuit [x,y] = circuit [x,y] butterfly circuit input = (ilv (butterfly circuit) >-> evens circuit) input ------------------------------------------------------------------------------- sortB cmp [x, y] = cmp [x, y] sortB cmp input = (two (sortB cmp) >-> sndList reverse >-> butterfly cmp) input ------------------------------------------------------------------------------- twoSorter :: [Int] -> [Int] twoSorter [a, b] = if a <= b then [a, b] else [b, a] ------------------------------------------------------------------------------- streamingTwoSorter :: [[Int]] -> [[Int]] streamingTwoSorter [as, bs] = transpose [twoSorter [a, b] | (a, b) <- zip as bs] ------------------------------------------------------------------------------- bsort :: [[Int]] -> [[Int]] bsort = sortB streamingTwoSorter ------------------------------------------------------------------------------- produceRandomNumbers :: Int -> IO [Int] produceRandomNumbers n = sequence (replicate n (getStdRandom (randomR (1,25)))) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "Streaming bsort" -- The argument to replicate specifies the input of inputs -- to the sorter e.g. 2^3 means this is an 8 input sorter. -- The argument to produceRandomNumbers specified how many -- numbers flow along each input stream. nums <- sequence (replicate (2^5) (produceRandomNumbers 10000)) --putStrLn (show nums) performGC tStart <- getClockTime let r = concat (bsort nums) seq r (return ()) tEnd <- getClockTime --putStrLn (show r) putStrLn (show (sum r)) putStrLn ("Time: " ++ show (secDiff tStart tEnd) ++ " seconds.") ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/bsort/Makefile ================================================ GHC = /c/ghc/ghc/inplace/bin/ghc-stage2 GHC_OPTS = -threaded -eventlog # HEAP = -H100M HEAP = EBH = -feager-blackholing all: $(GHC) $(GHC_OPTS) --make BSort.hs -O -o bsort $(GHC) $(GHC_OPTS) --make BSortPar.hs -O -o bsortpar $(GHC) $(GHC_OPTS) --make BSortPar2.hs -O -o bsortpar2 $(GHC) $(GHC_OPTS) --make BSortPar3.hs -O -o bsortpar3 $(GHC) $(GHC_OPTS) --make BSortStreaming.hs -o bsort_streaming run0: ./bsort +RTS -N1 -l -qg0 -qb run1: ./bsortpar +RTS -N1 -l -qg0 -qb -sbsortpar-N1.log mv bsortpar.exe.eventlog bsortpar-N1.eventlog ./bsortpar +RTS -N2 -l -qg0 -qb -sbsortpar-N2.log mv bsortpar.exe.eventlog bsortpar-N2.eventlog run2: ./bsortpar2 +RTS -N1 -l -qg0 -qb -sbsortpar2-N1.log mv bsortpar2.exe.eventlog bsortpar2-N1.eventlog ./bsortpar2 +RTS -N2 -l -qg0 -qb -sbsortpar2-N2.log mv bsortpar2.exe.eventlog bsortpar2-N2.eventlog run3: ./bsortpar3 +RTS -N1 -l -qg0 -qb -sbsortpar3-N1.log mv bsortpar3.exe.eventlog bsortpar3-N1.eventlog ./bsortpar3 +RTS -N2 -l -qg0 -qb -sbsortpar3-N2.log mv bsortpar3.exe.eventlog bsortpar3-N2.eventlog runs: ./bsort_streaming +RTS -N1 -l -qg0 -qb -Sbsort-streaming-n1.log mv bsort_streaming.exe.eventlog bsort-streaming-n1.eventlog ./bsort_streaming +RTS -N2 -l -qg0 -qb -Sbsort-streaming-n2.log mv bsort_streaming.exe.eventlog bsort-streaming-n2.eventlog clean: rm -f bsort bsortpar bsortpar_streaming *.hi *.o ================================================ FILE: papers/haskell_symposium_2009/bsort.tex ================================================ \subsection{Batcher's Bitonic Parallel Sorter} Batcher's bitonic merger and sorter is a parallel sorting algorithm which has a good implementation in hardware. We have produced an implementation of this algorithm in Haskell originally for circuit generation for FPGAs. However, this executable model also represents an interesting software implicit parallelization exercise because the entire parallel structure of the algorithm is expressed in terms of just one combinator called \codef{par2}: \begin{lstlisting} par2 :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) par2 circuit1 circuit2 (input1, input2) = (output1, output2) where output1 = circuit1 input1 output2 = circuit2 input2 \end{lstlisting} This combinator captures the idea of two circuits which are independent and execute in parallel. This combinator is used to define other combinators which express different ways of performing parallel divide and conquer operations: \begin{lstlisting} two :: ([a] -> [b]) -> [a] -> [b] two r = halve >-> par2 r r >-> unhalve ilv :: ([a] -> [b]) -> [a] -> [b] ilv r = unriffle >-> two r >-> riffle \end{lstlisting} The \codef{halve} combinator breaks a list into two sub-lists of even length and the \codef{unhalve} operate performs the inverse operation. The \codef{riffile} combinator permutes its inputs by breaking a list into two halves and then interleaving the resulting lists. \codef{unriffle} performs the inverse permutation. These combinators are in turn used to define a butterfly parallel processing network which describes a merger: \begin{lstlisting} butterfly circuit [x,y] = circuit [x,y] butterfly circuit input = (ilv (butterfly circuit) >-> evens circuit) input \end{lstlisting} The \codef{evens} combinator breaks an input list into adjacent groups of two elements and applies the \codef{circuit} argument to each group. A column of par-wise processing elements is used to combine the results of two sub-merges: \begin{lstlisting} evens :: ([a] -> [b]) -> [a] -> [b] evens f = chop 2 >-> map f >-> concat \end{lstlisting} The \codef{chop 2} combinator breaks a list into sub-lists of length 2. This parallel Batcher's bitonic merger plus the \codef{evens} function can be used to build a parallel Batcher's bitonic sorter: \begin{lstlisting} sortB cmp [x, y] = cmp [x, y] sortB cmp input = (two (sortB cmp) >-> sndList reverse >-> butterfly cmp) input \end{lstlisting} The \codef{sndList} combinator breaks a list into two halves and applies its argument circuit to the top halve and the identity function to the bottom halve and then concatenates the sub-results into a single list. A straightforward way to perform a semi-explicit parallelization of the \codef{par2} combinator is use \codef{par} to spark off the evaluation of one of the sub-circuits. \begin{lstlisting} par2 :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) par2 circuit1 circuit2 (input1, input2) = output1 `par` (output2 `pseq` (output1, output2)) where output1 = circuit1 input1 output2 = circuit2 input2 \end{lstlisting} This relatively simple change results in a definite performance gain due to parallelism. Here is the log output produced by running a test-bench program with just one Haskell execution context: \begin{verbatim} .\bsortpar.exe +RTS -N1 -l -qg0 -qb -sbsortpar-N1.log SPARKS: 106496 (0 converted, 106496 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 5.32s ( 5.37s elapsed) GC time 0.72s ( 0.74s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 6.04s ( 6.12s elapsed) \end{verbatim} Although many sparks are created none are taken up because there is only one worker thread. The execution trace for this invocation is shown in Figure~\ref{f:bsortpar-n1}. \begin{figure*} \begin{center} \includegraphics[width=17cm]{bsortpar-n1.png} \end{center} \caption{A sequential execution of bsort} \label{f:bsortpar-n1} \end{figure*} \begin{figure*} \begin{center} \includegraphics[width=17cm]{bsortpar-n2.png} \end{center} \caption{A parallel execution of bsort} \label{f:bsortpar-n2} \end{figure*} Running with two threads shows a very good performance improvement: \begin{verbatim} .\bsortpar.exe +RTS -N2 -l -qg0 -qb -sbsortpar-N2.log SPARKS: 106859 (49 converted, 106537 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 4.73s ( 3.03s elapsed) GC time 1.64s ( 0.72s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 6.36s ( 3.75s elapsed) \end{verbatim} This example produces very many sparks most of which fizzle but enough sparks are turned into productive work i.e. 6.36 seconds worth of work done in 3.75 seconds of time. The execution trace for this invocation is shown in Figure~\ref{f:bsortpar-n2}. There is an obvious sequential block of execution between 2.1 seconds and 2.9 seconds and this is due to a sequential component of the algorithm which combines the results of parallel sub-computations i.e the \codef{evens} function. We can use the parallel strategies library to change the sequential application in the definition of \codef{evens} to a parallel map operation: \begin{lstlisting} evens :: ([a] -> [b]) -> [a] -> [b] evens f = chop 2 >-> parMap rwhnf f >-> concat \end{lstlisting} This results in many more sparks being converted: \begin{verbatim} .\bsortpar2.exe +RTS -N2 -l -qg0 -qb -sbsortpar2-N2.log SPARKS: 852737 (91128 converted, 10175 pruned) INIT time 0.00s ( 0.04s elapsed) MUT time 4.95s ( 3.86s elapsed) GC time 1.29s ( 0.65s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 6.24s ( 4.55s elapsed) \end{verbatim} ================================================ FILE: papers/haskell_symposium_2009/fib/Fib1.hs ================================================ ------------------------------------------------------------------------------- module Main where import System.Time import Control.Parallel import System.Mem ------------------------------------------------------------------------------- fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) ------------------------------------------------------------------------------- par2Fib:: Int -> Int -> Int par2Fib a b = f `par` (f + e) where f = fib a e = fib b ------------------------------------------------------------------------------- result :: Int result = par2Fib 36 36 ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "Fib1" performGC t0 <- getClockTime pseq result (return ()) t1 <- getClockTime putStrLn ("fib1 = " ++ show result) putStrLn ("Time: " ++ show (secDiff t0 t1)) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/fib/Fib2.hs ================================================ ------------------------------------------------------------------------------- module Main where import System.Time import Control.Parallel import System.Mem ------------------------------------------------------------------------------- fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) ------------------------------------------------------------------------------- par2Fib:: Int -> Int -> Int par2Fib a b = f `par` (e `pseq` f + e) where f = fib a e = fib b ------------------------------------------------------------------------------- result :: Int result = par2Fib 36 36 ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "Fib2" performGC t0 <- getClockTime pseq result (return ()) t1 <- getClockTime putStrLn ("fib2 = " ++ show result) putStrLn ("Time: " ++ show (secDiff t0 t1)) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/fib/Makefile ================================================ GHC = /c/ghc/ghc/inplace/bin/ghc-stage2 GHC_OPTS = -threaded -eventlog all: $(GHC) $(GHC_OPTS) --make Fib1.hs $(GHC) $(GHC_OPTS) --make Fib2.hs run1: ./Fib1 +RTS -N1 -qg0 -qb ./Fib1 +RTS -N2 -qg0 -qb run2: ./Fib2 +RTS -N1 -qg0 -qb -H50M ./Fib2 +RTS -N2 -qg0 -qb -H500M clean: rm -rf *.hi *.o ================================================ FILE: papers/haskell_symposium_2009/ghc-parallel-tuning.bib ================================================ % $Id: ghc-parallel-tuning.bib#3 2009/07/18 22:48:30 REDMOND\\satnams $ % $Source: //depot/satnams/haskell/ThreadScope/papers/haskell_symposium_2009/ghc-parallel-tuning.bib $ @phdthesis{loidl, author = "H-W. Loidl", title = "Granularity in Large-Scale Parallel Functional Programming", school = "Department of Computing Science, University of Glasgow", year = 1998, month = Mar } @InProceedings{berthold:07, AUTHOR = "Jost Berthold and Rita Loogen", TITLE = "Visualizing Parallel Functional Program Runs: Case Studies with the {E}den {T}race {V}iewer", booktitle = "Parallel Computing: Architectures, Algorithms and Applications. Proceedings of the International Conference ParCo 2007", address = {J\"ulich, Germany}, MONTH = Sept, YEAR = 2007} @article{mohr:91, AUTHOR = "E. Mohr and D. A. Kranz and R. H. Halstead", TITLE = "Lazy Task Creation -- a Technique for Increasing the Granularity of Parallel Programs", JOURNAL = "IEEE Transactions on Parallel and Distributed Systems", NUMBER = 3, VOLUME = 2, YEAR = 1991, MONTH = Jul} @article{trinder:02, author = "P.W. Trinder and H.-W. Loidl and R. F. Pointon", title = "Parallel and {D}istributed {H}askells", journal = "Journal of Functional Programming", number = 5, volume = 12, pages = "469-510", month = Jul, year = 2002 } @article{spj:trin98b, author = "P.W. Trinder and K. Hammond and H.-W. Loidl and Simon Peyton Jones", title = "Algorithm + {S}trategy = {P}arallelism", journal = "Journal of Functional Programming", number = 1, volume = 8, pages = "23-60", month = Jan, year = 1998, url = "http://research.microsoft.com/Users/simonpj/Papers/strategies.ps.gz" } @InProceedings{multicore-ghc, author = {Simon Marlow and Simon Peyton Jones and Satnam Singh}, title = {Runtime Support for Multicore {H}askell}, booktitle = {ICFP'09: The 14th ACM SIGPLAN International Conference on Functional Programming}, year = 2009, address = {Edinburgh, Scotland}} @article{hughes:why-fp-matters, author = {John Hughes}, title = {Why functional programming matters}, journal = {The Computer Journal}, volume = {32}, number = {2}, pages = {98-107}, month = apr, year = {1989}, keywords = {Higher order functions, numerical algorithms, alpha-beta heuristic.} } @inproceedings{jones96concurrent, author = "S. {Peyton Jones} and A. Gordon and S. Finne", title = "Concurrent {Haskell}", booktitle = "Proc.\ of POPL'96", pages = "295--308", year = "1996", publisher = "ACM Press" } @inproceedings{stm, author = {Harris,, Tim and Marlow,, Simon and Peyton-Jones,, Simon and Herlihy,, Maurice}, title = {Composable memory transactions}, booktitle = {PPoPP '05: Proceedings of the tenth ACM SIGPLAN symposium on Principles and practice of parallel programming}, year = {2005}, isbn = {1-59593-080-9}, pages = {48--60}, location = {Chicago, IL, USA}, doi = {http://doi.acm.org/10.1145/1065944.1065952}, publisher = {ACM}, address = {New York, NY, USA}, } @InProceedings{dph, author = {Simon {Peyton Jones} and Roman Leshchinskiy and Gabriele Keller and Manuel M. T. Chakravarty}, title = {Harnessing the Multicores: Nested Data Parallelism in {H}askell}, booktitle = {IARCS Annual Conference on Foundations of Software Technology and Theoretical Computer Science (FSTTCS 2008)}, year = 2008} @incollection{Trinder:gum, topic = "parallel functional programming", author = {PW Trinder and K Hammond and JS Mattson and AS Partridge and SL {Peyton~Jones}}, title = {{GUM}: a portable parallel implementation of {H}askell}, booktitle = "{ACM Conference on Programming Languages Design and Implementation (PLDI'96)}", address = "Philadelphia", publisher = acm, year = 1996, month = may, keywords = {GHC} } @Article{eden, author = {Rita Loogen and Yolanda Ortega-Mallén and Ricardo Peña-Marí}, title = {Parallel Functional Programming in {E}den}, journal = {Journal of Functional Programming}, year = 2005, volume = 3, number = 15, pages = {431--475}} @INPROCEEDINGS{Runciman93profilingparallel, author = {Colin Runciman and David Wakeling}, title = {Profiling Parallel Functional Computations (Without Parallel Machines)}, booktitle = {Glasgow Workshop on Functional Programming}, year = 1993, pages = {236--251}, publisher = {Springer} } ================================================ FILE: papers/haskell_symposium_2009/ghc-parallel-tuning.tex ================================================ \documentclass[twocolumn,9pt]{sigplanconf} \usepackage{url} % \usepackage{code} \usepackage{graphicx} \usepackage{enumerate} \usepackage{listings} \lstset{basicstyle=\fontfamily{cmss} \small, columns=fullflexible, language=Haskell, numbers=none, numberstyle=\tiny, numbersep=2pt, literate={->}{$\rightarrow$\ }{2}{<-}{$\leftarrow$\ }{2}} \newcommand{\codef}[1]{{\fontfamily{cmss}\small#1}} \newcommand{\boldcode}[1]{{\bf\fontfamily{cmss}\small#1}} \usepackage{natbib} \bibpunct();A{}, \let\cite=\citep \nocaptionrule \title{Parallel Performance Tuning for Haskell} \authorinfo{Don Jones Jr.}{University of Kentucky} {donnie@darthik.com} \authorinfo{Simon Marlow}{Microsoft Research} {simonmar@microsoft.com} \authorinfo{Satnam Singh}{Microsoft Research} {satnams@microsoft.com} \begin{document} \maketitle %\makeatactive \begin{abstract} Parallel Haskell programming has entered the mainstream with support now included in GHC for multiple parallel programming models, along with multicore execution support in the runtime. However, tuning programs for parallelism is still something of a black art. Without much in the way of feedback provided by the runtime system, it is a matter of trial and error combined with experience to achieve good parallel speedups. This paper describes an early prototype of a parallel profiling system for multicore programming with GHC. The system comprises three parts: fast event tracing in the runtime, a Haskell library for reading the resulting trace files, and a number of tools built on this library for presenting the information to the programmer. We focus on one tool in particular, a graphical timeline browser called ThreadScope. The paper illustrates the use of ThreadScope through a number of case studies, and describes some useful methodologies for parallelizing Haskell programs. \end{abstract} \category{D.1.1}{Applicative (Functional) Programming}{} \category{D.1.3}{Concurrent Programming}{} \terms{Performance and Measurement} \keywords{Parallel functional programming, performance tuning} \section{Introduction} Life has never been better for the Parallel Haskell programmer: GHC supports multicore execution out of the box, including multiple parallel programming models: Strategies \cite{spj:trin98b}, Concurrent Haskell \cite{jones96concurrent} with STM \cite{stm}, and Data Parallel Haskell \cite{dph}. Performance of the runtime system has received attention recently, with significant improvements in parallel performance available in the forthcoming GHC release \cite{multicore-ghc}. Many of the runtime bottlenecks that hampered parallel performance in earlier GHC versions are much reduced, with the result that it should now be easier to achieve parallel speedups. However, optimizing the runtime only addresses half of the problem; the other half being how to tune a given Haskell program to run effectively in parallel. The programmer still has control over task granularity, data dependencies, speculation, and to some extent evaluation order. Getting these wrong can be disastrous for parallel performance. For example, the granularity should neither be too fine nor too coarse. Too coarse and the runtime will not be able to effectively load-balance to keep all CPUs constantly busy; too fine and the costs of creating and scheduling the tiny tasks outweigh the benefits of executing them in parallel. Current methods for tuning parallel Haskell programs rely largely on trial and error, experience, and an eye for understanding the limited statistics produced at the end of a program's run by the runtime system. What we need are effective ways to measure and collect information about the runtime behaviour of parallel Haskell programs, and tools to communicate this information to the programmer in a way that they can understand and use to solve performance problems with their programs. In this paper we describe a new profiling system developed for the purposes of understanding the parallel execution of Haskell programs. In particular, our system includes a tool called ThreadScope that allows the programmer to interactively browse the parallel execution profile. This paper contributes the following: \begin{itemize} \item We describe the design of our parallel profiling system, and the ThreadScope tool for understanding parallel execution. Our trace file format is fully extensible, and profiling tools built using our framework are both backwards- and forward-compatible with different versions of GHC. \item Through several case studies, we explore how to use ThreadScope for identifying parallel performance problems, and describe a selection of methodologies for parallelising Haskell code. \end{itemize} Earlier methodologies for parallelising Haskell code exist \cite{spj:trin98b}, but there are two crucial differences in the multicore GHC setting. Firstly, the trade-offs are likely to be different, since we are working with a shared-memory heap, and communication is therefore cheap\footnote{though not entirely free, since memory cache hierarchies mean data still has to be shuffled between processors even if that shuffling is not explicitly programmed.}. Secondly, it has recently been discovered that Strategies interact badly with garbage collection \cite{multicore-ghc}, so in this paper we avoid the use of the original Strategies library, relying instead on our own simple hand-rolled parallel combinators. Our work is at an early stage. The ThreadScope tool displays only one particular view of the execution of Parallel Haskell programs (albeit a very useful one). There are a wealth of possibilities, both for improving ThreadScope itself and for building new tools. We cover some of the possibilities in Section~\ref{s:conclusion}. \input{motivation} \section{Case Studies} \input{bsort} \subsection{Soda} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{soda1.png} \end{center} \caption{Soda ThreadScope profile} \label{f:soda-threadscope} \end{figure*} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{soda2.png} \end{center} \caption{Soda ThreadScope profile (zoomed initial portion)} \label{f:soda-threadscope2} \end{figure*} Soda is a program for solving word-search problems: given a rectangular grid of letters, find occurrences of a word from a supplied list, where a word can appear horizontally, vertically, or diagonally, in either direction (giving a total of eight possible orientations). The program has a long history as a Parallel Haskell benchmark \cite{Runciman93profilingparallel}. The version we start with here is a recent incarnation, using a random initial grid with a tunable size. The words do not in fact appear in the grid; the program just fruitlessly searches the entire grid for a predefined list of words. One advantage of this formulation for benchmark purposes is that the program's performance does not depend on the search order, however a disadvantage is that the parallel structure is unrealistically regular. The parallelism is expressed using \codef{parListWHNF} to avoid the space leak issues with the standard strategy implementation of \codef{parList} \cite{multicore-ghc}. The \codef{parListWHNF} function is straightforwardly defined thus: \begin{verbatim} parListWHNF :: [a] -> () parListWHNF [] = () parListWHNF (x:xs) = x `par` parListWHNF xs \end{verbatim} To establish the baseline performance, we run the program using GHC's \texttt{+RTS -s} flags, below is an excerpt of the output: \begin{verbatim} SPARKS: 12 (12 converted, 0 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 7.27s ( 7.28s elapsed) GC time 0.61s ( 0.72s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 7.88s ( 8.00s elapsed) \end{verbatim} We can see that there are only 12 sparks generated by this program: in fact the program creates one spark per word in the search list, of which there are 12. This rather coarse granularity will certainly limit the ability of the runtime to effectively load-balance as we increase the number of cores, but that won't be an issue with a small number of cores. Initially we try with 4 cores, and with GHC's parallel GC enabled: \begin{verbatim} SPARKS: 12 (11 converted, 0 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 8.15s ( 2.21s elapsed) GC time 4.50s ( 1.17s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 12.65s ( 3.38s elapsed) \end{verbatim} Not bad: 8.00/3.38 is a speedup of around 2.4 on 4 cores. But since this program has a highly parallel structure, we might hope to do better. Figure~\ref{f:soda-threadscope} shows the ThreadScope profile for this version of soda. We can see that while an overall view of the runtime shows a reasonable parallelization, if we zoom into the initial part of the run (Figure~\ref{f:soda-threadscope2}) we can see that HEC 0 is running continuously, but threads on the other HECs are running very briefly and then immediately getting blocked (zooming in further would show the individual events). Going back to the program, we can see that the grid of letters is generated lazily by a function \codef{mk\_grid}. What is happening here is that the main thread creates sparks before the grid has been evaluated, and then proceeds to evaluate the grid. As each spark runs, it blocks almost immediately waiting for the main thread to complete evaluation of the grid. This type of blocking is often not disastrous, since a thread will become unblocked soon after the thunk on which it is blocking is evaluated (see the discussion of ``blackholes'' in \citet{multicore-ghc}). There is nevertheless a short delay between the thread becoming runnable again and the runtime noticing this and moving the thread to the run queue. Sometimes this delay can be hidden if the program has other sparks it can run in the meantime, but that is not the case here. There are also costs associated with blocking the thread and waking it up again, which we would like to avoid if possible. One way to avoid this is to evaluate the whole grid before creating any sparks. This is achieved by adding a call to \codef{rnf}: \begin{lstlisting} -- force the grid to be evaluated: evaluate (rnf grid) \end{lstlisting} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{soda3.png} \end{center} \caption{Soda ThreadScope profile (evaluating the input grid eagerly)} \label{f:soda-threadscope3} \end{figure*} The effect on the profile is fairly dramatic (Figure~\ref{f:soda-threadscope3}). We can see that the parallel execution doesn't begin until around 500ms into the execution: creating the grid is taking quite a while. The program also runs slightly faster in parallel now (a 6\% improvement, or a parallel speedup of 2.5 compared to 2.4): \begin{verbatim} SPARKS: 12 (11 converted, 0 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 7.62s ( 2.31s elapsed) GC time 3.35s ( 0.86s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 10.97s ( 3.18s elapsed) \end{verbatim} which we attribute to less blocking and unblocking of threads. We can also see that this program now has a significant sequential section - around 15\% of the execution time - which limits the maximum speedup we can achieve with 4 cores to 2.7, and we are already very close to that at 2.5. To improve parallelism further with this example we would have to parallelize the creation of the initial grid; this probably isn't hard, but it would be venturing beyond the realms of realism somewhat to optimize the creation of the input data for a synthetic benchmark, so we conclude the case study here. It has been instructional to see how thread blocking appears in the ThreadScope profile, and how to avoid it by pre-evaluating data that is needed on multiple CPUs. Here are a couple more factors that may be affecting the speedup we see in this example: \begin{itemize} \item The static grid data is created on one CPU and has to be fetched into the caches of the other CPUs. We hope in the future to be able to show the rate of cache misses (and similar characteristics) on each CPU alongside the other information in the ThreadScope profile, which would highlight issues such as this. \item The granularity is too large: we can see that the HECs finish unevenly, losing a little parallelism at the end of the run. \end{itemize} \subsection{minimax} Minimax is another historical Parallel Haskell program. It is based on an implementation of alpha-beta searching for the game tic-tac-toe, from Hughes' influential paper ``Why Functional Programming Matters'' \cite{hughes:why-fp-matters}. For the purposes of this paper we have generalized the program to use a game board of arbitrary size: the original program used a fixed 3x3 grid, which is too quickly solved to be a useful parallelism benchmark nowadays. However 4x4 still represents a sufficient challenge without optimizing the program further. For the examples that follow, the benchmark is to evaluate the game tree 6 moves ahead, on a 4x4 grid in which the first 4 moves have already been randomly played. This requires evaluating a maximum of roughly 500,000,000 positions, although parts of the game tree will be pruned, as we shall describe shortly. We will explore a few different parallelizations of this program using ThreadScope. The function for calculating the best line in the game is \codef{alternate}: \begin{lstlisting}[columns=flexible] alternate depth player f g board = move : alternate depth opponent g f board' where move@(board',_) = best f possibles scores scores = map (bestMove depth opponent g f) possibles possibles = newPositions player board opponent = opposite player \end{lstlisting} This function calculates the sequence of moves in the game that give the best outcome (as calculated by the alpha-beta search) for each player. At each stage, we generate the list of possible moves (\codef{newPositions}), evaluate each move by alpha-beta search on the game tree (\codef{bestMove}), and pick the best one (\codef{best}). Let's run the program sequentially first to establish the baseline runtime: \begin{verbatim} 14,484,898,888 bytes allocated in the heap INIT time 0.00s ( 0.00s elapsed) MUT time 8.44s ( 8.49s elapsed) GC time 3.49s ( 3.51s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 11.94s ( 12.00s elapsed) \end{verbatim} One obvious way to parallelize this problem is to evaluate each of the possible moves in parallel. This is easy to achieve with a \codef{parListWHNF} strategy: \begin{lstlisting} scores = map (bestMove depth opponent g f) possibles `using` parListWHNF \end{lstlisting} where \codef{using} is defined to apply its first argument to its second argument and then return the result evaluated to weak-head normal form. \begin{lstlisting} x `using` s = s x `seq` x \end{lstlisting} And indeed this does yield a reasonable speedup: \begin{verbatim} 14,485,148,912 bytes allocated in the heap SPARKS: 12 (11 converted, 0 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 9.19s ( 2.76s elapsed) GC time 7.01s ( 1.75s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 16.20s ( 4.52s elapsed) \end{verbatim} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{minimax1.png} \end{center} \caption{Minimax ThreadScope profile} \label{f:minimax-threadscope1} \end{figure*} A speedup of 2.7 on 4 processors is a good start! However, looking at the ThreadScope profile (Figure~\ref{f:minimax-threadscope1}), we can see that there is a jagged edge on the right: our granularity is too large, and we don't have enough work to keep all the processors busy until the end. What's more, as we can see from the runtime statistics, there were only 12 sparks, corresponding to the 12 possible moves in the 4x4 grid after 4 moves have already been played. In order to scale to more CPUs we will need to find more parallelism. The game tree evaluation is defined as follows: \begin{lstlisting}[columns=flexible] bestMove :: Int -> Piece -> Player -> Player -> Board -> Evaluation bestMove depth p f g = mise f g . cropTree . mapTree static . prune depth . searchTree p \end{lstlisting} Where \codef{searchTree} lazily generates a search tree starting from the current position, with player \texttt{p} to play next. The function \codef{prune} prunes the search tree to the given depth, and \codef{mapTree static} applies a static evaluation function to each node in the tree. The function \codef{cropTree} prunes branches below a node in which the game has been won by either player. Finally, \codef{mise} performs the alpha-beta search, where \codef{f} and \codef{g} are the min and max functions over evaluations for the current player \codef{p}. We must be careful with parallelization here, because the algorithm is relying heavily on lazy evaluation to avoid evaluating parts of the game tree. Certainly we don't want to evaluate beyond the prune depth, and we also don't want to evaluate beyond a node in which one player has already won (\codef{cropTree} prunes further moves after a win). The alpha-beta search will prune even more of the tree, since there is no point exploring any further down a branch if it has already been established that there is a winning move. So unless we are careful, some of the parallelism we add here may be wasted speculation. The right place to parallelize is in the alpha-beta search itself. Here is the sequential code: \begin{lstlisting}[columns=flexible] mise :: Player -> Player -> Tree Evaluation -> Evaluation mise f g (Branch a []) = a mise f g (Branch _ l) = foldr f (g OWin XWin) (map (mise g f) l) \end{lstlisting} The first equation looks for a leaf, and returns the evaluation of the board at that point. A leaf is either a completed game (either drawn or a winning position for one player), or the result of pruning the search tree. The second equation is the interesting one: \codef{foldr f} picks the best option for the current player from the list of evaluations at the next level. The next level evaluations are given by \codef{map (mise g f) l}, which picks the best options for the \emph{other} player (which is why the \codef{f} and \codef{g} are reversed). The \codef{map} here is a good opportunity for parallelism. Adding a \codef{parListWHNF} strategy should be enough: \begin{lstlisting} mise f g (Branch _ l) = foldr f (g OWin XWin) (map (mise g f) l `using` parListWHNF) \end{lstlisting} However, this will try to parallelize every level of the search, leading to some sparks with very fine granularity. Also it may introduce too much speculation: elements in each list after a win do not need to be evaluated. Indeed, if we try this we get: \begin{verbatim} 22,697,543,448 bytes allocated in the heap SPARKS: 4483767 (639031 converted, 3457369 pruned) INIT time 0.00s ( 0.01s elapsed) MUT time 16.19s ( 4.13s elapsed) GC time 27.21s ( 6.82s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 43.41s ( 10.95s elapsed) \end{verbatim} We ran a lot of sparks (600k), but we didn't achieve much speedup over the sequential version. One clue that we are actually speculating useless work is the amount of allocation. In the sequential run the runtime reported 14GB allocated, but this parallel version allocated 22GB\footnote{CPU time is not a good measure of speculative work, because in the parallel runtime threads can sometimes be spinning while waiting for work, particularly in the GC.}. In order to eliminate some of the smaller sparks, we can parallelize the alpha-beta to a fixed depth. This is done by introducing a new variant of \codef{mise}, \codef{parMise}, that applies the \codef{parListWHNF} strategy up to a certain depth, and then calls the sequential \codef{mise} beyond that. Just using a depth of one gives quite good results: \begin{verbatim} SPARKS: 132 (120 converted, 12 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 8.82s ( 2.59s elapsed) GC time 6.65s ( 1.70s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 15.46s ( 4.30s elapsed) \end{verbatim} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{minimax2.png} \end{center} \caption{Minimax ThreadScope profile (with parMise 1)} \label{f:minimax-threadscope2} \end{figure*} Though as we can see from the ThreadScope profile (Figure~\ref{f:minimax-threadscope2}), there are some gaps. Increasing the threshold to two works nicely: \begin{verbatim} SPARKS: 1452 (405 converted, 1046 pruned) INIT time 0.00s ( 0.03s elapsed) MUT time 8.86s ( 2.31s elapsed) GC time 6.32s ( 1.57s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 15.19s ( 3.91s elapsed) \end{verbatim} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{minimax3.png} \end{center} \caption{Minimax ThreadScope profile (with parMise 2)} \label{f:minimax-threadscope3} \end{figure*} We have now achieved a speedup of 3.1 on 4 cores against the sequential code, and as we can see from the final ThreadScope profile (Figure~\ref{f:minimax-threadscope3}) all our cores are kept busy. We found that increasing the threshold to 3 starts to cause speculation of unnecessary work. In 4x4 tic-tac-toe most positions are a draw, so it turns out that there is little speculation in the upper levels of the alpha-beta search, but as we get deeper in the tree, we find positions that are a certain win for one player or another, which leads to speculative work if we evaluate all the moves in parallel. Ideally GHC would have better support for speculation: right now, speculative sparks are not garbage collected when they are found to be unreachable. We do plan to improve this in the future, but unfortunately changing the GC policy for sparks is incompatible with the current formulation of Strategies \cite{multicore-ghc}. \input{threadring} \input{infrastructure} \input{related-work} \section{Conclusions and Further work} \label{s:conclusion} We have shown how thread-based profile information can be effectively used to help understand and fix parallel performance bugs in both Parallel Haskell and Concurrent Haskell programs, and we expect these profiling tools to also be of benefit to developers using Data Parallel Haskell in the future. The ability to profile parallel Haskell programs plays an important part in the development of such programs because the analysis process motivates the need to develop specialized strategies to help control evaluation order, extent and granularity as we demonstrated in the minmax example. Here are some of the future directions we would like to take this work: \begin{itemize} \item Improve the user interface and navigation of ThreadScope. For example, it would be nice to filter the display to show just a subset of the threads, in order to focus on the behaviour of a particular thread or group of threads. \item It would also be useful to understand how threads interact with each other via \codef{MVars} e.g. to make it easier to see which threads are blocked on read and write accesses to \codef{MVar}s. \item The programmer should be able to generate events programmatically, in order to mark positions in the timeline so that different parts of the program's execution can easily be identified and separated in ThreadScope. \item It would be straightforward to produce graphs similar to those from the GpH and GranSim programming tools \cite{trinder:02,loidl}, either by writing a Haskell program to translate the GHC trace files into the appropriate input for these tools, or by rewriting the tools themselves in Haskell. \item Combine the timeline profile with information from the OS and CPU. For example, for IO-bound concurrent programs we might like to see IO or network activity displayed on the timeline. Information from CPU performance counters could also be superimposed or displayed alongside the thread timelines, providing insight into cache behaviour, for example. \item Have the runtime system generate more tracing information, so that ThreadScope can display information about such things as memory usage, run queue sizes, spark pool sizes, and foreign call activity. \end{itemize} \section*{Acknowledgments} The authors would like to acknowledge the work of the developers of previous Haskell concurrent and parallel profiling systems which have provided much inspiration for our own work. Specifically work on GpH, GranSim and Eden was particularly useful. We wish to thank Microsoft Research for funding Donnie Jones' visit to Cambridge in 2008 during which he developed an early prototype of event tracing in GHC. {\small \bibliographystyle{plainnat} \bibliography{ghc-parallel-tuning} } \end{document} ================================================ FILE: papers/haskell_symposium_2009/infrastructure.tex ================================================ \section{Profiling Infrastructure} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{eventbench.png} \end{center} \caption{Synthetic event benchmark} \label{f:event-bench} \end{figure*} Our profiling framework comprises three parts: \begin{itemize} \item Support in GHC's runtime for tracing events to a log file at runtime. The tracing is designed to be as lightweight as possible, so as not to have any significant impact on the behaviour of the program being measured. \item A Haskell library \codef{ghc-events} that can read the trace file generated by the runtime and build a Haskell data structure representing the trace. \item Multiple tools make use of the \codef{ghc-events} library to read and analyze trace files. \end{itemize} Having a single trace-file format and a library that parses it means that it is easy to write a new tool that works with GHC trace files: just import the \codef{ghc-events} package and write code that uses the Haskell data structures directly. We have already built several such tools ourselves, some of which are merely proof-of-concept experiments, but the \codef{ghc-events} library makes it almost trivial to create new tools: \begin{itemize} \item A simple program that just prints out the (sorted) contents of the trace file as text. Useful for checking that a trace file can be parsed, and for examining the exact sequence of events. \item The ThreadScope graphical viewer. \item A tool that parses a trace file and generates a PDF format timeline view, similar to the ThreadScope view. \item A tool that generates input in the format expected by the GtkWave circuit waveform viewer. This was used as an early prototype for ThreadScope, since the timeline view that we want to display has a lot in common with the waveform diagrams that gtkwave displays and browses. \end{itemize} \subsection{Fast runtime tracing} The runtime system generates trace files that log certain events and the time at which they occurred. The events are typically those related to thread activity; for example, ``HEC 0 started to run thread 3'', or ``thread 5 blocked on an MVar''. The kinds of events we can log are limited only by the extra overhead incurred by the act of logging them. Minimizing the overhead of event logging is something we care about: the goal is to profile the actual runtime behaviour of the program, so it is important that, as far as possible, we avoid disturbing the behaviour that we are trying to profile. In the GHC runtime, a pre-allocated event buffer is used by each HEC to store generated events. By doing so, we avoid any dynamic memory allocation overhead, and require no locks since the buffers are HEC-local. Yet, this requires us to flush the buffer to the filesystem once it becomes full, but since the buffer is a fixed size we pay a near-constant penalty for each flush and a deterministic delay on the GHC runtime. The HEC-local buffers are flushed independently, which means that events in the log file appear out-of-order and have to be sorted. Sorting of the events is easily performed by the profiling tool after reading in the log file using the \codef{ghc-events} library. To measure the speed at which the GHC runtime can log events, we used a C program (no Haskell code, just using the GHC runtime system as a library) that simply generates 2,000,000 events, alternating between ``thread start'' and ``thread stop'' events. Our program generates a 34MB trace file and runs in 0.31 seconds elapsed time: \begin{verbatim} INIT time 0.00s ( 0.02s elapsed) MUT time 0.22s ( 0.29s elapsed) GC time 0.00s ( 0.00s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 0.22s ( 0.31s elapsed) \end{verbatim} which gives a rough figure of 150ns for each event on average. Looking at the ThreadScope view of this program (Figure~\ref{f:event-bench}) we can clearly see where the buffer flushes are happening, and that each one is about 5ms long. An alternative approach is to use memory-mapped files, and write our events directly into memory, leaving the actual file writing to the OS. This would allow writing to be performed asynchronously, which would hopefully reduce the impact of the buffer flush. According to \codef{strace} on Linux, the above test program is spending 0.7s writing buffers, so making this asynchronous would save us about 30ns per event on average. However, on a 32-bit machine where we can't afford to reserve a large amount of address space for the whole log file, we would still have to occasionally flush and remap new portions of the file. This alternative approach is something we plan to explore in the future. % how much impact does this have on runtimes? To see how much impact event logging has on real execution times, we took a parallel version of the canonical Fibonacci function, \codef{parfib}, and compared the time elapsed with and without event logging enabled for 50 executions of parfib on an Intel(R) Core(TM)2 Duo CPU T5250 1.50GHz, using both cores. The program generates about 2,000,000 events during the run, and generates a 40MB log file. \begin{verbatim} parfib eventlog ./Main 40 10 +RTS -N2 -l -RTS Avg Time Elapsed Standard Deviation 20.582757s 0.789547s parfib without eventlog ./Main 40 10 +RTS -N2 -RTS Avg Time Elapsed Standard Deviation 17.447493s 1.352686s \end{verbatim} Considering the significant number of events generated in the traces and the very detailed profiling information made available by these traces, the overhead does not have an immense impact at approximately 10-25\% increase in elapsed time. In the case of parfib, the event representing the creation of a new spark is dominant, comprising at least 80\% of the the events generated. In fact, it is debatable whether we should be logging the creation of a spark, since the cost of logging this event is likely to be larger than the cost of creating the spark itself - a spark creation is simply a write into a circular buffer. For parallel quicksort, far fewer sparks are created and most of the computation is spent in garbage collection; thus, we can achieve an almost unnoticeable overhead from event tracing. The parallel quicksort example involved sorting a list of 100,000 randomly generated integers and was performed in the same manner as parfib where we compare with event logging and without, yet in this test we perform 100 executions on an Intel(R) Core(TM) 2 Quad CPU 3.0Ghz. \begin{verbatim} parquicksort eventlog ./Main +RTS -N4 -l -RTS Avg Time Elapsed Standard Deviation 14.201385s 2.954869 parquicksort without eventlog ./Main +RTS -N4 -RTS Avg Time Elapsed Standard Deviation 15.187529s 3.385293s \end{verbatim} Since parallel quicksort spent the majority of the computation doing useful work, particularly garbage collection of the created lists, a trace file of only approximately 5MB and near 300,000 events was created and the overhead of event tracing is not noticeable. The crux of the event tracing is that even when a poorly performing program utilizes event tracing, the overhead should still not be devastating to the program's performance, but best of all on a program with high utilization event tracing should barely affect the performance. \subsection{An extensible file format} We believe it is essential that the trace file format is both backwards and forwards compatible, and architecture independent. In particular, this means that: \begin{itemize} \item If you build a newer version of a tool, it will still work with the trace files you already have, and trace files generated by programs compiled with older versions of GHC. \item If you upgrade your GHC and recompile your programs, the trace files will still work with any profiling tools you already have. \item Trace files do not have a shelf life. You can keep your trace files around, safe in the knowledge that they will work with future versions of profiling tools. Trace files can be archived, and shared between machines. \end{itemize} Nevertheless, we don't expect the form of trace files to remain completely static. In the future we will certainly want to add new events, and add more information to existing events. We therefore need an extensible file format. Informally, our trace files are structured as follows: \begin{itemize} \item A list of \emph{event types}. An event-type is a variable-length structure that describes one kind of event. The event-type structure contains \begin{itemize} \item A unique number for this event type \item A field describing the length in bytes of an instance of the event, or zero for a variable-length event. \item A variable-length string (preceded by its length) describing this event (for example ``thread created'') \item A variable-length field (preceded by its length) for future expansion. We might in the future want to add more fields to the event-type structure, and this field allows for that. \end{itemize} \item A list of \emph{events}. Each event begins with an event number that corresponds to one of the event types defined earlier, and the length of the event structure is given by the event type (or it has variable length). The event also contains \begin{itemize} \item A nanosecond-resolution timestamp. \item For a variable-length event, the length of the event. \item Information specific to this event, for example which CPU it occurred on. If the parser knows about this event, then it can parse the rest of the event's information, otherwise it can skip over this field because its length is known. \end{itemize} \end{itemize} The unique numbers that identify events are shared knowledge between GHC and the \codef{ghc-events} library. When creating a new event, a new unique identifier is chosen; identifiers can never be re-used. Even when parsing a trace file that contains new events, the parser can still give a timestamp and a description of the unknown events. The parser might encounter an event-type that it knows about, but the event-type might contain new unknown fields. The parser can recognize this situation and skip over the extra fields, because it knows the length of the event from the event-type structure. Therefore when a tool encounters a new log file it can continue to provide consistent functionality. Of course, there are scenarios in which it isn't possible to provide this ideal graceful degradation. For example, we might construct a tool that profiles a particular aspect of the behaviour of the runtime, and in the future the runtime might be redesigned to behave in a completely different way, with a new set of events. The old events simply won't be generated any more, and the old tool won't be able to display anything useful with the new trace files. Still, we expect that our extensible trace file format will allow us to smooth over the majority of forwards- and backwards-compatibility issues that will arise between versions of the tools and GHC runtime. Moreover, extensibility costs almost nothing, since the extra fields are all in the event-types header, which has a fixed size for a given version of GHC. ================================================ FILE: papers/haskell_symposium_2009/motivation.tex ================================================ \section{Profiling Motivation} Haskell provides a mechanism to allow the user to control the granularity of parallelism by indicating what computations may be usefully carried out in parallel. This is done by using functions from the \codef{Control.Parallel} module. The interface for \codef{Control.Parallel} is shown below: \begin{lstlisting}[columns=flexible] par :: a -> b -> b pseq :: a -> b -> b \end{lstlisting} The function \codef{par} indicates to the GHC run-time system that it may be beneficial to evaluate the first argument in parallel with the second argument. The \codef{par} function returns as its result the value of the second argument. One can always eliminate \codef{par} from a program by using the following identity without altering the semantics of the program: \begin{lstlisting} par a b = b \end{lstlisting} A thread is not necessarily created to compute the value of the expression \codef{a}. Instead, the GHC run-time system creates a {\em spark} which has the potential to be executed on a different thread from the parent thread. A sparked computation expresses the possibility of performing some speculative evaluation. Since a thread is not necessarily created to compute the value of \codef{a}, this approach has some similarities with the notion of a {\em lazy future}~\cite{mohr:91}. % SDM: removed, not necessary for the Haskell Symposium. Also the % following paragraph doesn't make sense. % % Sometimes it is convenient to write a function with two arguments as an % infix function and this is done in Haskell by writing backticks % around the function: % \begin{lstlisting} % a `par` b % \end{lstlisting} We call such programs semi-explicitly parallel because the programmer has provided a hint about the appropriate level of granularity for parallel operations and the system implicitly creates threads to implement the concurrency. The user does not need to explicitly create any threads or write any code for inter-thread communication or synchronization. To illustrate the use of \codef{par} we present a program that performs two compute intensive functions in parallel. The first compute intensive function we use is the notorious Fibonacci function: \begin{lstlisting} fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) \end{lstlisting} The second compute intensive function we use is the \codef{sumEuler} function taken from~\cite{trinder:02}: \begin{lstlisting} mkList :: Int -> [Int] mkList n = [1..n-1] relprime :: Int -> Int -> Bool relprime x y = gcd x y == 1 euler :: Int -> Int euler n = length (filter (relprime n) (mkList n)) sumEuler :: Int -> Int sumEuler = sum . (map euler) . mkList \end{lstlisting} The function that we wish to parallelize adds the results of calling \codef{fib} and \codef{sumEuler}: \begin{lstlisting} sumFibEuler :: Int -> Int -> Int sumFibEuler a b = fib a + sumEuler b \end{lstlisting} As a first attempt we can try to use \codef{par} to speculatively spark off the computation of \codef{fib} while the parent thread works on \codef{sumEuler}: \begin{lstlisting} -- A wrong way to parallelize f + e parSumFibEuler :: Int -> Int -> Int parSumFibEuler a b = f `par` (f + e) where f = fib a e = sumEuler b \end{lstlisting} To create two workloads that take roughly the same amount of time to execute we performed some experiments which show that \codef{fib 38} takes roughly the same time to execute as \codef{sumEuler 5300}. The execution trace for this program as displayed by ThreadScope is shown in Figure~\ref{f:wrongpar}. This figure shows the execution trace of two Haskell Execution Contexts (HECs), where each HEC corresponds to a processor core. The $x$-axis is time. The purple portion of each line shows at what time intervals a thread is running and the orange (lighter coloured) bar shows when garbage collection is occurring. Garbage collections are always ``stop the world'', in that all Haskell threads must stop during GC, but a GC may be performed either sequentially on one HEC or in parallel on multiple HECs; in Figure~\ref{f:wrongpar} we are using parallel GC. \begin{figure*} \begin{center} \includegraphics[width=18cm]{SumEuler1-N2-eventlog.pdf} \end{center} \caption{No parallelization of \codef{f `par` (f + e)}} \label{f:wrongpar} \end{figure*} We can examine the statistics produced by the runtime system (using the flags \texttt{+RTS -s -RTS}) to help understand what went wrong: \begin{verbatim} SPARKS: 1 (0 converted, 0 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 9.39s ( 9.61s elapsed) GC time 0.37s ( 0.24s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 9.77s ( 9.85s elapsed) \end{verbatim} The log shows that although a single spark was created, no sparks where ``converted'', i.e. executed. In this case the performance bug is because the main thread immediately starts to work on the evaluation of \codef{fib 38} itself which causes this spark to \emph{fizzle}. A fizzled spark is one that is found to be under evaluation or already evaluated, so there is no profit in evaluating it in parallel. The log also shows that the total amount of computation work done is 9.39 seconds (the \codef{MUT} time); the time spent performing garbage collection was 0.37 seconds (the \codef{GC} time); and the total amount of work done amounts to 9.77 seconds with 9.85 seconds of wall clock time. A profitably parallel program will have a wall clock time (elapsed time) which is less than the total time\footnote{although to measure actual parallel speedup, the wall-clock time for the parallel execution should be compared to the wall-clock time for the sequential execution.}. One might be tempted to fix this problem by swapping the arguments to the \codef{+} operator in the hope that the main thread will work on \codef{sumEuler} while the sparked thread works on \codef{fib}: \begin{lstlisting} -- Maybe a lucky parallelization parSumFibEuler :: Int -> Int -> Int parSumFibEuler a b = f `par` (e + f) where f = fib a e = sumEuler b \end{lstlisting} This results in the execution trace shown in Figure~\ref{f:lucky} which shows a sparked thread being taken up by a spare worker thread. \begin{figure*} \begin{center} \includegraphics[width=18cm]{SumEuler2-N2-eventlog.pdf} \end{center} \caption{A lucky parallelization of \codef{f `par` (e + f)}} \label{f:lucky} \end{figure*} The execution log for this program shows that a spark was used productively and the elapsed time has dropped from 9.85s to 5.33s: \begin{verbatim} SPARKS: 1 (1 converted, 0 pruned) INIT time 0.00s ( 0.00s elapsed) MUT time 9.47s ( 4.91s elapsed) GC time 0.69s ( 0.42s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 10.16s ( 5.33s elapsed) \end{verbatim} While this trick works, it only works by accident. There is no fixed evaluation order for the arguments to \codef{+}, and GHC might decide to use a different evaluation order tomorrow. To make the parallelism more robust, we need to be explicit about the evaluation order we intend. The way to do this is to use \codef{pseq}\footnote{Previous work has used \codef{seq} for sequential evaluation ordering, but there is a subtle difference between Haskell's \codef{seq} and the operator we need for sequencing here. The details are described in \citet{multicore-ghc}.} in combination with \codef{par}, the idea being to ensure that the main thread works on \codef{sumEuler} while the sparked thread works on \codef{fib}: \begin{lstlisting} -- A correct parallelization that does not depend on -- the evaluation order of + parSumFibEuler :: Int -> Int -> Int parSumFibEuler a b = f `par` (e `pseq` (f + e)) where f = fib a e = sumEuler b \end{lstlisting} This version does not make any assumptions about the evaluation order of \codef{+}, but relies only on the evaluation order of \codef{pseq}, which is guaranteed to be stable. This example as well as our wider experience of attempting to write semi-explicit parallel programs shows that it is often very difficult to understand if and when opportunities for parallelism expressed through \codef{par} are effectively taken up and to also understand how operations like garbage collection influence the performance of the program. Until recently one only had available high level summary information about the overall execution of a parallel Haskell program. In this paper we describe recent improvements to the Haskell run-time which allow a much more detailed profile to be generated which can then be used to help debug performance problems. ================================================ FILE: papers/haskell_symposium_2009/related-work.tex ================================================ \section{Related Work} GranSim~\cite{loidl} is an event-driven simulator for the parallel execution of Glasgow Parallel Haskell (GPH) programs which allows the parallel behaviour of Haskell programs to be analyzed by instantiating any number of virtual processors which are emulated by a single thread on the host machine. GranSim has an associated set of visualization tools which show overall activity, per-processor activity, and per-thread activity. There is also a separate tool for analyzing the granularity of the generated threads. The GUM system~\cite{Trinder:gum} is a portable parallel implementation of Haskell with good profiling support for distributed implementations. Recent work on the Eden Trace Viewer~\cite{berthold:07} illustrates how higher level trace information can help with performance tuning. We hope to adopt many of the lessons learned in future versions of ThreadScope. ================================================ FILE: papers/haskell_symposium_2009/sigplanconf.cls ================================================ %----------------------------------------------------------------------------- % % LaTeX Class/Style File % % Name: sigplanconf.cls % Purpose: A LaTeX 2e class file for SIGPLAN conference proceedings. % This class file supercedes acm_proc_article-sp, % sig-alternate, and sigplan-proc. % % Author: Paul C. Anagnostopoulos % Windfall Software % 978 371-2316 % paul@windfall.com % % Created: 12 September 2004 % % Revisions: See end of file. % %----------------------------------------------------------------------------- \NeedsTeXFormat{LaTeX2e}[1995/12/01] \ProvidesClass{sigplanconf}[2005/07/14 v1.2 ACM SIGPLAN Proceedings] % The following few pages contain LaTeX programming extensions adapted % from the ZzTeX macro package. % Token Hackery % ----- ------- \def \@expandaftertwice {\expandafter\expandafter\expandafter} \def \@expandafterthrice {\expandafter\expandafter\expandafter\expandafter \expandafter\expandafter\expandafter} % This macro discards the next token. \def \@discardtok #1{}% token % This macro removes the `pt' following a dimension. {\catcode `\p = 12 \catcode `\t = 12 \gdef \@remover #1pt{#1} } % \catcode % This macro extracts the contents of a macro and returns it as plain text. % Usage: \expandafter\@defof \meaning\macro\@mark \def \@defof #1:->#2\@mark{#2} % Control Sequence Names % ------- -------- ----- \def \@name #1{% {\tokens} \csname \expandafter\@discardtok \string#1\endcsname} \def \@withname #1#2{% {\command}{\tokens} \expandafter#1\csname \expandafter\@discardtok \string#2\endcsname} % Flags (Booleans) % ----- ---------- % The boolean literals \@true and \@false are appropriate for use with % the \if command, which tests the codes of the next two characters. \def \@true {TT} \def \@false {FL} \def \@setflag #1=#2{\edef #1{#2}}% \flag = boolean % IF and Predicates % -- --- ---------- % A "predicate" is a macro that returns \@true or \@false as its value. % Such values are suitable for use with the \if conditional. For example: % % \if \@oddp{\x} \else \fi % A predicate can be used with \@setflag as follows: % % \@setflag \flag = {} % Here are the predicates for TeX's repertoire of conditional % commands. These might be more appropriately interspersed with % other definitions in this module, but what the heck. % Some additional "obvious" predicates are defined. \def \@eqlp #1#2{\ifnum #1 = #2\@true \else \@false \fi} \def \@neqlp #1#2{\ifnum #1 = #2\@false \else \@true \fi} \def \@lssp #1#2{\ifnum #1 < #2\@true \else \@false \fi} \def \@gtrp #1#2{\ifnum #1 > #2\@true \else \@false \fi} \def \@zerop #1{\ifnum #1 = 0\@true \else \@false \fi} \def \@onep #1{\ifnum #1 = 1\@true \else \@false \fi} \def \@posp #1{\ifnum #1 > 0\@true \else \@false \fi} \def \@negp #1{\ifnum #1 < 0\@true \else \@false \fi} \def \@oddp #1{\ifodd #1\@true \else \@false \fi} \def \@evenp #1{\ifodd #1\@false \else \@true \fi} \def \@rangep #1#2#3{\if \@orp{\@lssp{#1}{#2}}{\@gtrp{#1}{#3}}\@false \else \@true \fi} \def \@tensp #1{\@rangep{#1}{10}{19}} \def \@dimeqlp #1#2{\ifdim #1 = #2\@true \else \@false \fi} \def \@dimneqlp #1#2{\ifdim #1 = #2\@false \else \@true \fi} \def \@dimlssp #1#2{\ifdim #1 < #2\@true \else \@false \fi} \def \@dimgtrp #1#2{\ifdim #1 > #2\@true \else \@false \fi} \def \@dimzerop #1{\ifdim #1 = 0pt\@true \else \@false \fi} \def \@dimposp #1{\ifdim #1 > 0pt\@true \else \@false \fi} \def \@dimnegp #1{\ifdim #1 < 0pt\@true \else \@false \fi} \def \@vmodep {\ifvmode \@true \else \@false \fi} \def \@hmodep {\ifhmode \@true \else \@false \fi} \def \@mathmodep {\ifmmode \@true \else \@false \fi} \def \@textmodep {\ifmmode \@false \else \@true \fi} \def \@innermodep {\ifinner \@true \else \@false \fi} \long\def \@codeeqlp #1#2{\if #1#2\@true \else \@false \fi} \long\def \@cateqlp #1#2{\ifcat #1#2\@true \else \@false \fi} \long\def \@tokeqlp #1#2{\ifx #1#2\@true \else \@false \fi} \long\def \@xtokeqlp #1#2{\expandafter\ifx #1#2\@true \else \@false \fi} \long\def \@definedp #1{% \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname \relax \@false \else \@true \fi} \long\def \@undefinedp #1{% \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname \relax \@true \else \@false \fi} \def \@emptydefp #1{\ifx #1\@empty \@true \else \@false \fi}% {\name} \let \@emptylistp = \@emptydefp \long\def \@emptyargp #1{% {#n} \@empargp #1\@empargq\@mark} \long\def \@empargp #1#2\@mark{% \ifx #1\@empargq \@true \else \@false \fi} \def \@empargq {\@empargq} \def \@emptytoksp #1{% {\tokenreg} \expandafter\@emptoksp \the#1\@mark} \long\def \@emptoksp #1\@mark{\@emptyargp{#1}} \def \@voidboxp #1{\ifvoid #1\@true \else \@false \fi} \def \@hboxp #1{\ifhbox #1\@true \else \@false \fi} \def \@vboxp #1{\ifvbox #1\@true \else \@false \fi} \def \@eofp #1{\ifeof #1\@true \else \@false \fi} % Flags can also be used as predicates, as in: % % \if \flaga \else \fi % Now here we have predicates for the common logical operators. \def \@notp #1{\if #1\@false \else \@true \fi} \def \@andp #1#2{\if #1% \if #2\@true \else \@false \fi \else \@false \fi} \def \@orp #1#2{\if #1% \@true \else \if #2\@true \else \@false \fi \fi} \def \@xorp #1#2{\if #1% \if #2\@false \else \@true \fi \else \if #2\@true \else \@false \fi \fi} % Arithmetic % ---------- \def \@increment #1{\advance #1 by 1\relax}% {\count} \def \@decrement #1{\advance #1 by -1\relax}% {\count} % Options % ------- \@setflag \@blockstyle = \@false \@setflag \@copyrightwanted = \@true \@setflag \@explicitsize = \@false \@setflag \@mathtime = \@false \@setflag \@ninepoint = \@true \@setflag \@onecolumn = \@false \@setflag \@preprint = \@false \newcount{\@numheaddepth} \@numheaddepth = 3 \@setflag \@times = \@false % Note that all the dangerous article class options are trapped. \DeclareOption{9pt}{\@setflag \@ninepoint = \@true \@setflag \@explicitsize = \@true} \DeclareOption{10pt}{\PassOptionsToClass{10pt}{article}% \@setflag \@ninepoint = \@false \@setflag \@explicitsize = \@true} \DeclareOption{11pt}{\PassOptionsToClass{11pt}{article}% \@setflag \@ninepoint = \@false \@setflag \@explicitsize = \@true} \DeclareOption{12pt}{\@unsupportedoption{12pt}} \DeclareOption{a4paper}{\@unsupportedoption{a4paper}} \DeclareOption{a5paper}{\@unsupportedoption{a5paper}} \DeclareOption{b5paper}{\@unsupportedoption{b5paper}} \DeclareOption{blockstyle}{\@setflag \@blockstyle = \@true} \DeclareOption{cm}{\@setflag \@times = \@false} \DeclareOption{computermodern}{\@setflag \@times = \@false} \DeclareOption{executivepaper}{\@unsupportedoption{executivepaper}} \DeclareOption{indentedstyle}{\@setflag \@blockstyle = \@false} \DeclareOption{landscape}{\@unsupportedoption{landscape}} \DeclareOption{legalpaper}{\@unsupportedoption{legalpaper}} \DeclareOption{letterpaper}{\@unsupportedoption{letterpaper}} \DeclareOption{mathtime}{\@setflag \@mathtime = \@true} \DeclareOption{nocopyrightspace}{\@setflag \@copyrightwanted = \@false} \DeclareOption{notitlepage}{\@unsupportedoption{notitlepage}} \DeclareOption{numberedpars}{\@numheaddepth = 4} %%%\DeclareOption{onecolumn}{\@setflag \@onecolumn = \@true} \DeclareOption{preprint}{\@setflag \@preprint = \@true} \DeclareOption{times}{\@setflag \@times = \@true} \DeclareOption{titlepage}{\@unsupportedoption{titlepage}} \DeclareOption{twocolumn}{\@setflag \@onecolumn = \@false} \DeclareOption*{\PassOptionsToClass{\CurrentOption}{article}} \ExecuteOptions{9pt,indentedstyle,times} \@setflag \@explicitsize = \@false \ProcessOptions \if \@onecolumn \if \@notp{\@explicitsize}% \@setflag \@ninepoint = \@false \PassOptionsToClass{11pt}{article}% \fi \PassOptionsToClass{twoside,onecolumn}{article} \else \PassOptionsToClass{twoside,twocolumn}{article} \fi \LoadClass{article} \def \@unsupportedoption #1{% \ClassError{proc}{The standard '#1' option is not supported.}} % Utilities % --------- \newcommand{\setvspace}[2]{% #1 = #2 \advance #1 by -1\parskip} % Document Parameters % -------- ---------- % Page: \setlength{\hoffset}{-1in} \setlength{\voffset}{-1in} \setlength{\topmargin}{1in} \setlength{\headheight}{0pt} \setlength{\headsep}{0pt} \if \@onecolumn \setlength{\evensidemargin}{.75in} \setlength{\oddsidemargin}{.75in} \else \setlength{\evensidemargin}{.75in} \setlength{\oddsidemargin}{.75in} \fi % Text area: \newdimen{\standardtextwidth} \setlength{\standardtextwidth}{42pc} \if \@onecolumn \setlength{\textwidth}{40.5pc} \else \setlength{\textwidth}{\standardtextwidth} \fi \setlength{\topskip}{8pt} \setlength{\columnsep}{2pc} \setlength{\textheight}{54.5pc} % Running foot: \setlength{\footskip}{30pt} % Paragraphs: \if \@blockstyle \setlength{\parskip}{5pt plus .1pt minus .5pt} \setlength{\parindent}{0pt} \else \setlength{\parskip}{0pt} \setlength{\parindent}{12pt} \fi \setlength{\lineskip}{.5pt} \setlength{\lineskiplimit}{\lineskip} \frenchspacing \pretolerance = 400 \tolerance = \pretolerance \setlength{\emergencystretch}{5pt} \clubpenalty = 10000 \widowpenalty = 10000 \setlength{\hfuzz}{.5pt} % Standard vertical spaces: \newskip{\standardvspace} \setvspace{\standardvspace}{5pt plus 1pt minus .5pt} % Margin paragraphs: \setlength{\marginparwidth}{36pt} \setlength{\marginparsep}{2pt} \setlength{\marginparpush}{8pt} \setlength{\skip\footins}{8pt plus 3pt minus 1pt} \setlength{\footnotesep}{9pt} \renewcommand{\footnoterule}{% \hrule width .5\columnwidth height .33pt depth 0pt} \renewcommand{\@makefntext}[1]{% \noindent \@makefnmark \hspace{1pt}#1} % Floats: \setcounter{topnumber}{4} \setcounter{bottomnumber}{1} \setcounter{totalnumber}{4} \renewcommand{\fps@figure}{tp} \renewcommand{\fps@table}{tp} \renewcommand{\topfraction}{0.90} \renewcommand{\bottomfraction}{0.30} \renewcommand{\textfraction}{0.10} \renewcommand{\floatpagefraction}{0.75} \setcounter{dbltopnumber}{4} \renewcommand{\dbltopfraction}{\topfraction} \renewcommand{\dblfloatpagefraction}{\floatpagefraction} \setlength{\floatsep}{18pt plus 4pt minus 2pt} \setlength{\textfloatsep}{18pt plus 4pt minus 3pt} \setlength{\intextsep}{10pt plus 4pt minus 3pt} \setlength{\dblfloatsep}{18pt plus 4pt minus 2pt} \setlength{\dbltextfloatsep}{20pt plus 4pt minus 3pt} % Miscellaneous: \errorcontextlines = 5 % Fonts % ----- \if \@times \renewcommand{\rmdefault}{ptm}% \if \@mathtime \usepackage[mtbold,noTS1]{mathtime}% \else %%% \usepackage{mathptm}% \fi \else \relax \fi \if \@ninepoint \renewcommand{\normalsize}{% \@setfontsize{\normalsize}{9pt}{10pt}% \setlength{\abovedisplayskip}{5pt plus 1pt minus .5pt}% \setlength{\belowdisplayskip}{\abovedisplayskip}% \setlength{\abovedisplayshortskip}{3pt plus 1pt minus 2pt}% \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\tiny}{\@setfontsize{\tiny}{5pt}{6pt}} \renewcommand{\scriptsize}{\@setfontsize{\scriptsize}{7pt}{8pt}} \renewcommand{\small}{% \@setfontsize{\small}{8pt}{9pt}% \setlength{\abovedisplayskip}{4pt plus 1pt minus 1pt}% \setlength{\belowdisplayskip}{\abovedisplayskip}% \setlength{\abovedisplayshortskip}{2pt plus 1pt}% \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\footnotesize}{% \@setfontsize{\footnotesize}{8pt}{9pt}% \setlength{\abovedisplayskip}{4pt plus 1pt minus .5pt}% \setlength{\belowdisplayskip}{\abovedisplayskip}% \setlength{\abovedisplayshortskip}{2pt plus 1pt}% \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\large}{\@setfontsize{\large}{11pt}{13pt}} \renewcommand{\Large}{\@setfontsize{\Large}{14pt}{18pt}} \renewcommand{\LARGE}{\@setfontsize{\LARGE}{18pt}{20pt}} \renewcommand{\huge}{\@setfontsize{\huge}{20pt}{25pt}} \renewcommand{\Huge}{\@setfontsize{\Huge}{25pt}{30pt}} \fi % Abstract % -------- \renewenvironment{abstract}{% \section*{Abstract}% \normalsize}{% } % Bibliography % ------------ \renewenvironment{thebibliography}[1] {\section*{\refname \@mkboth{\MakeUppercase\refname}{\MakeUppercase\refname}}% \list{\@biblabel{\@arabic\c@enumiv}}% {\settowidth\labelwidth{\@biblabel{#1}}% \leftmargin\labelwidth \advance\leftmargin\labelsep \@openbib@code \usecounter{enumiv}% \let\p@enumiv\@empty \renewcommand\theenumiv{\@arabic\c@enumiv}}% \small \softraggedright%%%\sloppy \clubpenalty4000 \@clubpenalty \clubpenalty \widowpenalty4000% \sfcode`\.\@m} {\def\@noitemerr {\@latex@warning{Empty `thebibliography' environment}}% \endlist} % Categories % ---------- \@setflag \@firstcategory = \@true \newcommand{\category}[3]{% \if \@firstcategory \paragraph*{Categories and Subject Descriptors}% \@setflag \@firstcategory = \@false \else \unskip ;\hspace{.75em}% \fi \@ifnextchar [{\@category{#1}{#2}{#3}}{\@category{#1}{#2}{#3}[]}} \def \@category #1#2#3[#4]{% {\let \and = \relax #1 [\textit{#2}]% \if \@emptyargp{#4}% \if \@notp{\@emptyargp{#3}}: #3\fi \else :\space \if \@notp{\@emptyargp{#3}}#3---\fi \textrm{#4}% \fi}} % Copyright Notice % --------- ------ \def \ftype@copyrightbox {8} \def \@toappear {} \def \@permission {} \def \@copyrightspace {% \@float{copyrightbox}[b]% \vbox to 1in{% \vfill \if \@preprint [copyright notice will appear here]\par \else \@toappear \fi}% \end@float} \long\def \toappear #1{% \def \@toappear {\parbox[b]{20pc}{\scriptsize #1}}} \toappear{% \noindent \@permission \par \vspace{2pt} \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par Copyright \copyright\ \@copyrightyear\ ACM \@copyrightdata\dots \$5.00.} \newcommand{\permission}[1]{% \gdef \@permission {#1}} \permission{% Permission to make digital or hard copies of all or part of this work for personal or classroom use is granted without fee provided that copies are not made or distributed for profit or commercial advantage and that copies bear this notice and the full citation on the first page. To copy otherwise, to republish, to post on servers or to redistribute to lists, requires prior specific permission and/or a fee.} % Here we have some alternate permission statements and copyright lines: \newcommand{\ACMCanadapermission}{% \permission{% Copyright \@copyrightyear\ Association for Computing Machinery. ACM acknowledges that this contribution was authored or co-authored by an affiliate of the National Research Council of Canada (NRC). As such, the Crown in Right of Canada retains an equal interest in the copyright, however granting nonexclusive, royalty-free right to publish or reproduce this article, or to allow others to do so, provided that clear attribution is also given to the authors and the NRC.}} \newcommand{\ACMUSpermission}{% \permission{% Copyright \@copyrightyear\ Association for Computing Machinery. ACM acknowledges that this contribution was authored or co-authored by a contractor or affiliate of the U.S. Government. As such, the Government retains a nonexclusive, royalty-free right to publish or reproduce this article, or to allow others to do so, for Government purposes only.}} \newcommand{\authorpermission}{% \permission{% Copyright is held by the author/owner(s).} \toappear{% \noindent \@permission \par \vspace{2pt} \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par ACM \@copyrightdata.}} \newcommand{\Sunpermission}{% \permission{% Copyright is held by Sun Microsystems, Inc.}% \toappear{% \noindent \@permission \par \vspace{2pt} \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par ACM \@copyrightdata.}} \newcommand{\USpublicpermission}{% \permission{% This paper is authored by an employee(s) of the United States Government and is in the public domain.}% \toappear{% \noindent \@permission \par \vspace{2pt} \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par ACM \@copyrightdata.}} % Enunciations % ------------ \def \@begintheorem #1#2{% {name}{number} \trivlist \item[\hskip \labelsep \textsc{#1 #2.}]% \itshape\selectfont \ignorespaces} \def \@opargbegintheorem #1#2#3{% {name}{number}{title} \trivlist \item[% \hskip\labelsep \textsc{#1\ #2}% \if \@notp{\@emptyargp{#3}}\nut (#3).\fi]% \itshape\selectfont \ignorespaces} % Figures % ------- \@setflag \@caprule = \@true \long\def \@makecaption #1#2{% \addvspace{4pt} \if \@caprule \hrule width \hsize height .33pt \vspace{4pt} \fi \setbox \@tempboxa = \hbox{\@setfigurenumber{#1.}\nut #2}% \if \@dimgtrp{\wd\@tempboxa}{\hsize}% \noindent \@setfigurenumber{#1.}\nut #2\par \else \centerline{\box\@tempboxa}% \fi} \newcommand{\nocaptionrule}{% \@setflag \@caprule = \@false} \def \@setfigurenumber #1{% {\rmfamily \bfseries \selectfont #1}} % Hierarchy % --------- \setcounter{secnumdepth}{\@numheaddepth} \newskip{\@sectionaboveskip} \setvspace{\@sectionaboveskip}{10pt plus 3pt minus 2pt} \newskip{\@sectionbelowskip} \if \@blockstyle \setlength{\@sectionbelowskip}{0.1pt}% \else \setlength{\@sectionbelowskip}{4pt}% \fi \renewcommand{\section}{% \@startsection {section}% {1}% {0pt}% {-\@sectionaboveskip}% {\@sectionbelowskip}% {\large \bfseries \raggedright}} \newskip{\@subsectionaboveskip} \setvspace{\@subsectionaboveskip}{8pt plus 2pt minus 2pt} \newskip{\@subsectionbelowskip} \if \@blockstyle \setlength{\@subsectionbelowskip}{0.1pt}% \else \setlength{\@subsectionbelowskip}{4pt}% \fi \renewcommand{\subsection}{% \@startsection% {subsection}% {2}% {0pt}% {-\@subsectionaboveskip}% {\@subsectionbelowskip}% {\normalsize \bfseries \raggedright}} \renewcommand{\subsubsection}{% \@startsection% {subsubsection}% {3}% {0pt}% {-\@subsectionaboveskip} {\@subsectionbelowskip}% {\normalsize \bfseries \raggedright}} \newskip{\@paragraphaboveskip} \setvspace{\@paragraphaboveskip}{6pt plus 2pt minus 2pt} \renewcommand{\paragraph}{% \@startsection% {paragraph}% {4}% {0pt}% {\@paragraphaboveskip} {-1em}% {\normalsize \bfseries \if \@times \itshape \fi}} \renewcommand{\subparagraph}{% \@startsection% {subparagraph}% {4}% {0pt}% {\@paragraphaboveskip} {-1em}% {\normalsize \itshape}} % Standard headings: \newcommand{\acks}{\section*{Acknowledgments}} \newcommand{\keywords}{\paragraph*{Keywords}} \newcommand{\terms}{\paragraph*{General Terms}} % Identification % -------------- \def \@conferencename {} \def \@conferenceinfo {} \def \@copyrightyear {} \def \@copyrightdata {[to be supplied]} \newcommand{\conferenceinfo}[2]{% \gdef \@conferencename {#1}% \gdef \@conferenceinfo {#2}} \newcommand{\copyrightyear}[1]{% \gdef \@copyrightyear {#1}} \let \CopyrightYear = \copyrightyear \newcommand{\copyrightdata}[1]{% \gdef \@copyrightdata {#1}} \let \crdata = \copyrightdata % Lists % ----- \setlength{\leftmargini}{13pt} \setlength\leftmarginii{13pt} \setlength\leftmarginiii{13pt} \setlength\leftmarginiv{13pt} \setlength{\labelsep}{3.5pt} \setlength{\topsep}{\standardvspace} \if \@blockstyle \setlength{\itemsep}{1pt} \setlength{\parsep}{3pt} \else \setlength{\itemsep}{1pt} \setlength{\parsep}{3pt} \fi \renewcommand{\labelitemi}{{\small \centeroncapheight{\textbullet}}} \renewcommand{\labelitemii}{\centeroncapheight{\rule{2.5pt}{2.5pt}}} \renewcommand{\labelitemiii}{$-$} \renewcommand{\labelitemiv}{{\Large \textperiodcentered}} \renewcommand{\@listi}{% \leftmargin = \leftmargini \listparindent = 0pt} %%% \itemsep = 1pt %%% \parsep = 3pt} %%% \listparindent = \parindent} \let \@listI = \@listi \renewcommand{\@listii}{% \leftmargin = \leftmarginii \topsep = 1pt \labelwidth = \leftmarginii \advance \labelwidth by -\labelsep \listparindent = \parindent} \renewcommand{\@listiii}{% \leftmargin = \leftmarginiii \labelwidth = \leftmarginiii \advance \labelwidth by -\labelsep \listparindent = \parindent} \renewcommand{\@listiv}{% \leftmargin = \leftmarginiv \labelwidth = \leftmarginiv \advance \labelwidth by -\labelsep \listparindent = \parindent} % Mathematics % ----------- \def \theequation {\arabic{equation}} % Miscellaneous % ------------- \newcommand{\balancecolumns}{% \vfill\eject \global\@colht = \textheight \global\ht\@cclv = \textheight} \newcommand{\nut}{\hspace{.5em}} \newcommand{\softraggedright}{% \let \\ = \@centercr \leftskip = 0pt \rightskip = 0pt plus 10pt} % Program Code % ------- ---- \newcommand{\mono}[1]{% {\@tempdima = \fontdimen2\font \texttt{\spaceskip = 1.1\@tempdima #1}}} % Running Heads and Feet % ------- ----- --- ---- \def \@preprintfooter {} \newcommand{\preprintfooter}[1]{% \gdef \@preprintfooter {#1}} \if \@preprint \def \ps@plain {% \let \@mkboth = \@gobbletwo \let \@evenhead = \@empty \def \@evenfoot {\scriptsize \textit{\@preprintfooter}\hfil \thepage \hfil \textit{\@formatyear}}% \let \@oddhead = \@empty \let \@oddfoot = \@evenfoot} \else \let \ps@plain = \ps@empty \let \ps@headings = \ps@empty \let \ps@myheadings = \ps@empty \fi \def \@formatyear {% \number\year/\number\month/\number\day} % Special Characters % ------- ---------- \DeclareRobustCommand{\euro}{% \protect{\rlap{=}}{\sf \kern .1em C}} % Title Page % ----- ---- \@setflag \@addauthorsdone = \@false \def \@titletext {\@latex@error{No title was provided}{}} \def \@subtitletext {} \newcount{\@authorcount} \newcount{\@titlenotecount} \newtoks{\@titlenotetext} \def \@titlebanner {} \renewcommand{\title}[1]{% \gdef \@titletext {#1}} \newcommand{\subtitle}[1]{% \gdef \@subtitletext {#1}} \newcommand{\authorinfo}[3]{% {names}{affiliation}{email/URL} \global\@increment \@authorcount \@withname\gdef {\@authorname\romannumeral\@authorcount}{#1}% \@withname\gdef {\@authoraffil\romannumeral\@authorcount}{#2}% \@withname\gdef {\@authoremail\romannumeral\@authorcount}{#3}} \renewcommand{\author}[1]{% \@latex@error{The \string\author\space command is obsolete; use \string\authorinfo}{}} \newcommand{\titlebanner}[1]{% \gdef \@titlebanner {#1}} \renewcommand{\maketitle}{% \pagestyle{plain}% \if \@onecolumn {\hsize = \standardtextwidth \@maketitle}% \else \twocolumn[\@maketitle]% \fi \@placetitlenotes \if \@copyrightwanted \@copyrightspace \fi} \def \@maketitle {% \begin{center} \@settitlebanner \let \thanks = \titlenote \noindent \LARGE \bfseries \@titletext \par \vskip 6pt \noindent \Large \@subtitletext \par \vskip 12pt \ifcase \@authorcount \@latex@error{No authors were specified for this paper}{}\or \@titleauthors{i}{}{}\or \@titleauthors{i}{ii}{}\or \@titleauthors{i}{ii}{iii}\or \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{}{}\or \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{}\or \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}\or \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% \@titleauthors{vii}{}{}\or \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% \@titleauthors{vii}{viii}{}\or \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% \@titleauthors{vii}{viii}{ix}\or \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{}{}% \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{}% \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{xii}% \else \@latex@error{Cannot handle more than 12 authors}{}% \fi \vspace{1.75pc} \end{center}} \def \@settitlebanner {% \if \@notp{\@emptydefp{\@titlebanner}}% \vbox to 0pt{% \vskip -32pt \noindent \textbf{\@titlebanner}\par \vss}% \nointerlineskip \fi} \def \@titleauthors #1#2#3{% \if \@andp{\@emptyargp{#2}}{\@emptyargp{#3}}% \noindent \@setauthor{40pc}{#1}{\@false}\par \else\if \@emptyargp{#3}% \noindent \@setauthor{17pc}{#1}{\@false}\hspace{3pc}% \@setauthor{17pc}{#2}{\@false}\par \else \noindent \@setauthor{12.5pc}{#1}{\@false}\hspace{2pc}% \@setauthor{12.5pc}{#2}{\@false}\hspace{2pc}% \@setauthor{12.5pc}{#3}{\@true}\par \relax \fi\fi \vspace{20pt}} \def \@setauthor #1#2#3{% {width}{text}{unused} \vtop{% \def \and {% \hspace{16pt}} \hsize = #1 \normalfont \centering \large \@name{\@authorname#2}\par \vspace{5pt} \normalsize \@name{\@authoraffil#2}\par \vspace{2pt} \textsf{\@name{\@authoremail#2}}\par}} \def \@maybetitlenote #1{% \if \@andp{#1}{\@gtrp{\@authorcount}{3}}% \titlenote{See page~\pageref{@addauthors} for additional authors.}% \fi} \newtoks{\@fnmark} \newcommand{\titlenote}[1]{% \global\@increment \@titlenotecount \ifcase \@titlenotecount \relax \or \@fnmark = {\ast}\or \@fnmark = {\dagger}\or \@fnmark = {\ddagger}\or \@fnmark = {\S}\or \@fnmark = {\P}\or \@fnmark = {\ast\ast}% \fi \,$^{\the\@fnmark}$% \edef \reserved@a {\noexpand\@appendtotext{% \noexpand\@titlefootnote{\the\@fnmark}}}% \reserved@a{#1}} \def \@appendtotext #1#2{% \global\@titlenotetext = \expandafter{\the\@titlenotetext #1{#2}}} \newcount{\@authori} \iffalse \def \additionalauthors {% \if \@gtrp{\@authorcount}{3}% \section{Additional Authors}% \label{@addauthors}% \noindent \@authori = 4 {\let \\ = ,% \loop \textbf{\@name{\@authorname\romannumeral\@authori}}, \@name{\@authoraffil\romannumeral\@authori}, email: \@name{\@authoremail\romannumeral\@authori}.% \@increment \@authori \if \@notp{\@gtrp{\@authori}{\@authorcount}} \repeat}% \par \fi \global\@setflag \@addauthorsdone = \@true} \fi \let \addauthorsection = \additionalauthors \def \@placetitlenotes { \the\@titlenotetext} % Utilities % --------- \newcommand{\centeroncapheight}[1]{% {\setbox\@tempboxa = \hbox{#1}% \@measurecapheight{\@tempdima}% % Calculate ht(CAP) - ht(text) \advance \@tempdima by -\ht\@tempboxa % ------------------ \divide \@tempdima by 2 % 2 \raise \@tempdima \box\@tempboxa}} \newbox{\@measbox} \def \@measurecapheight #1{% {\dimen} \setbox\@measbox = \hbox{ABCDEFGHIJKLMNOPQRSTUVWXYZ}% #1 = \ht\@measbox} \long\def \@titlefootnote #1#2{% \insert\footins{% \reset@font\footnotesize \interlinepenalty\interfootnotelinepenalty \splittopskip\footnotesep \splitmaxdepth \dp\strutbox \floatingpenalty \@MM \hsize\columnwidth \@parboxrestore %%% \protected@edef\@currentlabel{% %%% \csname p@footnote\endcsname\@thefnmark}% \color@begingroup \def \@makefnmark {$^{#1}$}% \@makefntext{% \rule\z@\footnotesep\ignorespaces#2\@finalstrut\strutbox}% \color@endgroup}} % LaTeX Modifications % ----- ------------- \def \@seccntformat #1{% \@name{\the#1}% \@expandaftertwice\@seccntformata \csname the#1\endcsname.\@mark \quad} \def \@seccntformata #1.#2\@mark{% \if \@emptyargp{#2}.\fi} % Revision History % -------- ------- % Date Person Ver. Change % ---- ------ ---- ------ % 2004.09.12 PCA 0.1--5 Preliminary development. % 2004.11.18 PCA 0.5 Start beta testing. % 2004.11.19 PCA 0.6 Obsolete \author and replace with % \authorinfo. % Add 'nocopyrightspace' option. % Compress article opener spacing. % Add 'mathtime' option. % Increase text height by 6 points. % 2004.11.28 PCA 0.7 Add 'cm/computermodern' options. % Change default to Times text. % 2004.12.14 PCA 0.8 Remove use of mathptm.sty; it cannot % coexist with latexym or amssymb. % 2005.01.20 PCA 0.9 Rename class file to sigplanconf.cls. % 2005.03.05 PCA 0.91 Change default copyright data. % 2005.03.06 PCA 0.92 Add at-signs to some macro names. % 2005.03.07 PCA 0.93 The 'onecolumn' option defaults to '11pt', % and it uses the full type width. % 2005.03.15 PCA 0.94 Add at-signs to more macro names. % Allow margin paragraphs during review. % 2005.03.22 PCA 0.95 Implement \euro. % Remove proof and newdef environments. % 2005.05.06 PCA 1.0 Eliminate 'onecolumn' option. % Change footer to small italic and eliminate % left portion of no \preprintfooter. % Eliminate copyright notice if preprint. % Clean up and shrink copyright box. % 2005.05.30 PCA 1.1 Add alternate permission statements. % 2005.06.29 PCA 1.1 Publish final first edition of guide. % 2005.07.11 PCA 1.2 Add \subparagraph. % Use block paragraphs in lists, and adjust % spacing between items and paragraphs. ================================================ FILE: papers/haskell_symposium_2009/sumEuler/Makefile ================================================ GHC = /c/ghc/ghc/inplace/bin/ghc-stage2 GHC_OPTS = -threaded -eventlog # HEAP = -H100M HEAP = all: $(GHC) $(GHC_OPTS) --make SuMEuler0.hs $(GHC) $(GHC_OPTS) --make SumEuler1.hs $(GHC) $(GHC_OPTS) --make SumEuler2.hs $(GHC) $(GHC_OPTS) --make SumEuler3.hs run: run0 run1 run2 run3 run0: ./SumEuler0 run1: ./SumEuler1 +RTS -N1 -qg0 -qb $(HEAP) -l -sSumEuler1.N1.log mv SumEuler1.exe.eventlog SumEuler1.N1.eventlog ./SumEuler1 +RTS -N2 -qg0 -qb $(HEAP) -l -sSumEuler1.N2.log mv SumEuler1.exe.eventlog SumEuler1.N2.eventlog run2: ./SumEuler2 +RTS -N1 -qg0 -qb $(HEAP) -l -sSumEuler2.N1.log mv SumEuler2.exe.eventlog SumEuler2.N1.eventlog ./SumEuler2 +RTS -N2 -qg0 -qb $(HEAP) -l -sSumEuler2.N2.log mv SumEuler2.exe.eventlog SumEuler2.N2.eventlog run3: ./SumEuler3 +RTS -N1 -qg0 -qb $(HEAP) -l -sSumEuler3.N1.log mv SumEuler3.exe.eventlog SumEuler3.N1.eventlog ./SumEuler3 +RTS -N2 -qg0 -qb $(HEAP) -l -sSumEuler3.N2.log mv SumEuler3.exe.eventlog SumEuler3.N2.eventlog clean: rm -rf *.hi *.o cleanall: clean rm -rf *.eventlog *.log ================================================ FILE: papers/haskell_symposium_2009/sumEuler/SumEuler0.hs ================================================ ------------------------------------------------------------------------------- -- This program runs fib and sumEuler separately and sequentially -- to allow us to compute how long each individual function takes -- to execute. module Main where import System.Time import Control.Parallel import System.Mem ------------------------------------------------------------------------------- fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) ------------------------------------------------------------------------------- mkList :: Int -> [Int] mkList n = [1..n-1] ------------------------------------------------------------------------------- relprime :: Int -> Int -> Bool relprime x y = gcd x y == 1 ------------------------------------------------------------------------------- euler :: Int -> Int euler n = length (filter (relprime n) (mkList n)) ------------------------------------------------------------------------------- sumEuler :: Int -> Int sumEuler = sum . (map euler) . mkList ------------------------------------------------------------------------------- sumFibEuler :: Int -> Int -> Int sumFibEuler a b = fib a + sumEuler b ------------------------------------------------------------------------------- result1 :: Int result1 = fib 38 result2 :: Int result2 = sumEuler 5300 ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "SumEuler0 (sequential)" performGC t0 <- getClockTime pseq result1 (return ()) t1 <- getClockTime putStrLn ("fib time: " ++ show (secDiff t0 t1)) t2 <- getClockTime pseq result2 (return ()) t3 <- getClockTime putStrLn ("sumEuler time: " ++ show (secDiff t2 t3)) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/sumEuler/SumEuler1.hs ================================================ ------------------------------------------------------------------------------- -- This demonstrates that f `par` (f + e) does not result in parallelism. module Main where import System.Time import Control.Parallel import System.Mem ------------------------------------------------------------------------------- fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) ------------------------------------------------------------------------------- mkList :: Int -> [Int] mkList n = [1..n-1] ------------------------------------------------------------------------------- relprime :: Int -> Int -> Bool relprime x y = gcd x y == 1 ------------------------------------------------------------------------------- euler :: Int -> Int euler n = length (filter (relprime n) (mkList n)) ------------------------------------------------------------------------------- sumEuler :: Int -> Int sumEuler = sum . (map euler) . mkList ------------------------------------------------------------------------------- sumFibEuler :: Int -> Int -> Int sumFibEuler a b = fib a + sumEuler b ------------------------------------------------------------------------------- parSumFibEuler :: Int -> Int -> Int parSumFibEuler a b = f `par` (f + e) where f = fib a e = sumEuler b ------------------------------------------------------------------------------- result :: Int result = parSumFibEuler 38 5300 ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "SumEuler1" performGC t0 <- getClockTime pseq result (return ()) t1 <- getClockTime putStrLn ("sumeuler1 = " ++ show result) putStrLn ("Time: " ++ show (secDiff t0 t1)) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/sumEuler/SumEuler2.hs ================================================ ------------------------------------------------------------------------------- module Main where import System.Time import Control.Parallel import System.Mem ------------------------------------------------------------------------------- fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) ------------------------------------------------------------------------------- mkList :: Int -> [Int] mkList n = [1..n-1] ------------------------------------------------------------------------------- relprime :: Int -> Int -> Bool relprime x y = gcd x y == 1 ------------------------------------------------------------------------------- euler :: Int -> Int euler n = length (filter (relprime n) (mkList n)) ------------------------------------------------------------------------------- sumEuler :: Int -> Int sumEuler = sum . (map euler) . mkList ------------------------------------------------------------------------------- sumFibEuler :: Int -> Int -> Int sumFibEuler a b = fib a + sumEuler b ------------------------------------------------------------------------------- parSumFibEuler :: Int -> Int -> Int parSumFibEuler a b = f `par` (e + f) where f = fib a e = sumEuler b ------------------------------------------------------------------------------- result :: Int result = parSumFibEuler 38 5300 ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "SumEuler2" performGC t0 <- getClockTime pseq result (return ()) t1 <- getClockTime putStrLn ("sumeuler2 = " ++ show result) putStrLn ("Time: " ++ show (secDiff t0 t1)) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/sumEuler/SumEuler3.hs ================================================ ------------------------------------------------------------------------------- module Main where import System.Time import Control.Parallel import System.Mem ------------------------------------------------------------------------------- fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n-1) + fib (n-2) ------------------------------------------------------------------------------- mkList :: Int -> [Int] mkList n = [1..n-1] ------------------------------------------------------------------------------- relprime :: Int -> Int -> Bool relprime x y = gcd x y == 1 ------------------------------------------------------------------------------- euler :: Int -> Int euler n = length (filter (relprime n) (mkList n)) ------------------------------------------------------------------------------- sumEuler :: Int -> Int sumEuler = sum . (map euler) . mkList ------------------------------------------------------------------------------- sumFibEuler :: Int -> Int -> Int sumFibEuler a b = fib a + sumEuler b ------------------------------------------------------------------------------- parSumFibEuler :: Int -> Int -> Int parSumFibEuler a b = f `par` (e `pseq` (f + e)) where f = fib a e = sumEuler b ------------------------------------------------------------------------------- result :: Int result = parSumFibEuler 38 5300 ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "SumEuler3" performGC t0 <- getClockTime pseq result (return ()) t1 <- getClockTime putStrLn ("sumeuler2 = " ++ show result) putStrLn ("Time: " ++ show (secDiff t0 t1)) ------------------------------------------------------------------------------- ================================================ FILE: papers/haskell_symposium_2009/threadring.tex ================================================ \subsection{Thread Ring} The thread ring benchmark originates in the Computer Language Benchmarks Game\footnote{\url{http://shootout.alioth.debian.org/}} (formerly known as the Great Computer Language Shootout). It is a simple concurrency benchmark, in which a large number of threads are created in a ring topology, and then messages are passed around the ring. We include it here as an example of profiling a Concurrent Haskell program using ThreadScope, in contrast to the other case studies which have investigated programs that use semi-explicit parallelism. The code for our version of the benchmark is given in Figure~\ref{f:threadring-code}. This version uses a linear string of threads rather than a ring, where a number of messages are pumped in to the first thread in the string, and then collected at the other end. \begin{figure} \begin{lstlisting} import Control.Concurrent import Control.Monad import System import GHC.Conc (forkOnIO) thread :: MVar Int -> MVar Int -> IO () thread inp out = do x <- takeMVar inp putMVar out $! x+1 thread inp out spawn cur n = do next <- newEmptyMVar forkIO $ thread cur next return next main = do n <- getArgs >>= readIO.head s <- newEmptyMVar e <- foldM spawn s [1..2000] f <- newEmptyMVar forkIO $ replicateM n (takeMVar e) >>= putMVar f . sum replicateM n (putMVar s 0) takeMVar f \end{lstlisting} \caption{ThreadRing code} \label{f:threadring-code} \end{figure} Our aim is to try to make this program speed up in parallel. We expect there to be parallelism available: multiple messages are being pumped through the thread string, so we ought to be able to pump messages through distinct parts of the string in parallel. First, the sequential performance. This is for 500 messages and 2000 threads: \begin{verbatim} INIT time 0.00s ( 0.00s elapsed) MUT time 0.18s ( 0.19s elapsed) GC time 0.01s ( 0.01s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 0.19s ( 0.21s elapsed) \end{verbatim} Next, running the program on two cores: \begin{verbatim} INIT time 0.00s ( 0.00s elapsed) MUT time 0.65s ( 0.36s elapsed) GC time 0.02s ( 0.01s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 0.67s ( 0.38s elapsed) \end{verbatim} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{threadring1.png} \end{center} \caption{ThreadRing profile (no explicit placement; zoomed in)} \label{f:threadring1} \end{figure*} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{threadring2.png} \end{center} \caption{ThreadRing profile (with explicit placement)} \label{f:threadring2} \end{figure*} \begin{figure*} \begin{center} \includegraphics[scale=0.3]{threadring3.png} \end{center} \caption{ThreadRing profile (explicit placement and more messages)} \label{f:threadring3} \end{figure*} Things are significantly slower when we add a core. Let's examine the ThreadScope profile to see why - at first glance, the program seems to be using both cores, but as we zoom in we can see that there are lots of gaps (Figure~\ref{f:threadring1}). In this program we want to avoid communication between the two separate cores, because that will be expensive. We want as much communication as possible to happen between threads on the same core, where it is cheap. In order to do this, we have to give the scheduler some help. We know the structure of the communication in this program: messages are passed along the string in sequence, so we can place threads optimally to take advantage of that. GHC provides a way to place a thread onto a particular core (or HEC), using the \codef{forkOnIO} operation. The placement scheme we use is to divide the string into linear segments, one segment per core (in our case two). This strategy gets us back to the same performance as the sequential version: \begin{verbatim} INIT time 0.00s ( 0.00s elapsed) MUT time 0.23s ( 0.19s elapsed) GC time 0.02s ( 0.02s elapsed) EXIT time 0.00s ( 0.00s elapsed) Total time 0.26s ( 0.21s elapsed) \end{verbatim} Why don't we actually see any speedup? Figure~\ref{f:threadring2} shows the ThreadScope profile. The program has now been almost linearized; there is a small amount of overlap, but most of the execution is sequential, first on one core and then the other. Investigating the profile in more detail shows that this is a scheduling phenomenon. The runtime has moved all the messages through the first string before it propagates any into the second string, and this can happen because the total number of messages we are using for the benchmark is less than the number of threads. If we increase the number of messages, then we do actually see more parallelism. Figure~\ref{f:threadring3} shows the execution profile for 2000 messages and 2000 threads, and we can see there is significantly more overlap. ================================================ FILE: scripts/install-on-osx.sh ================================================ #!/bin/sh HC=$1 set -ex CABALPKG="cabal-c92b4ea7ce036fae6ebf3c2965d6ecc0ef252775-20170725-123913.xz" CABALCHECKSUM="2aa74ff75ee97745eb562360ed4e8f95f3eba4ce40c8621b6b23e29633f6ed3a" GHCPKG="ghc-8.2.1-x86_64-apple-darwin.tar.xz" GHCURL="https://downloads.haskell.org/~ghc/8.2.1/$GHCPKG" GHCCHECKSUM="900c802025fb630060dbd30f9738e5d107a4ca5a50d5c1262cd3e69fe4467188" if [ $(uname) != "Darwin" ]; then exit 0 fi if [ "x$HC" != "xghc-8.2.1" ]; then echo "Only GHC-8.2.1 is supported at the moment" exit 1 fi ROOTDIR=$(pwd) BUILDDIR=$(mktemp -d /tmp/build-cabal-nightly.XXXXXX) travis_retry () { $* || (sleep 1 && $*) || (sleep 2 && $*) } if [ ! -f $HOME/.ghc-install/bin/ghc-8.2.1 ]; then cd $BUILDDIR travis_retry curl -OL $GHCURL # Two spaces seems to be important echo "$GHCCHECKSUM ./$GHCPKG" | shasum -c -a 256 tar -xJf $GHCPKG cd ghc-* ./configure --prefix=$HOME/.ghc-install make install fi if [ ! -f $HOME/.ghc-install/bin/cabal ]; then cd $BUILDDIR travis_retry curl -OL https://haskell.futurice.com/files/$CABALPKG echo "$CABALCHECKSUM ./$CABALPKG" | shasum -c -a 256 # gunzip knows how to handle .xz gunzip -c $CABALPKG > $HOME/.ghc-install/bin/cabal mkdir -p $HOME/.ghc-install/bin chmod a+x $HOME/.ghc-install/bin/cabal fi ================================================ FILE: stack.osx.yaml ================================================ resolver: lts-16.28 packages: - . extra-deps: - cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa8779b23b2b67a9,4075 - gio-0.13.8.1@sha256:7404841eefdfffb50c2b5f63879ffe4bf40fb5ddf90a7f633494eca0e23150a5,3136 - glib-0.13.8.1@sha256:42670daf0c85309281e08ba8559df75daa2e3be642e79fdfa781bef5e59658b0,3156 - gtk-0.15.5@sha256:62b0ed14e07e57f13a575d36f37c6f250ee9ed45d68d492685e8bd26c35c2203,16598 - gtk2hs-buildtools-0.13.8.0@sha256:132f38155fc677430a47ea750918973161c876fb6f281d342ac2f07eb99229ce,5238 - pango-0.13.8.1@sha256:877b121c0bf87c96d3619effae6751ecfd74b7f7f3227cf3fde012597aed5ed9,3917 flags: gtk: have-quartz-gtk: true ================================================ FILE: stack.yaml ================================================ resolver: lts-16.28 packages: - . extra-deps: - cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa8779b23b2b67a9,4075 - gio-0.13.8.1@sha256:7404841eefdfffb50c2b5f63879ffe4bf40fb5ddf90a7f633494eca0e23150a5,3136 - glib-0.13.8.1@sha256:42670daf0c85309281e08ba8559df75daa2e3be642e79fdfa781bef5e59658b0,3156 - gtk-0.15.5@sha256:62b0ed14e07e57f13a575d36f37c6f250ee9ed45d68d492685e8bd26c35c2203,16598 - gtk2hs-buildtools-0.13.8.0@sha256:132f38155fc677430a47ea750918973161c876fb6f281d342ac2f07eb99229ce,5238 - pango-0.13.8.1@sha256:877b121c0bf87c96d3619effae6751ecfd74b7f7f3227cf3fde012597aed5ed9,3917 ================================================ FILE: tests/Hello.hs ================================================ module Main where main = putStrLn "Hello." ================================================ FILE: tests/Makefile ================================================ GHC = c:/ghc/ghc/inplace/bin/ghc-stage2 GHC_OPTS = -O -threaded -eventlog all: $(GHC) $(GHC_OPTS) --make Null.hs $(GHC) $(GHC_OPTS) --make Hello.hs $(GHC) $(GHC_OPTS) --make SumEulerPar1.hs $(GHC) $(GHC_OPTS) --make ParFib.hs run: cleanlogs rnull rhello rsep1 rparfib rnull: ./Null +RTS -ls rhello: ./Hello +RTS -ls rsep1: ./SumEulerPar1 +RTS -ls -N8 rparfib: ./ParFib +RTS -ls -N2 cleanlogs: rm -rf *.eventlog clean: rm -rf *.o *.hi *.exe *.eventlog ================================================ FILE: tests/Null.hs ================================================ module Main where main = return () ================================================ FILE: tests/ParFib.hs ================================================ ------------------------------------------------------------------------------- -- A parallel implementation of fib in Haskell using semi-explicit -- parallelism expressed with `par` and `pseq` module Main where import System.Time import Control.Parallel import System.Mem ------------------------------------------------------------------------------- -- A purely sequential implementation of fib. seqFib :: Int -> Integer seqFib 0 = 1 seqFib 1 = 1 seqFib n = seqFib (n-1) + seqFib (n-2) ------------------------------------------------------------------------------- -- A threshold value below which the parallel implementation of fib -- reverts to sequential implementation. threshHold :: Int threshHold = 25 ------------------------------------------------------------------------------- -- A parallel implementation of fib. parFib :: Int -> Integer parFib n = if n < threshHold then seqFib n else r `par` (l `pseq` l + r) where l = parFib (n-1) r = parFib (n-2) ------------------------------------------------------------------------------- result :: Integer result = parFib 46 ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn "ParFib" t0 <- getClockTime pseq result (return ()) t1 <- getClockTime putStrLn ("fib = " ++ show result) putStrLn ("Time: " ++ show (secDiff t0 t1)) ------------------------------------------------------------------------------- ================================================ FILE: tests/SumEulerPar1.hs ================================================ ------------------------------------------------------------------------------- --- $Id: SumEulerPar1.hs#1 2008/05/06 16:25:08 REDMOND\\satnams $ ------------------------------------------------------------------------------- module Main where import System.Time import System.Random import Control.Parallel import System.Mem import Control.Parallel.Strategies ------------------------------------------------------------------------------- mkList :: Int -> [Int] mkList n = [1..n-1] ------------------------------------------------------------------------------- relprime :: Int -> Int -> Bool relprime x y = gcd x y == 1 ------------------------------------------------------------------------------- euler :: Int -> Int euler n = length (filter (relprime n) (mkList n)) ------------------------------------------------------------------------------- sumEulerPar1 n = sum ((map euler (mkList n)) `using` parList rnf) ------------------------------------------------------------------------------- input :: Int input = 1000 ------------------------------------------------------------------------------- result :: Int result = sumEulerPar1 input ------------------------------------------------------------------------------- secDiff :: ClockTime -> ClockTime -> Float secDiff (TOD secs1 psecs1) (TOD secs2 psecs2) = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1) ------------------------------------------------------------------------------- main :: IO () main = do putStrLn ("SumEulerPar1 parList input = " ++ show input) performGC t0 <- getClockTime pseq result (return ()) t1 <- getClockTime putStrLn ("sumeuler = " ++ show result) putStrLn ("Time: " ++ show (secDiff t0 t1)) ------------------------------------------------------------------------------- ================================================ FILE: threadscope.cabal ================================================ Cabal-version: 1.24 Name: threadscope Version: 0.2.15.0 Category: Development, Profiling, Trace Synopsis: A graphical tool for profiling parallel Haskell programs. Description: ThreadScope is a graphical viewer for thread profile information generated by the Glasgow Haskell compiler (GHC). . The Threadscope program allows us to debug the parallel performance of Haskell programs. Using Threadscope we can check to see that work is well balanced across the available processors and spot performance issues relating to garbage collection or poor load balancing. License: BSD3 License-file: LICENSE Copyright: 2009-2010 Satnam Singh, 2009-2011 Simon Marlow, 2009 Donnie Jones, 2011-2012 Duncan Coutts, 2011-2014 Mikolaj Konarski, 2011 Nicolas Wu, 2011 Eric Kow Author: Satnam Singh , Simon Marlow , Donnie Jones , Duncan Coutts , Mikolaj Konarski , Nicolas Wu , Eric Kow Maintainer: Simon Marlow Homepage: http://www.haskell.org/haskellwiki/ThreadScope Bug-reports: https://github.com/haskell/ThreadScope/issues Build-Type: Simple Data-files: threadscope.ui, threadscope.png Extra-source-files: include/windows_cconv.h threadscope.ui README.md CHANGELOG.md Tested-with: GHC == 8.8.4 GHC == 8.10.7 GHC == 9.0.2 GHC == 9.2.8 GHC == 9.4.8 GHC == 9.6.6 GHC == 9.8.4 GHC == 9.10.1 GHC == 9.12.1 source-repository head type: git location: git@github.com:haskell/ThreadScope.git Executable threadscope Main-is: Main.hs Build-Depends: base >= 4.10 && < 5, gtk3 >= 0.12 && < 0.16, cairo < 0.14, glib < 0.14, pango < 0.14, binary < 0.11, array < 0.6, mtl < 2.4, filepath < 1.6, ghc-events >= 0.13 && < 0.21, containers >= 0.2 && < 0.8, deepseq >= 1.1 && <1.7.0, text < 2.2, time >= 1.1 && < 1.15, bytestring < 0.13, file-embed < 0.1, template-haskell < 2.24, temporary >= 1.1 && < 1.4, transformers <0.6.3 include-dirs: include default-extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards other-extensions: TemplateHaskell Other-Modules: Events.HECs, Events.EventDuration, Events.EventTree, Events.ReadEvents, Events.SparkStats, Events.SparkTree, Events.TestEvents, GUI.App, GUI.Main, GUI.MainWindow, GUI.EventsView, GUI.DataFiles, GUI.Dialogs, GUI.SaveAs, GUI.Timeline, GUI.Histogram, GUI.TraceView, GUI.BookmarkView, GUI.KeyView, GUI.StartupInfoView, GUI.SummaryView, GUI.Types, GUI.ConcurrencyControl, GUI.ProgressView, GUI.ViewerColours, GUI.Timeline.Activity, GUI.Timeline.CairoDrawing, GUI.Timeline.HEC, GUI.Timeline.Motion, GUI.Timeline.Render, GUI.Timeline.Sparks, GUI.Timeline.Ticks, GUI.Timeline.Types, GUI.Timeline.Render.Constants, GUI.GtkExtras Graphics.UI.Gtk.ModelView.TreeView.Compat Paths_threadscope ghc-options: -Wall -fwarn-tabs -rtsopts -fno-warn-type-defaults -fno-warn-name-shadowing -fno-warn-unused-do-bind -- Note: we do not want to use -threaded with gtk2hs. if impl(ghc < 6.12) -- GHC before 6.12 gave spurious warnings for RecordWildCards ghc-options: -fno-warn-unused-matches if !os(windows) build-depends: unix >= 2.3 && < 2.9 default-language: Haskell2010 ================================================ FILE: threadscope.ui ================================================ True gtk-refresh True gtk-save-as True gtk-goto-first True gtk-home True gtk-goto-last True gtk-zoom-in True gtk-zoom-out True gtk-zoom-fit 600 400 True ThreadScope 1200 600 True True True _File True True gtk-open True True True Export image... True image2 False True gtk-quit True True True True _View True True True Sidebar True True True Information pane True True True Black & white True True Event labels True True _Reload True True image1 False True _Move True True Jump to start True True image4 False Centre on cursor True True image5 False Jump to end True True image6 False True Zoom in True True image7 False Zoom out True True image8 False Fit to window True True image9 False True Help True True True Online tutorial True True Website True True gtk-about True True True False True 0 True both-horiz False True Open an eventlog True gtk-open False True True False True Jump to the start True gtk-goto-first False True True Centre view on the cursor gtk-home False True True Jump to the end True gtk-goto-last False True True False True Zoom in gtk-zoom-in False True True Zoom out gtk-zoom-out False True True Fit view to the window gtk-zoom-fit False True False False 1 True True True True sidepane True True automatic automatic True False False True True Key 2 False True True automatic automatic True True False 1 True True Traces 1 False True True both-horiz False True True gtk-jump-to False True True Bookmark True gtk-add False True True gtk-remove False True False False 0 True True automatic automatic True True False True True 1 2 True True Bookmarks 2 False False True True True True True 0 4 4 <b>Timeline</b> True False False 0 True 2 2 3 3 True 1 2 GTK_SHRINK | GTK_FILL True False 0 1 2 GTK_SHRINK True True True GDK_KEY_PRESS_MASK | GDK_KEY_RELEASE_MASK | GDK_STRUCTURE_MASK queue True 2 2 110 True 1 2 GTK_SHRINK 38 True 1 2 GTK_SHRINK True True 1 2 1 2 True True 1 True True True True infopane True True automatic automatic True queue True 8 4 2 8 4 True 0 0 Total time: GTK_FILL GTK_FILL True 0 0 Mutator time: 1 2 GTK_FILL GTK_FILL True 0 0 GC time: 2 3 GTK_FILL GTK_FILL True True 0 0 True 1 2 GTK_FILL True True 0 0 True 1 2 2 3 GTK_FILL True True 0 0 True 1 2 1 2 GTK_FILL True 0 0 Productivity: 3 4 GTK_FILL GTK_FILL True True 0 0 True 1 2 3 4 GTK_FILL True True The time spent executing code vs doing GC (for the full run or the selected time period) Time False True True automatic automatic True queue True 8 5 5 8 4 True 0 0 Maximum heap size: GTK_FILL GTK_FILL True 0 0 Maximum heap residency: 1 2 GTK_FILL GTK_FILL True 0 0 Total allocated: 2 3 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 2 3 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 1 2 GTK_FILL GTK_FILL True 0 0 Allocation rate: 3 4 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 3 4 GTK_FILL GTK_FILL True 0 0 Maximum slop: 4 5 GTK_FILL GTK_FILL True True 1 0 True 6 1 2 4 5 GTK_FILL GTK_FILL True 0 0 3 2 3 GTK_FILL GTK_FILL True 0 0 3 2 3 1 2 GTK_FILL GTK_FILL True 0 0 3 2 3 2 3 GTK_FILL GTK_FILL True 0 0 5 2 3 3 4 GTK_FILL GTK_FILL True 0 0 3 2 3 4 5 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 1 2 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 2 3 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 3 4 GTK_FILL GTK_FILL True True 1 0 True 18 3 4 4 5 GTK_FILL GTK_FILL True 0 0 4 5 GTK_FILL True 0 0 4 5 1 2 GTK_FILL GTK_FILL True 0 0 4 5 4 5 GTK_FILL GTK_FILL True 0 0 4 5 3 4 GTK_FILL GTK_FILL True 0 0 4 5 2 3 GTK_FILL GTK_FILL 1 True True Summary statistics about the heap (for the full run or the selected time period) Heap 1 False True True automatic automatic True queue True 8 3 2 8 4 True 0 0 Copied during GC: GTK_FILL GTK_FILL True 0 0 Parallel GC work balance: 1 2 GTK_FILL GTK_FILL True True 0 0 True 1 2 1 2 GTK_FILL True True automatic automatic True True False 2 2 3 True 4 True True 0 0 True False True 0 True True 0 0 False True 1 True True 1 0 True 18 False True 2 True True 0 0 False True 3 1 2 GTK_FILL 2 True True Garbage collector statistics (for the full run or the selected time period) GC 2 False True True automatic automatic True True 3 True True Counts of how many sparks were created, converted etc (for the full run or the selected time period) Spark stats 3 False True 2 110 True 1 2 GTK_SHRINK True True 1 2 1 2 4 True True A histogram of how long each spark took to evaluate, either for the whole program or the selected time period. Spark sizes 4 False True True automatic automatic True True 8 5 2 8 4 True 0 0 Executable: GTK_FILL GTK_FILL True 0 0 Arguments: 1 2 GTK_FILL GTK_FILL True 0 0 Start time: 2 3 GTK_FILL GTK_FILL True 0 0 RTS Id: 3 4 GTK_FILL GTK_FILL True 0 0 Environment: 4 5 GTK_FILL GTK_FILL True True The name and path of the program's executable file 0 0 True 1 2 GTK_FILL True True The time at which the program was started 0 0 True 1 2 2 3 GTK_FILL True True automatic automatic True True The arguments supplied when the program was run False 1 2 1 2 True True automatic automatic True True The environment variables available when the program was started False 1 2 4 5 True True The name and version of the compiler/runtime used by the program 0 0 True 1 2 3 4 GTK_FILL 5 True True Information about the program run including program name and command line arguments. Process info 5 False True 120 True 3 True queue True True True True 0 True adjustment1 False True 1 True True 2 6 True True The raw events from the eventlog. The selection is synchronised with the timeline. Raw events 6 False False True True True True True 2 True False True 3