[ { "path": ".github/workflows/ci.yml", "content": "name: CI\non:\n push:\n branches:\n - master\n tags:\n - v*\n pull_request:\n release:\n\nenv:\n GHC_FOR_RELEASE: \"9.10\"\n\njobs:\n build:\n name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} ${{matrix.container}}\n strategy:\n fail-fast: false\n matrix:\n os: [ubuntu-latest]\n ghc-version: ['9.12', '9.10', '9.8', '9.6', '9.4', '9.2']\n container: ['']\n\n include:\n # The windows build is currently broken\n # See #135\n - os: windows-latest\n ghc-version: '9.10'\n - os: macos-latest\n ghc-version: '9.10'\n # gtk2hs is broken under apline\n # See https://github.com/gtk2hs/gtk2hs/issues/262\n #- os: ubuntu-latest\n # ghc-version: '9.10'\n # container: alpine:3.21\n\n runs-on: ${{ matrix.os }}\n container: ${{ matrix.container }}\n\n steps:\n - uses: actions/checkout@v4\n\n - name: Install system dependencies (Alpine)\n if: ${{ startsWith(matrix.container, 'alpine') }}\n shell: sh\n run: |\n apk add bash curl sudo jq pkgconfig \\\n zlib-dev zlib-static binutils curl \\\n gcc g++ gmp-dev libc-dev libffi-dev make \\\n musl-dev ncurses-dev perl tar xz \\\n gtk+3.0-dev\n\n - name: Install system dependencies (Ubuntu)\n if: runner.os == 'Linux' && !startsWith(matrix.container, 'alpine')\n run: sudo apt-get update && sudo apt-get install libgtk-3-dev\n\n - name: Install system dependencies (macOS)\n if: runner.os == 'macOS'\n run: brew install cairo gtk+3 pkg-config\n\n - name: Set extra cabal build options (macOS)\n if: runner.os == 'macOS'\n run: |\n printf 'package gtk\\n flags: +have-quartz-gtk' >>cabal.project\n\n - name: Set up GHC ${{ matrix.ghc-version }}\n uses: haskell-actions/setup@v2\n id: setup\n with:\n ghc-version: ${{ matrix.ghc-version }}\n\n # Taken from https://github.com/agda/agda/blob/8210048a50c35d8d6fd0ae7e5edd1699592fda6f/src/github/workflows/cabal.yml#L113C1-L124C85\n # See: https://github.com/haskell/text-icu/pull/86\n # pacman needs MSYS /usr/bin in PATH, but this breaks the latest cache action.\n # - https://github.com/actions/cache/issues/1073\n # MSYS' pkg-config needs MSYS /mingw64/bin which we can safely add to the PATH\n #\n - name: Install system dependencies (Windows)\n if: ${{ startsWith(matrix.os, 'windows') }}\n shell: pwsh\n run: |\n $env:PATH = \"C:\\msys64\\usr\\bin;$env:PATH\"\n pacman --noconfirm -S msys2-keyring mingw-w64-x86_64-pkgconf mingw-w64-x86_64-gtk3\n echo \"C:\\msys64\\mingw64\\bin\" | Out-File -FilePath \"$env:GITHUB_PATH\" -Append\n\n - name: Enable static build (only on alpine)\n if: ${{ startsWith(matrix.container, 'alpine') }}\n run: |\n echo 'executable-static: true' >>cabal.project\n echo 'cc-options: -D_Noreturn=' >>cabal.project\n\n - name: Configure the build\n run: |\n cabal configure --enable-tests --enable-benchmarks --disable-documentation\n cabal build all --dry-run\n\n\n - name: Restore cached dependencies\n uses: actions/cache/restore@v4\n id: cache\n env:\n key: ${{ runner.os }}${{ matrix.container && '-container-' }}${{matrix.container}}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}\n with:\n path: ${{ steps.setup.outputs.cabal-store }}\n key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }}\n restore-keys: ${{ env.key }}-\n\n - name: Install dependencies\n # If we had an exact cache hit, the dependencies will be up to date.\n if: steps.cache.outputs.cache-hit != 'true'\n run: cabal build all --only-dependencies\n\n # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail.\n - name: Save cached dependencies\n uses: actions/cache/save@v4\n # If we had an exact cache hit, trying to save the cache would error because of key clash.\n if: steps.cache.outputs.cache-hit != 'true'\n with:\n path: ${{ steps.setup.outputs.cabal-store }}\n key: ${{ steps.cache.outputs.cache-primary-key }}\n\n - name: Build\n run: cabal build all\n\n - name: Run tests\n run: cabal test all\n\n - name: Check cabal file\n run: cabal check\n\n - name: Create bindist\n shell: sh\n run: |\n cabal install --install-method=copy --installdir=dist\n BINDIST_NAME=\"threadscope-ghc-${{matrix.ghc-version}}-${{ matrix.os }}${{ matrix.container && '-' }}${{matrix.container && 'alpine'}}\"\n echo \"BINDIST_NAME=$BINDIST_NAME\" >> \"$GITHUB_ENV\"\n tar -cJf \"$BINDIST_NAME.tar.xz\" -C dist threadscope\n echo bindist is \"$BINDIST_NAME.tar.xz\"\n\n - name: Upload bindist to artifacts\n uses: actions/upload-artifact@v4\n if: ${{ matrix.ghc-version == env.GHC_FOR_RELEASE }}\n with:\n name: ${{ env.BINDIST_NAME }}\n path: ${{ env.BINDIST_NAME}}.tar.xz\n\n - name: Release\n uses: softprops/action-gh-release@v2\n if: ${{ startsWith(github.ref, 'refs/tags/') && matrix.ghc-version == env.GHC_FOR_RELEASE }}\n with:\n files: ${{ env.BINDIST_NAME }}.tar.xz\n" }, { "path": ".gitignore", "content": "dist-newstyle\ncabal.project.local~*\n" }, { "path": "CHANGELOG.md", "content": "# Revision history for threadscope\n\n## 2025-05-29 - v0.2.15.0\n* Switch to GTK3 ([#137](https://github.com/haskell/ThreadScope/pull/137)))\n* Support new versions of GHC up to 9.12 and dependencies.\n\n## 2022-05-10 - v0.2.14.1\n\n* Spelling fixes ([#121](https://github.com/haskell/ThreadScope/pull/121), [#123](https://github.com/haskell/ThreadScope/pull/123))\n* Add compatibility with GHC-9.2 ([#124](https://github.com/haskell/ThreadScope/pull/124), [＃125](https://github.com/haskell/ThreadScope/pull/125))\n* Update dependencies ([#126](https://github.com/haskell/ThreadScope/pull/126))\n\n## 2021-01-09 - v0.2.14\n\n* Print times with more sensible units ([#111](https://github.com/haskell/ThreadScope/pull/111))\n* EventDuration: Make it more robust to truncated eventlogs ([#110](https://github.com/haskell/ThreadScope/pull/110))\n* Use GitHub Actions for CI ([#113](https://github.com/haskell/ThreadScope/pull/113))\n* Relax upper version bounds for ghc-events, time, bytestring, and template-haskell\n\n## 2020-04-06 - v0.2.13\n\n* Add changelog to extra-source-files ([#105](https://github.com/haskell/ThreadScope/pull/105))\n* Fix broken GitHub Releases deployment ([#106](https://github.com/haskell/ThreadScope/pull/106))\n* Update ghc-events to 0.13.0 ([#107](https://github.com/haskell/ThreadScope/pull/107))\n* Relax upper version bound for time\n\n## 2020-03-04 - v0.2.12\n\n* Remove unused events entry box ([#93](https://github.com/haskell/ThreadScope/pull/93))\n* Make the app work even if it fails to load the logo ([#96](https://github.com/haskell/ThreadScope/pull/96))\n* Support GHC 8.8 ([#99](https://github.com/haskell/ThreadScope/pull/99))\n* Support ghc-events 0.12.0 ([#101](https://github.com/haskell/ThreadScope/pull/101))\n* Stop using gtk-mac-integration and fix broken CI ([#103](https://github.com/haskell/ThreadScope/pull/103))\n * This causes a visual regression. The logo won't be displayed in Dock.\n\n## 2018-07-12 - v0.2.11.1\n\n* Relax upper version bounds for containers and ghc-events (#88)\n\n## 2018-06-08 - v0.2.11\n\n* Relax upper version bounds for template-haskell and temporary\n* Fix build failure with gtk-0.14.9\n* Modernise AppVeyor CI script\n\n## 2018-02-16 - v0.2.10\n\n* Add instructions to install gtk2 in the README\n* Do not include windows_cconv.h on non mingw32 systems (#79)\n* Relax upper version bound for ghc-events (#80)\n* Relax upper version bound for time\n\n## 2017-09-02 - v0.2.9\n\n* Render GC waiting periods in light orange (#70)\n* Fix inappropriate calling convention on Windows x86 (#71)\n* Enable GitHub Releases (#75)\n\n## 2017-07-17 - v0.2.8\n\n* Add macOS support (#56)\n* Update ghc-events to 0.6.0 (#61)\n* CI builds for Linux/Windows/macOS (#64, #65)\n* Set upper version bounds for dependencies\n" }, { "path": "Events/EventDuration.hs", "content": "-- This module supports a duration-based data-type to represent thread\n-- execution and GC information.\n\nmodule Events.EventDuration (\n EventDuration(..),\n isGCDuration,\n startTimeOf, endTimeOf, durationOf,\n eventsToDurations,\n isDiscreteEvent\n ) where\n\nimport System.IO\nimport System.IO.Unsafe\n\n-- Imports for GHC Events\nimport GHC.RTS.Events hiding (Event, GCIdle, GCWork)\nimport qualified GHC.RTS.Events as GHC\n\n-------------------------------------------------------------------------------\n-- This data structure is a duration-based representation of the eventlog\n-- information where thread-runs and GCs are explicitly represented by a\n-- single constructor identifying their start and end points.\n\ndata EventDuration\n = ThreadRun {-#UNPACK#-}!ThreadId\n ThreadStopStatus\n {-#UNPACK#-}!Timestamp\n {-#UNPACK#-}!Timestamp\n\n | GCStart {-#UNPACK#-}!Timestamp\n {-#UNPACK#-}!Timestamp\n\n | GCWork {-#UNPACK#-}!Timestamp\n {-#UNPACK#-}!Timestamp\n\n | GCIdle {-#UNPACK#-}!Timestamp\n {-#UNPACK#-}!Timestamp\n\n | GCEnd {-#UNPACK#-}!Timestamp\n {-#UNPACK#-}!Timestamp\n deriving Show\n\n{-\n GCStart GCWork GCIdle GCEnd\n gc start -----> work -----> idle ------+> done -----> gc end\n | |\n `-------<-------<-----'\n-}\n\nisGCDuration :: EventDuration -> Bool\nisGCDuration GCStart{} = True\nisGCDuration GCWork{} = True\nisGCDuration GCIdle{} = True\nisGCDuration GCEnd{} = True\nisGCDuration _ = False\n\n-------------------------------------------------------------------------------\n-- The start time of an event.\n\nstartTimeOf :: EventDuration -> Timestamp\nstartTimeOf ed\n = case ed of\n ThreadRun _ _ startTime _ -> startTime\n GCStart startTime _ -> startTime\n GCWork startTime _ -> startTime\n GCIdle startTime _ -> startTime\n GCEnd startTime _ -> startTime\n\n-------------------------------------------------------------------------------\n-- The emd time of an event.\n\nendTimeOf :: EventDuration -> Timestamp\nendTimeOf ed\n = case ed of\n ThreadRun _ _ _ endTime -> endTime\n GCStart _ endTime -> endTime\n GCWork _ endTime -> endTime\n GCIdle _ endTime -> endTime\n GCEnd _ endTime -> endTime\n\n-------------------------------------------------------------------------------\n-- The duration of an EventDuration\n\ndurationOf :: EventDuration -> Timestamp\ndurationOf ed = endTimeOf ed - startTimeOf ed\n\n-------------------------------------------------------------------------------\n\neventsToDurations :: [GHC.Event] -> [EventDuration]\neventsToDurations [] = []\neventsToDurations (event : events) =\n case evSpec event of\n RunThread{thread=t}\n | Just ev <- runDuration t -> ev : rest\n | otherwise -> rest\n StopThread{} -> rest\n StartGC -> gcStart (evTime event) events\n EndGC{} -> rest\n _otherEvent -> rest\n where\n rest = eventsToDurations events\n\n runDuration :: ThreadId -> Maybe EventDuration\n runDuration t = do\n (endTime, s) <- findRunThreadTime events\n return $ ThreadRun t s (evTime event) endTime\n\nisDiscreteEvent :: GHC.Event -> Bool\nisDiscreteEvent e =\n case evSpec e of\n RunThread{} -> False\n StopThread{} -> False\n StartGC{} -> False\n EndGC{} -> False\n GHC.GCWork{} -> False\n GHC.GCIdle{} -> False\n GHC.GCDone{} -> False\n GHC.SparkCounters{} -> False\n _ -> True\n\ngcStart :: Timestamp -> [GHC.Event] -> [EventDuration]\ngcStart _ [] = []\ngcStart t0 (event : events) =\n case evSpec event of\n GHC.GCWork{} -> GCStart t0 t1 : gcWork t1 events\n GHC.GCIdle{} -> GCStart t0 t1 : gcIdle t1 events\n GHC.GCDone{} -> GCStart t0 t1 : gcDone t1 events\n GHC.EndGC{} -> GCStart t0 t1 : eventsToDurations events\n RunThread{} -> GCStart t0 t1 : eventsToDurations (event : events)\n _other -> gcStart t0 events\n where\n t1 = evTime event\n\ngcWork :: Timestamp -> [GHC.Event] -> [EventDuration]\ngcWork _ [] = []\ngcWork t0 (event : events) =\n case evSpec event of\n GHC.GCWork{} -> gcWork t0 events\n GHC.GCIdle{} -> GCWork t0 t1 : gcIdle t1 events\n GHC.GCDone{} -> GCWork t0 t1 : gcDone t1 events\n GHC.EndGC{} -> GCWork t0 t1 : eventsToDurations events\n RunThread{} -> GCWork t0 t1 : eventsToDurations (event : events)\n _other -> gcStart t0 events\n where\n t1 = evTime event\n\ngcIdle :: Timestamp -> [GHC.Event] -> [EventDuration]\ngcIdle _ [] = []\ngcIdle t0 (event : events) =\n case evSpec event of\n GHC.GCIdle{} -> gcIdle t0 events\n GHC.GCWork{} -> GCIdle t0 t1 : gcWork t1 events\n GHC.GCDone{} -> GCIdle t0 t1 : gcDone t1 events\n GHC.EndGC{} -> GCIdle t0 t1 : eventsToDurations events\n RunThread{} -> GCIdle t0 t1 : eventsToDurations (event : events)\n _other -> gcStart t0 events\n where\n t1 = evTime event\n\ngcDone :: Timestamp -> [GHC.Event] -> [EventDuration]\ngcDone _ [] = []\ngcDone t0 (event : events) =\n case evSpec event of\n GHC.GCDone{} -> gcDone t0 events\n GHC.GCWork{} -> GCEnd t0 t1 : gcWork t1 events\n GHC.GCIdle{} -> GCEnd t0 t1 : gcIdle t1 events\n GHC.EndGC{} -> GCEnd t0 t1 : eventsToDurations events\n RunThread{} -> GCEnd t0 t1 : eventsToDurations (event : events)\n _other -> gcStart t0 events\n where\n t1 = evTime event\n\n-------------------------------------------------------------------------------\n\nfindRunThreadTime :: [GHC.Event] -> Maybe (Timestamp, ThreadStopStatus)\nfindRunThreadTime [] = Nothing\nfindRunThreadTime (e : es)\n = case evSpec e of\n StopThread{status=s} -> Just (evTime e, s)\n _ | [] <- es -> unsafePerformIO $ do\n hPutStrLn stderr \"warning: failed to find stop event for thread; eventlog truncated?\"\n return $ Just (evTime e, NoStatus)\n -- the eventlog abruptly ended; presumably the\n -- thread was still running.\n | otherwise -> findRunThreadTime es\n\n-------------------------------------------------------------------------------\n" }, { "path": "Events/EventTree.hs", "content": "module Events.EventTree (\n DurationTree(..),\n mkDurationTree,\n\n runTimeOf, gcTimeOf,\n reportDurationTree,\n durationTreeCountNodes,\n durationTreeMaxDepth,\n\n EventTree(..), EventNode(..),\n mkEventTree,\n reportEventTree, eventTreeMaxDepth,\n ) where\n\nimport Events.EventDuration\n\nimport GHC.RTS.Events hiding (Event)\nimport qualified GHC.RTS.Events as GHC\n\nimport Control.Exception (assert)\nimport Text.Printf\n\n-------------------------------------------------------------------------------\n\n-- We map the events onto a binary search tree, so that we can easily\n-- find the events that correspond to a particular view of the\n-- timeline. Additionally, each node of the tree contains a summary\n-- of the information below it, so that we can render views at various\n-- levels of resolution. For example, if a tree node would represent\n-- less than one pixel on the display, there is no point is descending\n-- the tree further.\n\n-- We only split at event boundaries; we never split an event into\n-- multiple pieces. Therefore, the binary tree is only roughly split\n-- by time, the actual split depends on the distribution of events\n-- below it.\n\ndata DurationTree\n = DurationSplit\n {-#UNPACK#-}!Timestamp -- The start time of this run-span\n {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts\n {-#UNPACK#-}!Timestamp -- The end time of this run-span\n DurationTree -- The LHS split; all events lie completely between\n -- start and split\n DurationTree -- The RHS split; all events lie completely between\n -- split and end\n {-#UNPACK#-}!Timestamp -- The total amount of time spent running a thread\n {-#UNPACK#-}!Timestamp -- The total amount of time spend in GC\n\n | DurationTreeLeaf\n EventDuration\n\n | DurationTreeEmpty\n\n deriving Show\n\n-------------------------------------------------------------------------------\n\nmkDurationTree :: [EventDuration] -> Timestamp -> DurationTree\nmkDurationTree es endTime =\n -- trace (show tree) $\n tree\n where\n tree = splitDurations es endTime\n\nsplitDurations :: [EventDuration] -- events\n -> Timestamp -- end time of last event in the list\n -> DurationTree\nsplitDurations [] _endTime =\n -- if len /= 0 then error \"splitDurations0\" else\n DurationTreeEmpty -- The case for an empty list of events.\n\nsplitDurations [e] _entTime =\n DurationTreeLeaf e\n\nsplitDurations es endTime\n | null rhs\n = splitDurations es lhs_end\n\n | null lhs\n = error $\n printf \"splitDurations: null lhs: len = %d, startTime = %d, endTime = %d\\n\"\n (length es) startTime endTime\n ++ '\\n': show es\n\n | otherwise\n = -- trace (printf \"len = %d, startTime = %d, endTime = %d, lhs_len = %d\\n\" len startTime endTime lhs_len) $\n assert (length lhs + length rhs == length es) $\n DurationSplit startTime\n lhs_end\n endTime\n ltree\n rtree\n runTime\n gcTime\n where\n startTime = startTimeOf (head es)\n splitTime = startTime + (endTime - startTime) `div` 2\n\n (lhs, lhs_end, rhs) = splitDurationList es [] splitTime 0\n\n ltree = splitDurations lhs lhs_end\n rtree = splitDurations rhs endTime\n\n runTime = runTimeOf ltree + runTimeOf rtree\n gcTime = gcTimeOf ltree + gcTimeOf rtree\n\n\nsplitDurationList :: [EventDuration]\n -> [EventDuration]\n -> Timestamp\n -> Timestamp\n -> ([EventDuration], Timestamp, [EventDuration])\nsplitDurationList [] acc !_tsplit !tmax\n = (reverse acc, tmax, [])\nsplitDurationList [e] acc !_tsplit !tmax\n -- Just one event left: put it on the right. This ensures that we\n -- have at least one event on each side of the split.\n = (reverse acc, tmax, [e])\nsplitDurationList (e:es) acc !tsplit !tmax\n | tstart <= tsplit -- pick all events that start at or before the split\n = splitDurationList es (e:acc) tsplit (max tmax tend)\n | otherwise\n = (reverse acc, tmax, e:es)\n where\n tstart = startTimeOf e\n tend = endTimeOf e\n\n-------------------------------------------------------------------------------\n\nrunTimeOf :: DurationTree -> Timestamp\nrunTimeOf (DurationSplit _ _ _ _ _ runTime _) = runTime\nrunTimeOf (DurationTreeLeaf e) | ThreadRun{} <- e = durationOf e\nrunTimeOf _ = 0\n\n-------------------------------------------------------------------------------\n\ngcTimeOf :: DurationTree -> Timestamp\ngcTimeOf (DurationSplit _ _ _ _ _ _ gcTime) = gcTime\ngcTimeOf (DurationTreeLeaf e) | isGCDuration e = durationOf e\ngcTimeOf _ = 0\n\n-------------------------------------------------------------------------------\n\nreportDurationTree :: Int -> DurationTree -> IO ()\nreportDurationTree hecNumber eventTree\n = putStrLn (\"HEC \" ++ show hecNumber ++ reportText)\n where\n reportText = \" nodes = \" ++ show (durationTreeCountNodes eventTree) ++\n \" max depth = \" ++ show (durationTreeMaxDepth eventTree)\n\n-------------------------------------------------------------------------------\n\ndurationTreeCountNodes :: DurationTree -> Int\ndurationTreeCountNodes (DurationSplit _ _ _ lhs rhs _ _)\n = 1 + durationTreeCountNodes lhs + durationTreeCountNodes rhs\ndurationTreeCountNodes _ = 1\n\n-------------------------------------------------------------------------------\n\ndurationTreeMaxDepth :: DurationTree -> Int\ndurationTreeMaxDepth (DurationSplit _ _ _ lhs rhs _ _)\n = 1 + durationTreeMaxDepth lhs `max` durationTreeMaxDepth rhs\ndurationTreeMaxDepth _ = 1\n\n-------------------------------------------------------------------------------\n\ndata EventTree\n = EventTree\n {-#UNPACK#-}!Timestamp -- The start time of this run-span\n {-#UNPACK#-}!Timestamp -- The end time of this run-span\n EventNode\n\ndata EventNode\n = EventSplit\n {-#UNPACK#-}!Timestamp -- The time used to split the events into two parts\n EventNode -- The LHS split; all events lie completely between\n -- start and split\n EventNode -- The RHS split; all events lie completely between\n -- split and end\n\n | EventTreeLeaf [GHC.Event]\n -- sometimes events happen \"simultaneously\" (at the same time\n -- given the resolution of our clock source), so we can't\n -- separate them.\n\n | EventTreeOne GHC.Event\n -- This is a space optimisation for the common case of\n -- EventTreeLeaf [e].\n\nmkEventTree :: [GHC.Event] -> Timestamp -> EventTree\nmkEventTree es endTime =\n EventTree s e $\n -- trace (show tree) $\n tree\n where\n tree = splitEvents es endTime\n (s,e) = if null es then (0,0) else (evTime (head es), endTime)\n\nsplitEvents :: [GHC.Event] -- events\n -> Timestamp -- end time of last event in the list\n -> EventNode\nsplitEvents [] !_endTime =\n -- if len /= 0 then error \"splitEvents0\" else\n EventTreeLeaf [] -- The case for an empty list of events\n\nsplitEvents [e] !_endTime =\n EventTreeOne e\n\nsplitEvents es !endTime\n | duration == 0\n = EventTreeLeaf es\n\n | null rhs\n = splitEvents es lhs_end\n\n | null lhs\n = error $\n printf \"splitEvents: null lhs: len = %d, startTime = %d, endTime = %d\\n\"\n (length es) startTime endTime\n ++ '\\n': show es\n\n | otherwise\n = -- trace (printf \"len = %d, startTime = %d, endTime = %d, lhs_len = %d\\n\" len startTime endTime lhs_len) $\n assert (length lhs + length rhs == length es) $\n EventSplit (evTime (head rhs))\n ltree\n rtree\n where\n -- | Integer division, rounding up.\n divUp :: Timestamp -> Timestamp -> Timestamp\n divUp n k = (n + k - 1) `div` k\n startTime = evTime (head es)\n splitTime = startTime + (endTime - startTime) `divUp` 2\n duration = endTime - startTime\n\n (lhs, lhs_end, rhs) = splitEventList es [] splitTime 0\n\n ltree = splitEvents lhs lhs_end\n rtree = splitEvents rhs endTime\n\n\nsplitEventList :: [GHC.Event]\n -> [GHC.Event]\n -> Timestamp\n -> Timestamp\n -> ([GHC.Event], Timestamp, [GHC.Event])\nsplitEventList [] acc !_tsplit !tmax\n = (reverse acc, tmax, [])\nsplitEventList [e] acc !_tsplit !tmax\n -- Just one event left: put it on the right. This ensures that we\n -- have at least one event on each side of the split.\n = (reverse acc, tmax, [e])\nsplitEventList (e:es) acc !tsplit !tmax\n | t <= tsplit -- pick all events that start at or before the split\n = splitEventList es (e:acc) tsplit (max tmax t)\n | otherwise\n = (reverse acc, tmax, e:es)\n where\n t = evTime e\n\n-------------------------------------------------------------------------------\n\nreportEventTree :: Int -> EventTree -> IO ()\nreportEventTree hecNumber (EventTree _ _ eventTree)\n = putStrLn (\"HEC \" ++ show hecNumber ++ reportText)\n where\n reportText = \" nodes = \" ++ show (eventTreeCountNodes eventTree) ++\n \" max depth = \" ++ show (eventNodeMaxDepth eventTree)\n\n-------------------------------------------------------------------------------\n\neventTreeCountNodes :: EventNode -> Int\neventTreeCountNodes (EventSplit _ lhs rhs)\n = 1 + eventTreeCountNodes lhs + eventTreeCountNodes rhs\neventTreeCountNodes _ = 1\n\n-------------------------------------------------------------------------------\n\neventTreeMaxDepth :: EventTree -> Int\neventTreeMaxDepth (EventTree _ _ t) = eventNodeMaxDepth t\n\neventNodeMaxDepth :: EventNode -> Int\neventNodeMaxDepth (EventSplit _ lhs rhs)\n = 1 + eventNodeMaxDepth lhs `max` eventNodeMaxDepth rhs\neventNodeMaxDepth _ = 1\n" }, { "path": "Events/HECs.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Events.HECs (\n HECs(..),\n Event,\n Timestamp,\n\n eventIndexToTimestamp,\n timestampToEventIndex,\n extractUserMarkers,\n histogram,\n histogramCounts,\n ) where\n\nimport Events.EventTree\nimport Events.SparkTree\nimport GHC.RTS.Events\n\nimport Data.Array\nimport Data.Text (Text)\nimport qualified Data.List as L\n\n#if MIN_VERSION_containers(0,5,0)\nimport qualified Data.IntMap.Strict as IM\n#else\nimport qualified Data.IntMap as IM\n#endif\n\n-----------------------------------------------------------------------------\n\n-- all the data from a .eventlog file\ndata HECs = HECs {\n hecCount :: Int,\n hecTrees :: [(DurationTree, EventTree, SparkTree)],\n hecEventArray :: Array Int Event,\n hecLastEventTime :: Timestamp,\n maxSparkPool :: Double,\n minXHistogram :: Int,\n maxXHistogram :: Int,\n maxYHistogram :: Timestamp,\n durHistogram :: [(Timestamp, Int, Timestamp)],\n perfNames :: IM.IntMap Text\n }\n\n-----------------------------------------------------------------------------\n\neventIndexToTimestamp :: HECs -> Int -> Timestamp\neventIndexToTimestamp HECs{hecEventArray=arr} n =\n evTime (arr ! n)\n\ntimestampToEventIndex :: HECs -> Timestamp -> Int\ntimestampToEventIndex HECs{hecEventArray=arr} ts =\n search l (r+1)\n where\n (l,r) = bounds arr\n\n search !l !r\n | (r - l) <= 1 = if ts > evTime (arr!l) then r else l\n | ts < tmid = search l mid\n | otherwise = search mid r\n where\n mid = l + (r - l) `quot` 2\n tmid = evTime (arr!mid)\n\nextractUserMarkers :: HECs -> [(Timestamp, Text)]\nextractUserMarkers hecs =\n [ (ts, mark)\n | (Event ts (UserMarker mark) _) <- elems (hecEventArray hecs) ]\n\n-- | Sum durations in the same buckets to form a histogram.\nhistogram :: [(Int, Timestamp)] -> [(Int, Timestamp)]\nhistogram durs = IM.toList $ fromListWith' (+) durs\n\n-- | Sum durations and spark counts in the same buckets to form a histogram.\nhistogramCounts :: [(Int, (Timestamp, Int))] -> [(Int, (Timestamp, Int))]\nhistogramCounts durs =\n let agg (dur1, count1) (dur2, count2) =\n -- bangs needed to avoid stack overflow\n let !dur = dur1 + dur2\n !count = count1 + count2\n in (dur, count)\n in IM.toList $ fromListWith' agg durs\n\nfromListWith' :: (a -> a -> a) -> [(Int, a)] -> IM.IntMap a\nfromListWith' f xs =\n L.foldl' ins IM.empty xs\n where\n#if MIN_VERSION_containers(0,5,0)\n ins t (k,x) = IM.insertWith f k x t\n#elif MIN_VERSION_containers(0,4,1)\n ins t (k,x) = IM.insertWith' f k x t\n#else\n ins t (k,x) =\n let r = IM.insertWith f k x t\n v = r IM.! k\n in v `seq` r\n#endif\n" }, { "path": "Events/ReadEvents.hs", "content": "module Events.ReadEvents (\n registerEventsFromFile, registerEventsFromTrace\n ) where\n\nimport Events.EventDuration\nimport Events.EventTree\nimport Events.HECs (HECs (..), histogram)\nimport Events.SparkTree\nimport Events.TestEvents\nimport GUI.ProgressView (ProgressView)\nimport qualified GUI.ProgressView as ProgressView\n\nimport GHC.RTS.Events\n\nimport GHC.RTS.Events.Analysis\nimport GHC.RTS.Events.Analysis.Capability\nimport GHC.RTS.Events.Analysis.SparkThread\n\nimport qualified Control.DeepSeq as DeepSeq\nimport Control.Exception\nimport Control.Monad\nimport Data.Array\nimport Data.Either\nimport Data.Function\nimport qualified Data.IntMap as IM\nimport qualified Data.List as L\nimport Data.Map (Map)\nimport qualified Data.Map as M\nimport Data.Maybe (catMaybes, fromMaybe)\nimport Data.Set (Set)\nimport System.FilePath\nimport Text.Printf\n\n-------------------------------------------------------------------------------\n-- import qualified GHC.RTS.Events as GHCEvents\n--\n-- The GHC.RTS.Events library returns the profile information\n-- in a data-structure which contains a list data structure\n-- representing the events i.e. [GHCEvents.Event]\n-- ThreadScope transforms this list into an alternative representation\n-- which (for each HEC) records event *durations* which are ordered in time.\n-- The durations represent the run-lengths for thread execution and\n-- run-lengths for garbage collection. This data-structure is called\n-- EventDuration.\n-- ThreadScope then transformations this data-structure into another\n-- data-structure which gives a binary-tree view of the event information\n-- by performing a binary split on the time domain i.e. the EventTree\n-- data structure.\n\n-- GHCEvents.Event => [EventDuration] => EventTree\n\n-------------------------------------------------------------------------------\n\nrawEventsToHECs :: [Event] -> Timestamp\n -> [(Double, (DurationTree, EventTree, SparkTree))]\nrawEventsToHECs evs endTime\n = map (\\cap -> toTree $ L.find ((Just cap ==) . evCap . head) heclists)\n [0 .. maximum (0 : map (fromMaybe 0 . evCap) evs)]\n where\n heclists =\n L.groupBy ((==) `on` evCap) $ L.sortBy (compare `on` evCap) evs\n\n toTree Nothing = (0, (DurationTreeEmpty,\n EventTree 0 0 (EventTreeLeaf []),\n emptySparkTree))\n toTree (Just evs) =\n (maxSparkPool,\n (mkDurationTree (eventsToDurations nondiscrete) endTime,\n mkEventTree discrete endTime,\n mkSparkTree sparkD endTime))\n where (discrete, nondiscrete) = L.partition isDiscreteEvent evs\n (maxSparkPool, sparkD) = eventsToSparkDurations nondiscrete\n\n-------------------------------------------------------------------------------\n\nregisterEventsFromFile :: String -> ProgressView\n -> IO (HECs, String, Int, Double)\nregisterEventsFromFile filename = registerEvents (Left filename)\n\nregisterEventsFromTrace :: String -> ProgressView\n -> IO (HECs, String, Int, Double)\nregisterEventsFromTrace traceName = registerEvents (Right traceName)\n\nregisterEvents :: Either FilePath String\n -> ProgressView\n -> IO (HECs, String, Int, Double)\n\nregisterEvents from progress = do\n\n let msg = case from of\n Left filename -> filename\n Right test -> test\n\n ProgressView.setTitle progress (\"Loading \" ++ takeFileName msg)\n\n buildEventLog progress from\n\n-------------------------------------------------------------------------------\n-- Runs in a background thread\n--\nbuildEventLog :: ProgressView -> Either FilePath String\n -> IO (HECs, String, Int, Double)\nbuildEventLog progress from =\n case from of\n Right test -> build test (testTrace test)\n Left filename -> do\n stopPulse <- ProgressView.startPulse progress\n fmt <- readEventLogFromFile filename\n stopPulse\n case fmt of\n Left err -> fail err --FIXME: report error properly\n Right evs -> build filename evs\n\n where\n -- | Integer division, rounding up.\n divUp :: Timestamp -> Timestamp -> Timestamp\n divUp n k = (n + k - 1) `div` k\n build name evs = do\n let\n eBy1000 ev = ev{evTime = evTime ev `divUp` 1000}\n eventsBy = map eBy1000 (events (dat evs))\n eventBlockEnd e | EventBlock{ end_time=t } <- evSpec e = t\n eventBlockEnd e = evTime e\n\n -- 1, to avoid graph scale 0 and division by 0 later on\n lastTx = maximum (1 : map eventBlockEnd eventsBy)\n\n -- Add caps to perf events, using the OS thread numbers\n -- obtained from task validation data.\n -- Only the perf events with a cap are displayed in the timeline.\n -- TODO: it may make sense to move this code to ghc-events\n -- and run after to-eventlog and ghc-events merge, but it requires\n -- one more step in the 'perf to TS' workflow and is a bit slower\n -- (yet another event sorting and loading eventlog chunks\n -- into the CPU cache).\n steps :: [Event] -> [(Map KernelThreadId Int, Event)]\n steps evs =\n zip (map fst $ rights $ validates capabilityTaskOSMachine evs) evs\n addC :: (Map KernelThreadId Int, Event) -> Event\n addC (state, ev@Event{evSpec=PerfTracepoint{tid}}) =\n case M.lookup tid state of\n Nothing -> ev -- unknown task's OS thread\n evCap -> ev {evCap}\n addC (state, ev@Event{evSpec=PerfCounter{tid}}) =\n case M.lookup tid state of\n Nothing -> ev -- unknown task's OS thread\n evCap -> ev {evCap}\n addC (_, ev) = ev\n addCaps evs = map addC (steps evs)\n\n -- sort the events by time, add extra caps and put them in an array\n sorted = addCaps $ sortEvents eventsBy\n maxTrees = rawEventsToHECs sorted lastTx\n maxSparkPool = maximum (0 : map fst maxTrees)\n trees = map snd maxTrees\n\n -- put events in an array\n n_events = length sorted\n event_arr = listArray (0, n_events-1) sorted\n hec_count = length trees\n\n -- Pre-calculate the data for the sparks histogram.\n intDoub :: Integral a => a -> Double\n intDoub = fromIntegral\n -- Discretizes the data using log.\n -- Log base 2 seems to result in 7--15 bars, which is OK visually.\n -- Better would be 10--15 bars, but we want the base to be a small\n -- integer, for readable scales, and we can't go below 2.\n ilog :: Timestamp -> Int\n ilog 0 = 0\n ilog x = floor $ logBase 2 (intDoub x)\n times :: (Int, Timestamp, Timestamp)\n -> Maybe (Timestamp, Int, Timestamp)\n times (_, timeStarted, timeElapsed) =\n Just (timeStarted, ilog timeElapsed, timeElapsed)\n\n sparkProfile :: Process\n ((Map ThreadId (Profile SparkThreadState),\n (Map Int ThreadId, Set ThreadId)),\n Event)\n (ThreadId, (SparkThreadState, Timestamp, Timestamp))\n sparkProfile = profileRouted\n (refineM evSpec sparkThreadMachine)\n capabilitySparkThreadMachine\n capabilitySparkThreadIndexer\n evTime\n sorted\n\n sparkSummary :: Map ThreadId (Int, Timestamp, Timestamp)\n -> [(ThreadId, (SparkThreadState, Timestamp, Timestamp))]\n -> [Maybe (Timestamp, Int, Timestamp)]\n sparkSummary m [] = map times $ M.elems m\n sparkSummary m ((threadId, (state, timeStarted', timeElapsed')):xs) =\n case state of\n SparkThreadRunning sparkId' -> case M.lookup threadId m of\n Just el@(sparkId, timeStarted, timeElapsed) ->\n if sparkId == sparkId'\n then let value = (sparkId, timeStarted, timeElapsed + timeElapsed')\n in sparkSummary (M.insert threadId value m) xs\n else times el : newSummary sparkId' xs\n Nothing -> newSummary sparkId' xs\n _ -> sparkSummary m xs\n where\n newSummary sparkId = let value = (sparkId, timeStarted', timeElapsed')\n in sparkSummary (M.insert threadId value m)\n\n allHisto :: [(Timestamp, Int, Timestamp)]\n allHisto = catMaybes . sparkSummary M.empty . toList $ sparkProfile\n\n -- Sparks of zero length are already well visualized in other graphs:\n durHistogram = filter (\\ (_, logdur, _) -> logdur > 0) allHisto\n -- Precompute some extremums of the maximal interval, needed for scales.\n durs = [(logdur, dur) | (_start, logdur, dur) <- durHistogram]\n (logDurs, sumDurs) = L.unzip (histogram durs)\n minXHistogram = minimum (maxBound : logDurs)\n maxXHistogram = maximum (minBound : logDurs)\n maxY = maximum (minBound : sumDurs)\n -- round up to multiples of 10ms\n maxYHistogram = 10000 * ceiling (fromIntegral maxY / 10000)\n\n getPerfNames nmap ev =\n case evSpec ev of\n PerfName{perfNum, name} ->\n IM.insert (fromIntegral perfNum) name nmap\n _ -> nmap\n perfNames = L.foldl' getPerfNames IM.empty eventsBy\n\n hecs = HECs {\n hecCount = hec_count,\n hecTrees = trees,\n hecEventArray = event_arr,\n hecLastEventTime = lastTx,\n maxSparkPool,\n minXHistogram,\n maxXHistogram,\n maxYHistogram,\n durHistogram,\n perfNames\n }\n\n treeProgress :: Int -> (DurationTree, EventTree, SparkTree) -> IO ()\n treeProgress hec (tree1, tree2, tree3) = do\n ProgressView.setText progress $\n printf \"Building HEC %d/%d\" (hec+1) hec_count\n ProgressView.setProgress progress hec_count hec\n evaluate tree1\n evaluate (eventTreeMaxDepth tree2)\n evaluate (sparkTreeMaxDepth tree3)\n when (hec_count == 1 || hec == 1) -- eval only with 2nd HEC\n (return $! DeepSeq.rnf durHistogram)\n\n zipWithM_ treeProgress [0..] trees\n ProgressView.setProgress progress hec_count hec_count\n\n -- TODO: fully evaluate HECs before returning because otherwise the last\n -- bit of work gets done after the progress window has been closed.\n\n return (hecs, name, n_events, fromIntegral lastTx / 1000000)\n" }, { "path": "Events/SparkStats.hs", "content": "module Events.SparkStats\n ( SparkStats(..)\n , initial, create, rescale, aggregate, agEx\n ) where\n\nimport Data.Word (Word64)\n\n-- | Sparks change state. Each state transition process has a duration.\n-- Spark statistics, for a given duration, record the spark transition rate\n-- (the number of sparks that enter a given state within the interval)\n-- and the absolute mean, maximal and minimal number of sparks\n-- in the spark pool within the duration.\ndata SparkStats =\n SparkStats { rateCreated, rateDud, rateOverflowed,\n rateConverted, rateFizzled, rateGCd,\n meanPool, maxPool, minPool :: {-# UNPACK #-}!Double }\n deriving (Show, Eq)\n\n-- | Initial, default value of spark stats, at the start of runtime,\n-- before any spark activity is recorded.\ninitial :: SparkStats\ninitial = SparkStats 0 0 0 0 0 0 0 0 0\n\n-- | Create spark stats for a duration, given absolute\n-- numbers of sparks in all categories at the start and end of the duration.\n-- The units for spark transitions (first 6 counters) is [spark/duration]:\n-- the fact that intervals may have different lengths is ignored here.\n-- The units for the pool stats are just [spark].\n-- The values in the second counter have to be greater or equal\n-- to the values in the first counter, except for the spark pool size.\n-- For pool size, we take into account only the first sample,\n-- to visualize more detail at high zoom levels, at the cost\n-- of a slight shift of the graph. Mathematically, this corresponds\n-- to taking the initial durations as centered around samples,\n-- but to have the same tree for rates and pool sizes, we then have\n-- to shift the durations by half interval size to the right\n-- (which would be neglectable if the interval was small and even).\ncreate :: (Word64, Word64, Word64, Word64, Word64, Word64, Word64)\n -> (Word64, Word64, Word64, Word64, Word64, Word64, Word64)\n -> SparkStats\ncreate (crt1, dud1, ovf1, cnv1, fiz1, gcd1, remaining1)\n (crt2, dud2, ovf2, cnv2, fiz2, gcd2, _remaining2) =\n let (crt, dud, ovf, cnv, fiz, gcd) =\n (fromIntegral $ crt2 - crt1,\n fromIntegral $ dud2 - dud1,\n fromIntegral $ ovf2 - ovf1,\n fromIntegral $ cnv2 - cnv1,\n fromIntegral $ fiz2 - fiz1,\n fromIntegral $ gcd2 - gcd1)\n p = fromIntegral remaining1\n in SparkStats crt dud ovf cnv fiz gcd p p p\n\n-- | Reduce a list of spark stats; spark pool stats are overwritten.\nfoldStats :: (Double -> Double -> Double)\n -> Double -> Double -> Double\n -> [SparkStats] -> SparkStats\nfoldStats f meanP maxP minP l\n = SparkStats\n (foldr f 0 (map rateCreated l))\n (foldr f 0 (map rateDud l))\n (foldr f 0 (map rateOverflowed l))\n (foldr f 0 (map rateConverted l))\n (foldr f 0 (map rateFizzled l))\n (foldr f 0 (map rateGCd l))\n meanP maxP minP\n\n-- | Rescale the spark transition stats, e.g., to change their units.\nrescale :: Double -> SparkStats -> SparkStats\nrescale scale s =\n let f w _ = scale * w\n in foldStats f (meanPool s) (maxPool s) (minPool s) [s]\n\n-- | Derive spark stats for an interval from a list of spark stats,\n-- in reverse chronological order, of consecutive subintervals\n-- that sum up to the original interval.\naggregate :: [SparkStats] -> SparkStats\naggregate [] = error \"aggregate\"\naggregate [s] = s -- optimization\naggregate l =\n let meanP = sum (map meanPool l) / fromIntegral (length l) -- TODO: inaccurate\n maxP = maximum (map maxPool l)\n minP = minimum (map minPool l)\n in foldStats (+) meanP maxP minP l\n\n-- | Extrapolate spark stats from previous data.\n-- Absolute pools size values extrapolate by staying constant,\n-- rates of change of spark status extrapolate by dropping to 0\n-- (which corresponds to absolute numbers of sparks staying constant).\nextrapolate :: SparkStats -> SparkStats\nextrapolate s =\n let f w _ = 0 * w\n in foldStats f (meanPool s) (maxPool s) (minPool s) [s]\n\n-- | Aggregate, if any data provided. Extrapolate from previous data, otherwise.\n-- In both cases, the second component is the new choice of \"previous data\".\n-- The list of stats is expected in reverse chronological order,\n-- as for aggregate.\nagEx :: [SparkStats] -> SparkStats -> (SparkStats, SparkStats)\nagEx [] s = (extrapolate s, s)\nagEx l@(s:_) _ = (aggregate l, s)\n" }, { "path": "Events/SparkTree.hs", "content": "module Events.SparkTree (\n SparkTree,\n sparkTreeMaxDepth,\n emptySparkTree,\n eventsToSparkDurations,\n mkSparkTree,\n sparkProfile,\n ) where\n\nimport qualified Events.SparkStats as SparkStats\n\nimport GHC.RTS.Events (Timestamp)\nimport qualified GHC.RTS.Events as GHCEvents\n\nimport Control.Exception (assert)\nimport Text.Printf\n-- import Debug.Trace\n\n-- | Sparks change state. Each state transition process has a duration.\n-- SparkDuration is a condensed description of such a process,\n-- containing a start time of the duration interval,\n-- spark stats that record the spark transition rate\n-- and the absolute number of sparks in the spark pool within the duration.\ndata SparkDuration =\n SparkDuration { startT :: {-#UNPACK#-}!Timestamp,\n deltaC :: {-#UNPACK#-}!SparkStats.SparkStats }\n deriving Show\n\n-- | Calculates durations and maximal rendered values from the event log.\n-- Warning: cannot be applied to a suffix of the log (assumes start at time 0).\neventsToSparkDurations :: [GHCEvents.Event] -> (Double, [SparkDuration])\neventsToSparkDurations es =\n let aux _startTime _startCounters [] = (0, [])\n aux startTime startCounters (event : events) =\n case GHCEvents.evSpec event of\n GHCEvents.SparkCounters crt dud ovf cnv fiz gcd rem ->\n let endTime = GHCEvents.evTime event\n endCounters = (crt, dud, ovf, cnv, fiz, gcd, rem)\n delta = SparkStats.create startCounters endCounters\n newMaxSparkPool = SparkStats.maxPool delta\n sd = SparkDuration { startT = startTime,\n deltaC = delta }\n (oldMaxSparkPool, l) = aux endTime endCounters events\n in (max oldMaxSparkPool newMaxSparkPool, sd : l)\n _otherEvent -> aux startTime startCounters events\n in aux 0 (0,0,0,0,0,0,0) es\n\n\n-- | We map the spark transition durations (intervals) onto a binary\n-- search tree, so that we can easily find the durations\n-- that correspond to a particular view of the timeline.\n-- Additionally, each node of the tree contains a summary\n-- of the information below it, so that we can render views at various\n-- levels of resolution. For example, if a tree node would represent\n-- less than one pixel on the display, there is no point is descending\n-- the tree further.\ndata SparkTree\n = SparkTree\n {-#UNPACK#-}!Timestamp -- ^ start time of span represented by the tree\n {-#UNPACK#-}!Timestamp -- ^ end time of the span represented by the tree\n SparkNode\n deriving Show\n\ndata SparkNode\n = SparkSplit\n {-#UNPACK#-}!Timestamp -- ^ time used to split the span into two parts\n SparkNode\n -- ^ the LHS split; all data lies completely between start and split\n SparkNode\n -- ^ the RHS split; all data lies completely between split and end\n {-#UNPACK#-}!SparkStats.SparkStats\n -- ^ aggregate of the spark stats within the span\n | SparkTreeLeaf\n {-#UNPACK#-}!SparkStats.SparkStats\n -- ^ the spark stats for the base duration\n | SparkTreeEmpty\n -- ^ represents a span that no data referts to, e.g., after the last GC\n deriving Show\n\nsparkTreeMaxDepth :: SparkTree -> Int\nsparkTreeMaxDepth (SparkTree _ _ t) = sparkNodeMaxDepth t\n\nsparkNodeMaxDepth :: SparkNode -> Int\nsparkNodeMaxDepth (SparkSplit _ lhs rhs _)\n = 1 + sparkNodeMaxDepth lhs `max` sparkNodeMaxDepth rhs\nsparkNodeMaxDepth _ = 1\n\nemptySparkTree :: SparkTree\nemptySparkTree = SparkTree 0 0 SparkTreeEmpty\n\n-- | Create spark tree from spark durations.\n-- Note that the last event may be not a spark event, in which case\n-- there is no data about sparks for the last time interval\n-- (the subtree for the interval will have SparkTreeEmpty node).\nmkSparkTree :: [SparkDuration] -- ^ spark durations calculated from events\n -> Timestamp -- ^ end time of last event in the list\n -> SparkTree\nmkSparkTree es endTime =\n SparkTree s e $\n -- trace (show tree) $\n tree\n where\n tree = splitSparks es endTime\n (s, e) = if null es then (0, 0) else (startT (head es), endTime)\n\n-- | Construct spark tree, by recursively splitting time intervals..\n-- We only split at spark transition duration boundaries;\n-- we never split a duration into multiple pieces.\n-- Therefore, the binary tree is only roughly split by time,\n-- the actual split depends on the distribution of sample points below it.\nsplitSparks :: [SparkDuration] -> Timestamp -> SparkNode\nsplitSparks [] !_endTime =\n SparkTreeEmpty\n\nsplitSparks [e] !_endTime =\n SparkTreeLeaf (deltaC e)\n\nsplitSparks es !endTime\n | null rhs\n = splitSparks es lhs_end\n | null lhs\n = error $\n printf \"splitSparks: null lhs: len = %d, startTime = %d, endTime = %d\\n\"\n (length es) startTime endTime\n ++ '\\n' : show es\n | otherwise\n = -- trace (printf \"len = %d, startTime = %d, endTime = %d\\n\" (length es) startTime endTime) $\n assert (length lhs + length rhs == length es) $\n SparkSplit (startT $ head rhs)\n ltree\n rtree\n (SparkStats.aggregate (subDelta rtree ++ subDelta ltree))\n where\n -- | Integer division, rounding up.\n divUp :: Timestamp -> Timestamp -> Timestamp\n divUp n k = (n + k - 1) `div` k\n startTime = startT $ head es\n splitTime = startTime + (endTime - startTime) `divUp` 2\n\n (lhs, lhs_end, rhs) = splitSparkList es [] splitTime 0\n\n ltree = splitSparks lhs lhs_end\n rtree = splitSparks rhs endTime\n\n subDelta (SparkSplit _ _ _ delta) = [delta]\n subDelta (SparkTreeLeaf delta) = [delta]\n subDelta SparkTreeEmpty = []\n\n\nsplitSparkList :: [SparkDuration]\n -> [SparkDuration]\n -> Timestamp\n -> Timestamp\n -> ([SparkDuration], Timestamp, [SparkDuration])\nsplitSparkList [] acc !_tsplit !tmax\n = (reverse acc, tmax, [])\nsplitSparkList [e] acc !_tsplit !tmax\n -- Just one event left: put it on the right. This ensures that we\n -- have at least one event on each side of the split.\n = (reverse acc, tmax, [e])\nsplitSparkList (e:es) acc !tsplit !tmax\n | startT e <= tsplit -- pick all durations that start at or before the split\n = splitSparkList es (e:acc) tsplit (max tmax (startT e))\n | otherwise\n = (reverse acc, tmax, e:es)\n\n\n-- | For each timeslice, give the spark stats calculated for that interval.\n-- The spark stats are Approximated from the aggregated data\n-- at the level of the spark tree covering intervals of the size\n-- similar to the timeslice size.\nsparkProfile :: Timestamp -> Timestamp -> Timestamp -> SparkTree\n -> [SparkStats.SparkStats]\nsparkProfile slice start0 end0 t\n = {- trace (show flat) $ -} chopped\n\n where\n -- do an extra slice at both ends\n start = if start0 < slice then start0 else start0 - slice\n end = end0 + slice\n\n flat = flatten start t []\n -- TODO: redefine chop so that it's obvious this error will not happen\n -- e.g., catch pathological cases, like a tree with only SparkTreeEmpty\n -- inside and/or make it tail-recursive instead of\n -- taking the 'previous' argument\n chopped0 = chop (error \"Fatal error in sparkProfile.\") [] start flat\n\n chopped | start0 < slice = SparkStats.initial : chopped0\n | otherwise = chopped0\n\n flatten :: Timestamp -> SparkTree -> [SparkTree] -> [SparkTree]\n flatten _start (SparkTree _s _e SparkTreeEmpty) rest = rest\n flatten start t@(SparkTree s e (SparkSplit split l r _)) rest\n | e <= start = rest\n | end <= s = rest\n | start >= split = flatten start (SparkTree split e r) rest\n | end <= split = flatten start (SparkTree s split l) rest\n | e - s > slice = flatten start (SparkTree s split l) $\n flatten start (SparkTree split e r) rest\n -- A rule of thumb: if a node is narrower than slice, don't drill down,\n -- even if the node sits astride slice boundaries and so the readings\n -- for each of the two neigbouring slices will not be accurate\n -- (but for the pair as a whole, they will be). Smooths the curve down\n -- even more than averaging over the timeslice already does.\n | otherwise = t : rest\n flatten _start t@(SparkTree _s _e (SparkTreeLeaf _)) rest\n = t : rest\n\n chop :: SparkStats.SparkStats -> [SparkStats.SparkStats]\n -> Timestamp -> [SparkTree] -> [SparkStats.SparkStats]\n chop _previous sofar start1 _ts\n | start1 >= end\n = case sofar of\n _ : _ -> [SparkStats.aggregate sofar]\n [] -> []\n chop _previous sofar _start1 [] -- data too short for the redrawn area\n | null sofar -- no data at all in the redrawn area\n = []\n | otherwise\n = [SparkStats.aggregate sofar]\n chop previous sofar start1 (t : ts)\n | e <= start1 -- skipping data left of the slice\n = case sofar of\n _ : _ -> error \"chop\"\n [] -> chop previous sofar start1 ts\n | s >= start1 + slice -- postponing data right of the slice\n = let (c, p) = SparkStats.agEx sofar previous\n in c : chop p [] (start1 + slice) (t : ts)\n | e > start1 + slice\n = let (c, p) = SparkStats.agEx (created_in_this_slice t ++ sofar) previous\n in c : chop p [] (start1 + slice) (t : ts)\n | otherwise\n = chop previous (created_in_this_slice t ++ sofar) start1 ts\n where\n (s, e) | SparkTree s e _ <- t = (s, e)\n\n -- The common part of the slice and the duration.\n mi = min (start1 + slice) e\n ma = max start1 s\n common = if mi < ma then 0 else mi - ma\n -- Instead of drilling down the tree (unless it's a leaf),\n -- we approximate by taking a proportion of the aggregate value,\n -- depending on how much of the spark duration corresponding\n -- to the tree node is covered by our timeslice.\n proportion = if e > s\n then fromIntegral common / fromIntegral (e - s)\n else assert (e == s && common == 0) $ 0\n\n -- Spark transitions in the tree are in units spark/duration.\n -- Here the numbers are rescaled so that the units are spark/ms.\n created_in_this_slice (SparkTree _ _ node) = case node of\n SparkTreeLeaf delta -> [SparkStats.rescale proportion delta]\n SparkTreeEmpty -> []\n SparkSplit _ _ _ delta -> [SparkStats.rescale proportion delta]\n" }, { "path": "Events/TestEvents.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nmodule Events.TestEvents (testTrace)\nwhere\n\nimport Data.Word\nimport GHC.RTS.Events\n\n-------------------------------------------------------------------------------\n\n\ntestTrace :: String -> EventLog\ntestTrace name = eventLog (test name)\n\n-------------------------------------------------------------------------------\n\neventLog :: [Event] -> EventLog\neventLog events =\n let eBy1000 ev = ev{evTime = evTime ev * 1000}\n eventsBy = map eBy1000 events\n in EventLog (Header testEventTypes) (Data eventsBy)\n\n-------------------------------------------------------------------------------\n\ncreate :: Word16\ncreate = 0\n\n-------------------------------------------------------------------------------\n\nrunThread :: Word16\nrunThread = 1\n\n-------------------------------------------------------------------------------\n\nstop :: Word16\nstop = 2\n\n-------------------------------------------------------------------------------\n\nrunnable :: Word16\nrunnable = 3\n\n-------------------------------------------------------------------------------\n\nmigrate :: Word16\nmigrate = 4\n\n-------------------------------------------------------------------------------\n\nrunSpark :: Word16\nrunSpark = 5\n\n-------------------------------------------------------------------------------\n\nstealSpark :: Word16\nstealSpark = 6\n\n-------------------------------------------------------------------------------\n\nshutdown :: Word16\nshutdown = 7\n\n-------------------------------------------------------------------------------\n\nwakeup :: Word16\nwakeup = 8\n\n-------------------------------------------------------------------------------\n\nstartGC :: Word16\nstartGC = 9\n\n------------------------------------------------------------------------------\n\nfinishGC :: Word16\nfinishGC = 10\n\n------------------------------------------------------------------------------\n\nreqSeqGC :: Word16\nreqSeqGC = 11\n\n------------------------------------------------------------------------------\n\nreqParGC :: Word16\nreqParGC = 12\n\n------------------------------------------------------------------------------\n\ncreateSparkThread :: Word16\ncreateSparkThread = 15\n\n------------------------------------------------------------------------------\n\nlogMessage :: Word16\nlogMessage = 16\n\n------------------------------------------------------------------------------\n\nstartup :: Word16\nstartup = 17\n\n------------------------------------------------------------------------------\n\nblockMarker :: Word16\nblockMarker = 18\n\n------------------------------------------------------------------------------\n\ntestEventTypes :: [EventType]\ntestEventTypes\n = [EventType create \"Create thread\" (Just 8),\n EventType runThread \"Run thread\" (Just 8),\n EventType stop \"Stop thread\" (Just 10),\n EventType runnable \"Thread runnable\" (Just 8),\n EventType migrate \"Migrate thread\" (Just 10),\n EventType runSpark \"Run spark\" (Just 8),\n EventType stealSpark \"Steal spark\" (Just 10),\n EventType shutdown \"Shutdown\" (Just 0),\n EventType wakeup \"Wakeup thread\" (Just 10),\n EventType startGC \"Start GC\" (Just 0),\n EventType finishGC \"Finish GC\" (Just 0),\n EventType reqSeqGC \"Request sequential GC\" (Just 0),\n EventType reqParGC \"Reqpargc parallel GC\" (Just 0),\n EventType createSparkThread \"Create spark thread\" (Just 8),\n EventType logMessage \"Log message\" Nothing,\n EventType startup \"Startup\" (Just 0),\n EventType blockMarker \"Block marker\" (Just 14)\n ]\n\n-------------------------------------------------------------------------------\ntest :: String -> [Event]\n-------------------------------------------------------------------------------\n\ntest \"empty0\"\n = [\n Event 0 (Startup 1) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n\n\ntest \"empty1\"\n = [\n Event 0 (Startup 1) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n\ntest \"test0\"\n = [\n Event 0 (Startup 1) (Just 0),\n Event 4000000 Shutdown (Just 0)\n ]\n-------------------------------------------------------------------------------\n\ntest \"small\"\n = [\n Event 0 (Startup 1) (Just 0),\n Event 1000000 (CreateThread 1) (Just 0),\n Event 2000000 (RunThread 1) (Just 0),\n Event 3000000 (StopThread 1 ThreadFinished) (Just 0),\n Event 4000000 (Shutdown) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n\ntest \"tick\"\n = [-- A thread from 2s to 3s\n Event 0 (Startup 3) (Just 0),\n Event 1000000000 (CreateThread 1) (Just 0),\n Event 2000000000 (RunThread 1) (Just 0),\n Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),\n Event 4000000000 (Shutdown) (Just 0),\n -- A thread from 0.2ms to 0.3ms\n Event 1000000 (CreateThread 2) (Just 1),\n Event 2000000 (RunThread 2) (Just 1),\n Event 3000000 (StopThread 2 ThreadFinished) (Just 1),\n Event 4000000 (Shutdown) (Just 1),\n -- A thread from 0.2us to 0.3us\n Event 1000 (CreateThread 3) (Just 2),\n Event 2000 (RunThread 3) (Just 2),\n Event 3000 (StopThread 3 ThreadFinished) (Just 2),\n Event 4000 (Shutdown) (Just 2)\n ]\n\n-------------------------------------------------------------------------------\n\ntest \"tick2\"\n = [-- A thread create but no run\n Event 0 (Startup 1) (Just 0),\n Event 1000000000 (CreateThread 1) (Just 0),\n Event 4000000000 (Shutdown) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n\ntest \"tick3\"\n = [-- A thread from 2s to 3s\n Event 0 (Startup 1) (Just 0),\n Event 1000000000 (CreateThread 1) (Just 0),\n Event 2000000000 (RunThread 1) (Just 0),\n Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),\n Event 4000000000 (Shutdown) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n\ntest \"tick4\"\n = [-- A test for scale values close to 1.0\n Event 0 (Startup 1) (Just 0),\n Event 100 (CreateThread 1) (Just 0),\n Event 200 (RunThread 1) (Just 0),\n Event 300 (StopThread 1 ThreadFinished) (Just 0),\n Event 400 (Shutdown) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n\ntest \"tick5\"\n = [-- A thread from 2s to 3s\n Event 0 (Startup 1) (Just 0),\n Event 1000000000 (CreateThread 1) (Just 0),\n Event 2000000000 (RunThread 1) (Just 0),\n Event 3000000000 (StopThread 1 ThreadFinished) (Just 0),\n Event 4000000000 (Shutdown) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n-- A long tick run to check small and large tick labels\n\ntest \"tick6\" = chequered 2 100 10000000\n\n-------------------------------------------------------------------------------\n\ntest \"overlap\"\n = [-- A thread from 2s to 3s\n Event 0 (Startup 1) (Just 0),\n Event 1000 (CreateThread 1) (Just 0),\n Event 1100 (RunThread 1) (Just 0),\n Event 1200 (CreateThread 2) (Just 0),\n Event 1300 (StopThread 1 ThreadFinished) (Just 0),\n\n Event 1400 (RunThread 2) (Just 0),\n Event 1500 (CreateThread 3) (Just 0),\n Event 1500 (CreateThread 4) (Just 0),\n Event 1500 (StopThread 2 ThreadFinished) (Just 0),\n\n Event 1600 (RunThread 3) (Just 0),\n Event 1600 (CreateThread 5) (Just 0),\n Event 1600 (StopThread 3 ThreadFinished) (Just 0),\n\n Event 1700 (RunThread 4) (Just 0),\n Event 1700 (CreateThread 6) (Just 0),\n Event 1800 (StopThread 4 ThreadFinished) (Just 0),\n\n Event 3000 (Shutdown) (Just 0)\n ]\n\n-------------------------------------------------------------------------------\n-- These tests are for chequered patterns to help check for rendering\n-- problems and also to help test the performance of scrolling etc.\n-- Each line has a fixed frequency of a thread running and then performing GC.\n-- Each successive HEC runs thread at half the frequency of the previous HEC.\n\ntest \"ch1\" = chequered 1 100 100000\ntest \"ch2\" = chequered 2 100 100000\ntest \"ch3\" = chequered 3 100 100000\ntest \"ch4\" = chequered 4 100 100000\ntest \"ch5\" = chequered 5 100 100000\ntest \"ch6\" = chequered 6 100 100000\ntest \"ch7\" = chequered 7 100 100000\ntest \"ch8\" = chequered 8 100 100000\n\n\n-------------------------------------------------------------------------------\n\ntest _ = []\n\n-------------------------------------------------------------------------------\n\nchequered :: ThreadId -> Timestamp -> Timestamp -> [Event]\nchequered numThreads basicDuration runLength\n = Event 0 (Startup (fromIntegral numThreads)) (Just 0) :\n makeChequered 1 numThreads basicDuration runLength\n\n-------------------------------------------------------------------------------\n\nmakeChequered :: ThreadId -> ThreadId -> Timestamp -> Timestamp -> [Event]\nmakeChequered currentThread numThreads _basicDuration _runLength\n | currentThread > numThreads = [] -- All threads rendered\nmakeChequered currentThread numThreads basicDuration runLength\n = eventBlock ++\n makeChequered (currentThread+1) numThreads (2*basicDuration) runLength\n where\n eventBlock = Event 0 (CreateThread currentThread) (Just $ fromIntegral $ currentThread - 1)\n : chequeredPattern currentThread 0 basicDuration runLength\n\n-------------------------------------------------------------------------------\n\nchequeredPattern :: ThreadId -> Timestamp -> Timestamp -> Timestamp -> [Event]\nchequeredPattern currentThread currentPos basicDuration runLength\n = if currentPos + 2*basicDuration > runLength then\n [Event runLength Shutdown mcap]\n else\n [Event currentPos (RunThread currentThread) mcap,\n Event (currentPos+basicDuration) (StopThread currentThread ThreadYielding) mcap,\n Event (currentPos+basicDuration) StartGC mcap,\n Event (currentPos+2*basicDuration) EndGC mcap\n ] ++ chequeredPattern currentThread (currentPos+2*basicDuration) basicDuration runLength\n where mcap = Just $ fromIntegral $ currentThread - 1\n\n-------------------------------------------------------------------------------\n" }, { "path": "GUI/App.hs", "content": "-------------------------------------------------------------------------------\n-- | Module : GUI.App\n--\n-- Platform-specific application functionality\n-------------------------------------------------------------------------------\n\nmodule GUI.App (initApp) where\n\n-------------------------------------------------------------------------------\n\n-- | Initialize application\n-- Perform application initialization for non-macOS platforms\ninitApp :: IO ()\ninitApp = return ()\n" }, { "path": "GUI/BookmarkView.hs", "content": "module GUI.BookmarkView (\n BookmarkView,\n bookmarkViewNew,\n BookmarkViewActions(..),\n\n bookmarkViewGet,\n bookmarkViewAdd,\n bookmarkViewRemove,\n bookmarkViewClear,\n bookmarkViewSetLabel,\n ) where\n\nimport GHC.RTS.Events (Timestamp)\n\nimport Graphics.UI.Gtk\nimport qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat\nimport Numeric\nimport Data.Text (Text)\n\n---------------------------------------------------------------------------\n\n-- | Abstract bookmark view object.\n--\ndata BookmarkView = BookmarkView {\n bookmarkStore :: ListStore (Timestamp, Text)\n }\n\n-- | The actions to take in response to TraceView events.\n--\ndata BookmarkViewActions = BookmarkViewActions {\n bookmarkViewAddBookmark :: IO (),\n bookmarkViewRemoveBookmark :: Int -> IO (),\n bookmarkViewGotoBookmark :: Timestamp -> IO (),\n bookmarkViewEditLabel :: Int -> Text -> IO ()\n }\n\n---------------------------------------------------------------------------\n\nbookmarkViewAdd :: BookmarkView -> Timestamp -> Text -> IO ()\nbookmarkViewAdd BookmarkView{bookmarkStore} ts label = do\n listStoreAppend bookmarkStore (ts, label)\n return ()\n\nbookmarkViewRemove :: BookmarkView -> Int -> IO ()\nbookmarkViewRemove BookmarkView{bookmarkStore} n = do\n listStoreRemove bookmarkStore n\n return ()\n\nbookmarkViewClear :: BookmarkView -> IO ()\nbookmarkViewClear BookmarkView{bookmarkStore} =\n listStoreClear bookmarkStore\n\nbookmarkViewGet :: BookmarkView -> IO [(Timestamp, Text)]\nbookmarkViewGet BookmarkView{bookmarkStore} =\n listStoreToList bookmarkStore\n\nbookmarkViewSetLabel :: BookmarkView -> Int -> Text -> IO ()\nbookmarkViewSetLabel BookmarkView{bookmarkStore} n label = do\n (ts,_) <- listStoreGetValue bookmarkStore n\n listStoreSetValue bookmarkStore n (ts, label)\n\n---------------------------------------------------------------------------\n\nbookmarkViewNew :: Builder -> BookmarkViewActions -> IO BookmarkView\nbookmarkViewNew builder BookmarkViewActions{..} = do\n\n let getWidget cast name = builderGetObject builder cast name\n\n ---------------------------------------------------------------------------\n\n bookmarkTreeView <- getWidget castToTreeView \"bookmark_list\"\n bookmarkStore <- listStoreNew []\n columnTs <- treeViewColumnNew\n cellTs <- cellRendererTextNew\n columnLabel <- treeViewColumnNew\n cellLabel <- cellRendererTextNew\n selection <- treeViewGetSelection bookmarkTreeView\n\n treeViewColumnSetTitle columnTs \"Time\"\n treeViewColumnSetTitle columnLabel \"Label\"\n treeViewColumnPackStart columnTs cellTs False\n treeViewColumnPackStart columnLabel cellLabel True\n treeViewAppendColumn bookmarkTreeView columnTs\n treeViewAppendColumn bookmarkTreeView columnLabel\n\n Compat.treeViewSetModel bookmarkTreeView (Just bookmarkStore)\n\n cellLayoutSetAttributes columnTs cellTs bookmarkStore $ \\(ts,_) ->\n [ cellText := showFFloat (Just 6) (fromIntegral ts / 1000000) \"s\" ]\n\n cellLayoutSetAttributes columnLabel cellLabel bookmarkStore $ \\(_,label) ->\n [ cellText := label ]\n\n ---------------------------------------------------------------------------\n\n addBookmarkButton <- getWidget castToToolButton \"add_bookmark_button\"\n deleteBookmarkButton <- getWidget castToToolButton \"delete_bookmark\"\n gotoBookmarkButton <- getWidget castToToolButton \"goto_bookmark_button\"\n\n onToolButtonClicked addBookmarkButton $\n bookmarkViewAddBookmark\n\n onToolButtonClicked deleteBookmarkButton $ do\n selected <- treeSelectionGetSelected selection\n case selected of\n Nothing -> return ()\n Just iter ->\n let pos = listStoreIterToIndex iter\n in bookmarkViewRemoveBookmark pos\n\n onToolButtonClicked gotoBookmarkButton $ do\n selected <- treeSelectionGetSelected selection\n case selected of\n Nothing -> return ()\n Just iter -> do\n let pos = listStoreIterToIndex iter\n (ts,_) <- listStoreGetValue bookmarkStore pos\n bookmarkViewGotoBookmark ts\n\n bookmarkTreeView `on` rowActivated $ \\[pos] _ -> do\n (ts, _) <- listStoreGetValue bookmarkStore pos\n bookmarkViewGotoBookmark ts\n\n set cellLabel [ cellTextEditable := True ]\n on cellLabel edited $ \\[pos] val -> do\n bookmarkViewEditLabel pos val\n\n ---------------------------------------------------------------------------\n\n return BookmarkView{..}\n" }, { "path": "GUI/ConcurrencyControl.hs", "content": "\nmodule GUI.ConcurrencyControl (\n ConcurrencyControl,\n start,\n fullSpeed,\n ) where\n\nimport qualified System.Glib.MainLoop as Glib\nimport qualified Control.Concurrent as Concurrent\nimport qualified Control.Exception as Exception\nimport Control.Concurrent.MVar\n\n\nnewtype ConcurrencyControl = ConcurrencyControl (MVar (Int, Glib.HandlerId))\n\n-- | Setup cooperative thread scheduling with Gtk+.\n--\nstart :: IO ConcurrencyControl\nstart = do\n handlerId <- normalScheduling\n return . ConcurrencyControl =<< newMVar (0, handlerId)\n\n-- | Run an expensive action that needs to use all the available CPU power.\n--\n-- The normal cooperative GUI thread scheduling does not work so well in this\n-- case so we use an alternative technique. We can't use this one all the time\n-- however or we'd hog the CPU even when idle.\n--\nfullSpeed :: ConcurrencyControl -> IO a -> IO a\nfullSpeed (ConcurrencyControl handlerRef) =\n Exception.bracket_ begin end\n where\n -- remove the normal scheduling handler and put in the full speed one\n begin = do\n (count, handlerId) <- takeMVar handlerRef\n if count == 0\n -- nobody else is running fullSpeed\n then do Glib.timeoutRemove handlerId\n handlerId' <- fullSpeedScheduling\n putMVar handlerRef (1, handlerId')\n -- we're already running fullSpeed, just inc the count\n else do putMVar handlerRef (count+1, handlerId)\n\n -- reinstate the normal scheduling\n end = do\n (count, handlerId) <- takeMVar handlerRef\n if count == 1\n -- just us running fullSpeed so we clean up\n then do Glib.timeoutRemove handlerId\n handlerId' <- normalScheduling\n putMVar handlerRef (0, handlerId')\n -- someone else running fullSpeed, they're responsible for stopping\n else do putMVar handlerRef (count-1, handlerId)\n\nnormalScheduling :: IO Glib.HandlerId\nnormalScheduling =\n Glib.timeoutAddFull\n (Concurrent.yield >> return True)\n Glib.priorityDefaultIdle 50\n --50ms, ie 20 times a second.\n\nfullSpeedScheduling :: IO Glib.HandlerId\nfullSpeedScheduling =\n Glib.idleAdd\n (Concurrent.yield >> return True)\n Glib.priorityDefaultIdle\n" }, { "path": "GUI/DataFiles.hs", "content": "{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TemplateHaskell #-}\nmodule GUI.DataFiles\n ( ui\n , loadLogo\n ) where\nimport Control.Exception (IOException, Handler(..), catches)\nimport System.IO\n\nimport Data.FileEmbed\nimport Graphics.UI.Gtk (Pixbuf, pixbufNewFromFile)\nimport Language.Haskell.TH\nimport System.Glib (GError)\nimport System.IO.Temp\nimport qualified Data.ByteString as B\nimport qualified Data.Text.Encoding as TE\n\nuiFile :: FilePath\nuiFile = \"threadscope.ui\"\n\nlogoFile :: FilePath\nlogoFile = \"threadscope.png\"\n\n-- | Textual representation of the UI file\nui :: Q Exp\nui = [| TE.decodeUtf8 $(makeRelativeToProject uiFile >>= embedFile) |]\n\nrenderLogo :: B.ByteString -> IO (Maybe Pixbuf)\nrenderLogo bytes =\n withSystemTempFile logoFile $ \\path h -> do\n B.hPut h bytes\n hClose h\n Just <$> pixbufNewFromFile path\n `catches`\n -- in case of a failure in the file IO or pixbufNewFromFile, return Nothing\n [ Handler $ \\(_ :: IOException) -> return Nothing\n , Handler $ \\(_ :: GError) -> return Nothing\n ]\n\n-- | Load the logo file as a 'Pixbuf'.\nloadLogo :: Q Exp\nloadLogo = [| renderLogo $(makeRelativeToProject logoFile >>= embedFile) |]\n" }, { "path": "GUI/Dialogs.hs", "content": "{-# LANGUAGE TemplateHaskell #-}\nmodule GUI.Dialogs where\n\nimport GUI.DataFiles (loadLogo)\nimport Paths_threadscope (version)\n\nimport Graphics.UI.Gtk\n\nimport Data.Version (showVersion)\nimport System.FilePath\nimport Control.Monad.Trans\n\n\n-------------------------------------------------------------------------------\n\naboutDialog :: WindowClass window => window -> IO ()\naboutDialog parent\n = do dialog <- aboutDialogNew\n logo <- $loadLogo\n set dialog [\n aboutDialogName := \"ThreadScope\",\n aboutDialogVersion := showVersion version,\n aboutDialogCopyright := \"Released under the GHC license as part of the Glasgow Haskell Compiler.\",\n aboutDialogComments := \"A GHC eventlog profile viewer\",\n aboutDialogAuthors := [\"Donnie Jones \",\n \"Simon Marlow \",\n \"Satnam Singh \",\n \"Duncan Coutts \",\n \"Mikolaj Konarski \",\n \"Nicolas Wu \",\n \"Eric Kow \"],\n aboutDialogLogo := logo,\n aboutDialogWebsite := \"http://www.haskell.org/haskellwiki/ThreadScope\",\n windowTransientFor := toWindow parent\n ]\n dialog `on` response $ \\_ -> widgetDestroy dialog\n widgetShow dialog\n\n-------------------------------------------------------------------------------\n\nopenFileDialog :: WindowClass window => window -> (FilePath -> IO ()) -> IO ()\nopenFileDialog parent open\n = do dialog <- fileChooserDialogNew\n (Just \"Open Profile...\")\n (Just (toWindow parent))\n FileChooserActionOpen\n [(\"gtk-cancel\", ResponseCancel)\n ,(\"gtk-open\", ResponseAccept)]\n set dialog [\n windowModal := True\n ]\n\n eventlogfiles <- fileFilterNew\n fileFilterSetName eventlogfiles \"GHC eventlog files (*.eventlog)\"\n fileFilterAddPattern eventlogfiles \"*.eventlog\"\n fileChooserAddFilter dialog eventlogfiles\n\n allfiles <- fileFilterNew\n fileFilterSetName allfiles \"All files\"\n fileFilterAddPattern allfiles \"*\"\n fileChooserAddFilter dialog allfiles\n\n dialog `on` response $ \\response -> do\n case response of\n ResponseAccept -> do\n mfile <- fileChooserGetFilename dialog\n case mfile of\n Just file -> open file\n Nothing -> return ()\n _ -> return ()\n widgetDestroy dialog\n\n widgetShowAll dialog\n\n-------------------------------------------------------------------------------\n\ndata FileExportFormat = FormatPDF | FormatPNG\n\nexportFileDialog :: WindowClass window => window\n -> FilePath\n -> (FilePath -> FileExportFormat -> IO ())\n -> IO ()\nexportFileDialog parent oldfile save = do\n dialog <- fileChooserDialogNew\n (Just \"Save timeline image...\")\n (Just (toWindow parent))\n FileChooserActionSave\n [(\"gtk-cancel\", ResponseCancel)\n ,(\"gtk-save\", ResponseAccept)]\n set dialog [\n fileChooserDoOverwriteConfirmation := True,\n windowModal := True\n ]\n\n let (olddir, oldfilename) = splitFileName oldfile\n fileChooserSetCurrentName dialog (replaceExtension oldfilename \"png\")\n fileChooserSetCurrentFolder dialog olddir\n\n pngFiles <- fileFilterNew\n fileFilterSetName pngFiles \"PNG bitmap files\"\n fileFilterAddPattern pngFiles \"*.png\"\n fileChooserAddFilter dialog pngFiles\n\n pdfFiles <- fileFilterNew\n fileFilterSetName pdfFiles \"PDF files\"\n fileFilterAddPattern pdfFiles \"*.pdf\"\n fileChooserAddFilter dialog pdfFiles\n\n dialog `on` response $ \\response ->\n case response of\n ResponseAccept -> do\n mfile <- fileChooserGetFilename dialog\n case mfile of\n Just file\n | takeExtension file == \".pdf\" -> do\n save file FormatPDF\n widgetDestroy dialog\n | takeExtension file == \".png\" -> do\n save file FormatPNG\n widgetDestroy dialog\n | otherwise ->\n formatError dialog\n Nothing -> widgetDestroy dialog\n _ -> widgetDestroy dialog\n\n widgetShowAll dialog\n where\n formatError dialog = do\n msg <- messageDialogNew (Just (toWindow dialog))\n [DialogModal, DialogDestroyWithParent]\n MessageError ButtonsClose\n \"The file format is unknown or unsupported\"\n set msg [\n messageDialogSecondaryText := Just $\n \"The PNG and PDF formats are supported. \"\n ++ \"Please use a file extension of '.png' or '.pdf'.\"\n ]\n dialogRun msg\n widgetDestroy msg\n\n\n\n-------------------------------------------------------------------------------\n\nerrorMessageDialog :: WindowClass window => window -> String -> String -> IO ()\nerrorMessageDialog parent headline explanation = do\n\n dialog <- messageDialogNew (Just (toWindow parent))\n [] MessageError ButtonsNone \"\"\n\n set dialog\n [ windowModal := True\n , windowTransientFor := toWindow parent\n , messageDialogText := Just headline\n , messageDialogSecondaryText := Just explanation\n , windowResizable := True\n ]\n\n dialogAddButton dialog \"Close\" ResponseClose\n dialogSetDefaultResponse dialog ResponseClose\n\n dialog `on` response $ \\_-> widgetDestroy dialog\n widgetShowAll dialog\n" }, { "path": "GUI/EventsView.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule GUI.EventsView (\n EventsView,\n eventsViewNew,\n EventsViewActions(..),\n\n eventsViewSetEvents,\n\n eventsViewGetCursor,\n eventsViewSetCursor,\n eventsViewScrollToLine,\n ) where\n\nimport GHC.RTS.Events\n\nimport Graphics.UI.Gtk hiding (rectangle)\nimport Graphics.Rendering.Cairo\nimport GUI.ViewerColours\n\nimport Control.Monad\nimport Data.Array\nimport Data.Monoid\nimport Data.IORef\nimport qualified Data.Text as T\nimport qualified Data.Text.Lazy as TL\nimport qualified Data.Text.Lazy.Builder as TB\nimport qualified Data.Text.Lazy.Builder.Int as TB (decimal)\nimport Numeric\nimport Prelude\n\n-------------------------------------------------------------------------------\n\ndata EventsView = EventsView {\n drawArea :: !Widget,\n adj :: !Adjustment,\n stateRef :: !(IORef ViewState)\n }\n\ndata EventsViewActions = EventsViewActions {\n eventsViewCursorChanged :: Int -> IO ()\n }\n\ndata ViewState = ViewState {\n lineHeight :: !Double,\n eventsState :: !EventsState\n }\n\ndata EventsState\n = EventsEmpty\n | EventsLoaded {\n cursorPos :: !Int,\n mrange :: !(Maybe (Int, Int)),\n eventsArr :: Array Int Event\n }\n\n-------------------------------------------------------------------------------\n\neventsViewNew :: Builder -> EventsViewActions -> IO EventsView\neventsViewNew builder EventsViewActions{..} = do\n\n stateRef <- newIORef undefined\n\n let getWidget cast = builderGetObject builder cast\n drawArea <- getWidget castToWidget (\"eventsDrawingArea\" :: T.Text)\n vScrollbar <- getWidget castToVScrollbar (\"eventsVScroll\" :: T.Text)\n adj <- get vScrollbar rangeAdjustment\n\n widgetSetCanFocus drawArea True\n --TODO: needs to be reset on each style change ^^\n\n -----------------------------------------------------------------------------\n -- Line height\n\n -- Calculate the height of each line based on the current font\n let getLineHeight = do\n pangoCtx <- widgetGetPangoContext drawArea\n fontDesc <- contextGetFontDescription pangoCtx\n metrics <- contextGetMetrics pangoCtx fontDesc emptyLanguage\n return $ ascent metrics + descent metrics --TODO: padding?\n\n -- We cache the height of each line\n initialLineHeight <- getLineHeight\n -- but have to update it when the font changes\n on drawArea styleSet $ \\_ -> do\n lineHeight' <- getLineHeight\n modifyIORef stateRef $ \\viewstate -> viewstate { lineHeight = lineHeight' }\n\n -----------------------------------------------------------------------------\n\n writeIORef stateRef ViewState {\n lineHeight = initialLineHeight,\n eventsState = EventsEmpty\n }\n\n let eventsView = EventsView {..}\n\n -----------------------------------------------------------------------------\n -- Drawing\n\n on drawArea draw $ liftIO $ do\n drawEvents eventsView =<< readIORef stateRef\n return ()\n\n -----------------------------------------------------------------------------\n -- Key navigation\n\n on drawArea keyPressEvent $ do\n let scroll by = liftIO $ do\n ViewState{eventsState, lineHeight} <- readIORef stateRef\n pagesize <- get adj adjustmentPageSize\n let pagejump = max 1 (truncate (pagesize / lineHeight) - 1)\n case eventsState of\n EventsEmpty -> return ()\n EventsLoaded{cursorPos, eventsArr} ->\n eventsViewCursorChanged cursorPos'\n where\n cursorPos' = clampBounds range (by pagejump end cursorPos)\n range@(_,end) = bounds eventsArr\n return True\n\n key <- eventKeyName\n#if MIN_VERSION_gtk3(0,13,0)\n case T.unpack key of\n#else\n case key of\n#endif\n \"Up\" -> scroll (\\_page _end pos -> pos-1)\n \"Down\" -> scroll (\\_page _end pos -> pos+1)\n \"Page_Up\" -> scroll (\\ page _end pos -> pos-page)\n \"Page_Down\" -> scroll (\\ page _end pos -> pos+page)\n \"Home\" -> scroll (\\_page _end _pos -> 0)\n \"End\" -> scroll (\\_page end _pos -> end)\n \"Left\" -> return True\n \"Right\" -> return True\n _ -> return False\n\n -----------------------------------------------------------------------------\n -- Scrolling\n\n set adj [ adjustmentLower := 0 ]\n\n on drawArea sizeAllocate $ \\_ ->\n updateScrollAdjustment eventsView =<< readIORef stateRef\n\n let hitpointToLine :: ViewState -> Double -> Double -> Maybe Int\n hitpointToLine ViewState{eventsState = EventsEmpty} _ _ = Nothing\n hitpointToLine ViewState{eventsState = EventsLoaded{eventsArr}, lineHeight}\n yOffset eventY\n | hitLine > maxIndex = Nothing\n | otherwise = Just hitLine\n where\n hitLine = truncate ((yOffset + eventY) / lineHeight)\n maxIndex = snd (bounds eventsArr)\n\n on drawArea buttonPressEvent $ tryEvent $ do\n (_,y) <- eventCoordinates\n liftIO $ do\n viewState <- readIORef stateRef\n yOffset <- get adj adjustmentValue\n widgetGrabFocus drawArea\n case hitpointToLine viewState yOffset y of\n Nothing -> return ()\n Just n -> eventsViewCursorChanged n\n\n on drawArea scrollEvent $ do\n dir <- eventScrollDirection\n liftIO $ do\n val <- get adj adjustmentValue\n upper <- get adj adjustmentUpper\n pagesize <- get adj adjustmentPageSize\n step <- get adj adjustmentStepIncrement\n case dir of\n ScrollUp -> set adj [ adjustmentValue := val - step ]\n ScrollDown -> set adj [ adjustmentValue := min (val + step)\n (upper - pagesize) ]\n _ -> return ()\n return True\n\n onValueChanged adj $\n widgetQueueDraw drawArea\n\n -----------------------------------------------------------------------------\n\n return eventsView\n\n-------------------------------------------------------------------------------\n\neventsViewSetEvents :: EventsView -> Maybe (Array Int Event) -> IO ()\neventsViewSetEvents eventWin@EventsView{drawArea, stateRef} mevents = do\n viewState <- readIORef stateRef\n let eventsState' = case mevents of\n Nothing -> EventsEmpty\n Just events -> EventsLoaded {\n cursorPos = 0,\n mrange = Nothing,\n eventsArr = events\n }\n viewState' = viewState { eventsState = eventsState' }\n writeIORef stateRef viewState'\n updateScrollAdjustment eventWin viewState'\n widgetQueueDraw drawArea\n\n-------------------------------------------------------------------------------\n\neventsViewGetCursor :: EventsView -> IO (Maybe Int)\neventsViewGetCursor EventsView{stateRef} = do\n ViewState{eventsState} <- readIORef stateRef\n case eventsState of\n EventsEmpty -> return Nothing\n EventsLoaded{cursorPos} -> return (Just cursorPos)\n\neventsViewSetCursor :: EventsView -> Int -> Maybe (Int, Int) -> IO ()\neventsViewSetCursor eventsView@EventsView{drawArea, stateRef} n mrange = do\n viewState@ViewState{eventsState} <- readIORef stateRef\n case eventsState of\n EventsEmpty -> return ()\n EventsLoaded{eventsArr} -> do\n let n' = clampBounds (bounds eventsArr) n\n writeIORef stateRef viewState {\n eventsState = eventsState { cursorPos = n', mrange }\n }\n eventsViewScrollToLine eventsView n'\n widgetQueueDraw drawArea\n\neventsViewScrollToLine :: EventsView -> Int -> IO ()\neventsViewScrollToLine EventsView{adj, stateRef} n = do\n ViewState{lineHeight} <- readIORef stateRef\n -- make sure that the range [n..n+1] is within the current page:\n adjustmentClampPage adj\n (fromIntegral n * lineHeight)\n (fromIntegral (n+1) * lineHeight)\n\n-------------------------------------------------------------------------------\n\nupdateScrollAdjustment :: EventsView -> ViewState -> IO ()\nupdateScrollAdjustment EventsView{drawArea, adj}\n ViewState{lineHeight, eventsState} = do\n\n Rectangle _ _ _ windowHeight <- widgetGetAllocation drawArea\n let numLines = case eventsState of\n EventsEmpty -> 0\n EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1\n linesHeight = fromIntegral numLines * lineHeight\n upper = max linesHeight (fromIntegral windowHeight)\n pagesize = fromIntegral windowHeight\n\n set adj [\n adjustmentUpper := upper,\n adjustmentPageSize := pagesize,\n adjustmentStepIncrement := pagesize * 0.2,\n adjustmentPageIncrement := pagesize * 0.9\n ]\n val <- get adj adjustmentValue\n when (val > upper - pagesize) $\n set adj [ adjustmentValue := max 0 (upper - pagesize) ]\n\n-------------------------------------------------------------------------------\n\ndrawEvents :: EventsView -> ViewState -> IO ()\ndrawEvents _ ViewState {eventsState = EventsEmpty} = return ()\ndrawEvents EventsView{drawArea, adj}\n ViewState {lineHeight, eventsState = EventsLoaded{..}} = do\n\n yOffset <- get adj adjustmentValue\n pageSize <- get adj adjustmentPageSize\n\n -- calculate which lines are visible\n let lower = truncate (yOffset / lineHeight)\n upper = ceiling ((yOffset + pageSize) / lineHeight)\n\n -- the array indexes [begin..end] inclusive\n -- are partially or fully visible\n begin = lower\n end = min upper (snd (bounds eventsArr))\n\n -- TODO: don't use Just here\n Just win <- widgetGetWindow drawArea\n style <- widgetGetStyle drawArea\n focused <- widgetGetIsFocus drawArea\n let state | focused = StateSelected\n | otherwise = StateActive\n\n pangoCtx <- widgetGetPangoContext drawArea\n layout <- layoutEmpty pangoCtx\n layoutSetEllipsize layout EllipsizeEnd\n\n\n (Rectangle _ _ width _) <- widgetGetAllocation drawArea\n let clipRect = Rectangle 0 0 0 0\n\n let -- With average char width, timeWidth is enough for 24 hours of logs\n -- (way more than TS can handle, currently). Aligns nicely with\n -- current timeline_yscale_area width, too.\n -- TODO: take timeWidth from the yScaleDrawingArea width\n -- TODO: perhaps make the timeWidth area grey, too?\n -- 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)?\n timeWidth = 105\n columnGap = 20\n descrWidth = width - timeWidth - columnGap\n\n sequence_\n [ do when (inside || selected) $\n renderWithDrawWindow win $ do\n setSourceRGBAForStyle styleGetBackground style state1\n rectangle 0 y (fromIntegral width) lineHeight\n fill\n\n -- The event time\n layoutSetText layout (showEventTime event)\n layoutSetAlignment layout AlignRight\n layoutSetWidth layout (Just (fromIntegral timeWidth))\n renderWithDrawWindow win $ do\n setForegroundColor style state2\n moveTo 0 y\n showLayout layout\n\n -- The event description text\n layoutSetText layout (showEventDescr event)\n layoutSetAlignment layout AlignLeft\n layoutSetWidth layout (Just (fromIntegral descrWidth))\n renderWithDrawWindow win $ do\n setForegroundColor style state2\n moveTo (fromIntegral $ timeWidth + columnGap) y\n showLayout layout\n\n | n <- [begin..end]\n , let y = fromIntegral n * lineHeight - yOffset\n event = eventsArr ! n\n inside = maybe False (\\ (s, e) -> s <= n && n <= e) mrange\n selected = cursorPos == n\n (state1, state2)\n | inside = (StateSelected, StateSelected)\n | selected = (StateSelected, state)\n | otherwise = (state, StateNormal)\n ]\n\n where\n showEventTime (Event time _spec _) =\n showFFloat (Just 6) (fromIntegral time / 1000000) \"s\"\n showEventDescr :: Event -> T.Text\n showEventDescr (Event _time spec cap) = TL.toStrict $ TB.toLazyText $\n maybe \"\" (\\c -> \"HEC \" <> TB.decimal c <> \": \") cap\n <> case spec of\n UnknownEvent{ref} -> \"unknown event; \" <> TB.decimal ref\n Message msg -> TB.fromText msg\n UserMessage msg -> TB.fromText msg\n _ -> buildEventInfo spec\n setForegroundColor = setSourceRGBAForStyle styleGetForeground\n\n-------------------------------------------------------------------------------\n\nclampBounds :: Ord a => (a, a) -> a -> a\nclampBounds (lower, upper) x\n | x <= lower = lower\n | x > upper = upper\n | otherwise = x\n" }, { "path": "GUI/GtkExtras.hs", "content": "{-# LANGUAGE ForeignFunctionInterface, CPP #-}\nmodule GUI.GtkExtras where\n\n-- This is all stuff that should be bound in the gtk package but is not yet\n-- (as of gtk-0.12.0)\n\nimport Graphics.UI.GtkInternals\nimport Graphics.UI.Gtk (Rectangle)\nimport System.Glib.MainLoop\nimport Graphics.Rendering.Pango.Types\nimport Graphics.Rendering.Pango.BasicTypes\nimport Graphics.UI.Gtk.General.Enums (StateType, ShadowType)\n\nimport Foreign\nimport Foreign.C\nimport Control.Concurrent.MVar\n\n#if mingw32_HOST_OS || mingw32_TARGET_OS\n#include \"windows_cconv.h\"\n#else\nimport System.Glib.GError\nimport Control.Monad\n#endif\n\nwaitGUI :: IO ()\nwaitGUI = do\n resultVar <- newEmptyMVar\n idleAdd (putMVar resultVar () >> return False) priorityDefaultIdle\n takeMVar resultVar\n\n-------------------------------------------------------------------------------\n\nlaunchProgramForURI :: String -> IO Bool\n#if mingw32_HOST_OS || mingw32_TARGET_OS\nlaunchProgramForURI uri = do\n withCString \"open\" $ \\verbPtr ->\n withCString uri $ \\filePtr ->\n c_ShellExecuteA\n nullPtr\n verbPtr\n filePtr\n nullPtr\n nullPtr\n 1 -- SW_SHOWNORMAL\n return True\n\nforeign import WINDOWS_CCONV unsafe \"shlobj.h ShellExecuteA\"\n c_ShellExecuteA :: Ptr () -- HWND hwnd\n -> CString -- LPCTSTR lpOperation\n -> CString -- LPCTSTR lpFile\n -> CString -- LPCTSTR lpParameters\n -> CString -- LPCTSTR lpDirectory\n -> CInt -- INT nShowCmd\n -> IO CInt -- HINSTANCE return\n\n#else\nlaunchProgramForURI uri =\n propagateGError $ \\errPtrPtr ->\n withCString uri $ \\uriStrPtr -> do\n timestamp <- gtk_get_current_event_time\n liftM toBool $ gtk_show_uri nullPtr uriStrPtr timestamp errPtrPtr\n#endif\n\n-------------------------------------------------------------------------------\n\nforeign import ccall safe \"gtk_show_uri\"\n gtk_show_uri :: Ptr Screen -> Ptr CChar -> CUInt -> Ptr (Ptr ()) -> IO CInt\n\nforeign import ccall unsafe \"gtk_get_current_event_time\"\n gtk_get_current_event_time :: IO CUInt\n" }, { "path": "GUI/Histogram.hs", "content": "{-# LANGUAGE ScopedTypeVariables #-}\n module GUI.Histogram (\n HistogramView,\n histogramViewNew,\n histogramViewSetHECs,\n histogramViewSetInterval,\n ) where\n\nimport Events.HECs\nimport GUI.Timeline.Render (renderTraces, renderYScaleArea)\nimport GUI.Timeline.Render.Constants\nimport GUI.Types\n\nimport qualified Graphics.Rendering.Cairo as C\nimport Graphics.UI.Gtk\nimport qualified GUI.GtkExtras as GtkExt\n\nimport Data.IORef\nimport Control.Monad.Trans\n\ndata HistogramView =\n HistogramView\n { hecsIORef :: IORef (Maybe HECs)\n , mintervalIORef :: IORef (Maybe Interval)\n , histogramDrawingArea :: DrawingArea\n , histogramYScaleArea :: DrawingArea\n }\n\nhistogramViewSetHECs :: HistogramView -> Maybe HECs -> IO ()\nhistogramViewSetHECs HistogramView{..} mhecs = do\n writeIORef hecsIORef mhecs\n writeIORef mintervalIORef Nothing -- the old interval may make no sense\n widgetQueueDraw histogramDrawingArea\n widgetQueueDraw histogramYScaleArea\n\nhistogramViewSetInterval :: HistogramView -> Maybe Interval -> IO ()\nhistogramViewSetInterval HistogramView{..} minterval = do\n writeIORef mintervalIORef minterval\n widgetQueueDraw histogramDrawingArea\n widgetQueueDraw histogramYScaleArea\n\nhistogramViewNew :: Builder -> IO HistogramView\nhistogramViewNew builder = do\n let getWidget cast = builderGetObject builder cast\n histogramDrawingArea <- getWidget castToDrawingArea \"histogram_drawingarea\"\n histogramYScaleArea <- getWidget castToDrawingArea \"timeline_yscale_area2\"\n timelineXScaleArea <- getWidget castToDrawingArea \"timeline_xscale_area\"\n\n -- HACK: layoutSetAttributes does not work for \\mu, so let's work around\n fd <- fontDescriptionNew\n fontDescriptionSetSize fd 8\n fontDescriptionSetFamily fd \"sans serif\"\n widgetModifyFont histogramYScaleArea (Just fd)\n\n Rectangle _ _ _ xh <- widgetGetAllocation timelineXScaleArea\n let xScaleAreaHeight = fromIntegral xh\n traces = [TraceHistogram]\n paramsHist (w, h) minterval = ViewParameters\n { width = w\n , height = h\n , viewTraces = traces\n , hadjValue = 0\n , scaleValue = 1\n , maxSpkValue = undefined\n , detail = undefined\n , bwMode = undefined\n , labelsMode = False\n , histogramHeight = h - histXScaleHeight\n , minterval = minterval\n , xScaleAreaHeight = xScaleAreaHeight\n }\n\n hecsIORef <- newIORef Nothing\n mintervalIORef <- newIORef Nothing\n\n pangoCtx <- widgetGetPangoContext histogramDrawingArea\n style <- get histogramDrawingArea widgetStyle\n layout <- layoutEmpty pangoCtx\n (_ :: String) <- layoutSetMarkup layout $\n \"No detailed spark events in this eventlog.\\n\"\n ++ \"Re-run with +RTS -lf to generate them.\"\n\n -- Program the callback for the capability drawingArea\n on histogramDrawingArea draw $\n C.liftIO $ do\n maybeEventArray <- readIORef hecsIORef\n -- TODO: get rid of Just\n Just win <- widgetGetWindow histogramDrawingArea\n Rectangle _ _ w windowHeight <- widgetGetAllocation histogramDrawingArea\n case maybeEventArray of\n Nothing -> return ()\n Just hecs\n | null (durHistogram hecs) -> do\n renderWithDrawWindow win $ do\n C.moveTo 4 20\n showLayout layout\n return ()\n | otherwise -> do\n minterval <- readIORef mintervalIORef\n if windowHeight < 80\n then return ()\n else do\n let size = (w, windowHeight - firstTraceY)\n params = paramsHist size minterval\n rect = Rectangle 0 0 w (snd size)\n renderWithDrawWindow win $\n renderTraces params hecs rect\n return ()\n\n -- Redrawing histogramYScaleArea\n histogramYScaleArea `on` draw $ liftIO $ do\n maybeEventArray <- readIORef hecsIORef\n case maybeEventArray of\n Nothing -> return ()\n Just hecs\n | null (durHistogram hecs) -> return ()\n | otherwise -> do\n -- TODO: get rid of Just\n Just win <- widgetGetWindow histogramYScaleArea\n minterval <- readIORef mintervalIORef\n Rectangle _ _ _ windowHeight <- widgetGetAllocation histogramYScaleArea\n if windowHeight < 80\n then return ()\n else do\n let size = (undefined, windowHeight - firstTraceY)\n params = paramsHist size minterval\n renderWithDrawWindow win $\n renderYScaleArea params hecs histogramYScaleArea\n return ()\n\n return HistogramView{..}\n" }, { "path": "GUI/KeyView.hs", "content": "module GUI.KeyView (\n KeyView,\n keyViewNew,\n ) where\n\nimport GUI.ViewerColours\nimport GUI.Timeline.Render.Constants\n\nimport Graphics.UI.Gtk\nimport qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat\nimport qualified Graphics.Rendering.Cairo as C\n\n\n---------------------------------------------------------------------------\n\n-- | Abstract key view object.\n--\ndata KeyView = KeyView\n\n---------------------------------------------------------------------------\n\nkeyViewNew :: Builder -> IO KeyView\nkeyViewNew builder = do\n\n keyTreeView <- builderGetObject builder castToTreeView \"key_list\"\n\n -- TODO: get rid of this Just\n Just dw <- widgetGetWindow keyTreeView\n keyEntries <- createKeyEntries dw keyData\n\n keyStore <- listStoreNew keyEntries\n keyColumn <- treeViewColumnNew\n imageCell <- cellRendererPixbufNew\n labelCell <- cellRendererTextNew\n\n treeViewColumnPackStart keyColumn imageCell False\n treeViewColumnPackStart keyColumn labelCell True\n treeViewAppendColumn keyTreeView keyColumn\n\n selection <- treeViewGetSelection keyTreeView\n treeSelectionSetMode selection SelectionNone\n\n let tooltipColumn = makeColumnIdString 0\n customStoreSetColumn keyStore tooltipColumn (\\(_,tooltip,_) -> tooltip)\n Compat.treeViewSetModel keyTreeView (Just keyStore)\n\n set keyTreeView [ treeViewTooltipColumn := tooltipColumn ]\n\n cellLayoutSetAttributes keyColumn imageCell keyStore $ \\(_,_,img) ->\n [ cellPixbuf := img ]\n cellLayoutSetAttributes keyColumn labelCell keyStore $ \\(label,_,_) ->\n [ cellText := label ]\n\n ---------------------------------------------------------------------------\n\n return KeyView\n\n-------------------------------------------------------------------------------\n\ndata KeyStyle = KDuration | KEvent | KEventAndGraph\n\nkeyData :: [(String, KeyStyle, Color, String)]\nkeyData =\n [ (\"running\", KDuration, runningColour,\n \"Indicates a period of time spent running Haskell code (not GC, not blocked/idle)\")\n , (\"GC\", KDuration, gcColour,\n \"Indicates a period of time spent by the RTS performing garbage collection (GC)\")\n , (\"GC waiting\", KDuration, gcWaitColour,\n \"Indicates a period of time spent by the RTS waiting to initiate or finish garbage collection (GC)\")\n , (\"create thread\", KEvent, createThreadColour,\n \"Indicates a new Haskell thread has been created\")\n , (\"seq GC req\", KEvent, seqGCReqColour,\n \"Indicates a HEC has requested to start a sequential GC\")\n , (\"par GC req\", KEvent, parGCReqColour,\n \"Indicates a HEC has requested to start a parallel GC\")\n , (\"migrate thread\", KEvent, migrateThreadColour,\n \"Indicates a Haskell thread has been moved from one HEC to another\")\n , (\"thread wakeup\", KEvent, threadWakeupColour,\n \"Indicates that a thread that was previously blocked (e.g. I/O, MVar etc) is now ready to run\")\n , (\"shutdown\", KEvent, shutdownColour,\n \"Indicates a HEC is terminating\")\n , (\"user message\", KEvent, userMessageColour,\n \"Indicates a message generated from Haskell code (via traceEvent)\")\n , (\"perf counter\", KEvent, createdConvertedColour,\n \"Indicates an update of a perf counter\")\n , (\"perf tracepoint\", KEvent, shutdownColour,\n \"Indicates that a perf tracepoint was reached\")\n , (\"create spark\", KEventAndGraph, createdConvertedColour,\n \"As an event it indicates a use of `par` resulted in a spark being \" ++\n \"created (and added to the spark pool). In the spark creation \" ++\n \"graph the coloured area represents the number of sparks created.\")\n , (\"dud spark\", KEventAndGraph, fizzledDudsColour,\n \"As an event it indicates a use of `par` resulted in the spark being \" ++\n \"discarded because it was a 'dud' (already evaluated). In the spark \" ++\n \"creation graph the coloured area represents the number of dud sparks.\")\n , (\"overflowed spark\",KEventAndGraph, overflowedColour,\n \"As an event it indicates a use of `par` resulted in the spark being \" ++\n \"discarded because the spark pool was full. In the spark creation \" ++\n \"graph the coloured area represents the number of overflowed sparks.\")\n , (\"run spark\", KEventAndGraph, createdConvertedColour,\n \"As an event it indicates a spark has started to be run/evaluated. \" ++\n \"In the spark conversion graph the coloured area represents the number \" ++\n \"of sparks run.\")\n , (\"fizzled spark\", KEventAndGraph, fizzledDudsColour,\n \"As an event it indicates a spark has 'fizzled', meaning it has been \" ++\n \"discovered that the spark's thunk was evaluated by some other thread. \" ++\n \"In the spark conversion graph the coloured area represents the number \" ++\n \"of sparks that have fizzled.\")\n , (\"GCed spark\", KEventAndGraph, gcColour,\n \"As an event it indicates a spark has been GCed, meaning it has been \" ++\n \"discovered that the spark's thunk was no longer needed anywhere. \" ++\n \"In the spark conversion graph the coloured area represents the number \" ++\n \"of sparks that were GCed.\")\n ]\n\n\ncreateKeyEntries :: DrawWindowClass dw\n => dw\n -> [(String, KeyStyle, Color,String)]\n -> IO [(String, String, Pixbuf)]\ncreateKeyEntries similar entries =\n sequence\n [ do pixbuf <- renderToPixbuf similar (50, hecBarHeight) $ do\n C.setSourceRGB 1 1 1\n C.paint\n renderKeyIcon style colour\n return (label, tooltip, pixbuf)\n\n | (label, style, colour, tooltip) <- entries ]\n\nrenderKeyIcon :: KeyStyle -> Color -> C.Render ()\nrenderKeyIcon KDuration keyColour = do\n setSourceRGBAhex keyColour 1.0\n let x = fromIntegral ox\n C.rectangle (x - 2) 5 38 (fromIntegral (hecBarHeight `div` 2))\n C.fill\nrenderKeyIcon KEvent keyColour = renderKEvent keyColour\nrenderKeyIcon KEventAndGraph keyColour = do\n renderKEvent keyColour\n -- An icon roughly representing a jaggedy graph.\n let x = fromIntegral ox\n y = fromIntegral hecBarHeight\n C.moveTo (2*x) (y - 2)\n C.relLineTo 3 (-6)\n C.relLineTo 3 0\n C.relLineTo 3 3\n C.relLineTo 5 1\n C.relLineTo 1 (-(y - 4))\n C.relLineTo 2 (y - 4)\n C.relLineTo 1 (-(y - 4))\n C.relLineTo 2 (y - 4)\n C.lineTo (2*x+20) (y - 2)\n C.fill\n setSourceRGBAhex black 1.0\n C.setLineWidth 1.0\n C.moveTo (2*x-4) (y - 2.5)\n C.lineTo (2*x+24) (y - 2.5)\n C.stroke\n\nrenderKEvent :: Color -> C.Render ()\nrenderKEvent keyColour = do\n setSourceRGBAhex keyColour 1.0\n C.setLineWidth 3.0\n let x = fromIntegral ox\n C.moveTo x 0\n C.relLineTo 0 25\n C.stroke\n\nrenderToPixbuf :: DrawWindowClass dw => dw -> (Int, Int) -> C.Render ()\n -> IO Pixbuf\nrenderToPixbuf similar (w, h) draw = do\n renderWithDrawWindow similar draw\n pixbuf <- pixbufNewFromWindow similar 0 0 w h\n return pixbuf\n\n-------------------------------------------------------------------------------\n" }, { "path": "GUI/Main.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE TemplateHaskell #-}\n{-# LANGUAGE OverloadedStrings #-}\nmodule GUI.Main (runGUI) where\n\n-- Imports for GTK\nimport qualified Graphics.UI.Gtk as Gtk\nimport System.Glib.GError (failOnGError)\n\n-- Imports from Haskell library\nimport Text.Printf\n#ifndef mingw32_HOST_OS\nimport System.Posix\n#endif\nimport Control.Concurrent\nimport qualified Control.Concurrent.Chan as Chan\nimport Control.Exception\nimport Data.Array\nimport Data.Maybe\nimport Data.Text (Text)\n\n-- Imports for ThreadScope\nimport qualified GUI.App as App\nimport qualified GUI.MainWindow as MainWindow\nimport GUI.Types\nimport Events.HECs hiding (Event)\nimport GUI.DataFiles (ui)\nimport GUI.Dialogs\nimport Events.ReadEvents\nimport GUI.EventsView\nimport GUI.SummaryView\nimport GUI.StartupInfoView\nimport GUI.Histogram\nimport GUI.Timeline\nimport GUI.TraceView\nimport GUI.BookmarkView\nimport GUI.KeyView\nimport GUI.SaveAs\nimport qualified GUI.ConcurrencyControl as ConcurrencyControl\nimport qualified GUI.ProgressView as ProgressView\nimport qualified GUI.GtkExtras as GtkExtras\n\n-------------------------------------------------------------------------------\n\ndata UIEnv = UIEnv {\n\n mainWin :: MainWindow.MainWindow,\n eventsView :: EventsView,\n startupView :: StartupInfoView,\n summaryView :: SummaryView,\n histogramView :: HistogramView,\n timelineWin :: TimelineView,\n traceView :: TraceView,\n bookmarkView :: BookmarkView,\n keyView :: KeyView,\n\n eventQueue :: Chan Event,\n concCtl :: ConcurrencyControl.ConcurrencyControl\n }\n\ndata EventlogState\n = NoEventlogLoaded\n | EventlogLoaded {\n mfilename :: Maybe FilePath, --test traces have no filepath\n hecs :: HECs,\n selection :: TimeSelection,\n cursorPos :: Int\n }\n\npostEvent :: Chan Event -> Event -> IO ()\npostEvent = Chan.writeChan\n\ngetEvent :: Chan Event -> IO Event\ngetEvent = Chan.readChan\n\ndata Event\n = EventOpenDialog\n | EventExportDialog\n | EventLaunchWebsite\n | EventLaunchTutorial\n | EventAboutDialog\n | EventQuit\n\n | EventFileLoad FilePath\n | EventTestLoad String\n | EventFileReload\n | EventFileExport FilePath FileExportFormat\n\n | EventSetState HECs (Maybe FilePath) String Int Double\n\n | EventShowSidebar Bool\n | EventShowEvents Bool\n\n | EventTimelineJumpStart\n | EventTimelineJumpEnd\n | EventTimelineJumpCursor\n | EventTimelineScrollLeft\n | EventTimelineScrollRight\n | EventTimelineZoomIn\n | EventTimelineZoomOut\n | EventTimelineZoomToFit\n | EventTimelineLabelsMode Bool\n | EventTimelineShowBW Bool\n\n | EventCursorChangedIndex Int\n | EventCursorChangedSelection TimeSelection\n\n | EventTracesChanged [Trace]\n\n | EventBookmarkAdd\n | EventBookmarkRemove Int\n | EventBookmarkEdit Int Text\n\n | EventUserError String SomeException\n -- can add more specific ones if necessary\n\nconstructUI :: IO UIEnv\nconstructUI = failOnGError $ do\n\n builder <- Gtk.builderNew\n Gtk.builderAddFromString builder $ui\n\n eventQueue <- Chan.newChan\n let post = postEvent eventQueue\n\n mainWin <- MainWindow.mainWindowNew builder MainWindow.MainWindowActions {\n mainWinOpen = post EventOpenDialog,\n mainWinExport = post EventExportDialog,\n mainWinQuit = post EventQuit,\n mainWinViewSidebar = post . EventShowSidebar,\n mainWinViewEvents = post . EventShowEvents,\n mainWinViewReload = post EventFileReload,\n mainWinWebsite = post EventLaunchWebsite,\n mainWinTutorial = post EventLaunchTutorial,\n mainWinAbout = post EventAboutDialog,\n mainWinJumpStart = post EventTimelineJumpStart,\n mainWinJumpEnd = post EventTimelineJumpEnd,\n mainWinJumpCursor = post EventTimelineJumpCursor,\n mainWinScrollLeft = post EventTimelineScrollLeft,\n mainWinScrollRight = post EventTimelineScrollRight,\n mainWinJumpZoomIn = post EventTimelineZoomIn,\n mainWinJumpZoomOut = post EventTimelineZoomOut,\n mainWinJumpZoomFit = post EventTimelineZoomToFit,\n mainWinDisplayLabels = post . EventTimelineLabelsMode,\n mainWinViewBW = post . EventTimelineShowBW\n }\n\n timelineWin <- timelineViewNew builder TimelineViewActions {\n timelineViewSelectionChanged = post . EventCursorChangedSelection\n }\n\n eventsView <- eventsViewNew builder EventsViewActions {\n eventsViewCursorChanged = post . EventCursorChangedIndex\n }\n\n startupView <- startupInfoViewNew builder\n summaryView <- summaryViewNew builder\n\n histogramView <- histogramViewNew builder\n\n traceView <- traceViewNew builder TraceViewActions {\n traceViewTracesChanged = post . EventTracesChanged\n }\n\n bookmarkView <- bookmarkViewNew builder BookmarkViewActions {\n bookmarkViewAddBookmark = post EventBookmarkAdd,\n bookmarkViewRemoveBookmark = post . EventBookmarkRemove,\n bookmarkViewGotoBookmark = \\ts -> do\n post (EventCursorChangedSelection (PointSelection ts))\n post EventTimelineJumpCursor,\n bookmarkViewEditLabel = \\n v -> post (EventBookmarkEdit n v)\n }\n\n keyView <- keyViewNew builder\n\n concCtl <- ConcurrencyControl.start\n\n return UIEnv{..}\n\n-------------------------------------------------------------------------------\n\ndata LoopDone = LoopDone\n\neventLoop :: UIEnv -> EventlogState -> IO ()\neventLoop uienv@UIEnv{..} eventlogState = do\n\n event <- getEvent eventQueue\n next <- dispatch event eventlogState\n#if __GLASGOW_HASKELL__ <= 612\n -- workaround for a wierd exception handling bug in ghc-6.12\n `catch` \\e -> throwIO (e :: SomeException)\n#endif\n case next of\n Left LoopDone -> return ()\n Right eventlogState' -> eventLoop uienv eventlogState'\n\n where\n dispatch :: Event -> EventlogState -> IO (Either LoopDone EventlogState)\n\n dispatch EventQuit _ = return (Left LoopDone)\n\n dispatch EventOpenDialog _ = do\n openFileDialog mainWin $ \\filename ->\n post (EventFileLoad filename)\n continue\n\n dispatch (EventFileLoad filename) _ = do\n async \"loading the eventlog\" $\n loadEvents (Just filename) (registerEventsFromFile filename)\n --TODO: set state to be empty during loading\n continue\n\n dispatch (EventTestLoad testname) _ = do\n async \"loading the test eventlog\" $\n loadEvents Nothing (registerEventsFromTrace testname)\n --TODO: set state to be empty during loading\n continue\n\n dispatch EventFileReload EventlogLoaded{mfilename = Just filename} = do\n async \"reloading the eventlog\" $\n loadEvents (Just filename) (registerEventsFromFile filename)\n --TODO: set state to be empty during loading\n continue\n\n dispatch EventFileReload EventlogLoaded{mfilename = Nothing} =\n continue\n\n-- dispatch EventClearState _\n\n dispatch (EventSetState hecs mfilename name nevents timespan) _ =\n\n -- We have to draw this ASAP, before the user manages to move\n -- the mouse away from the window, or the window is left\n -- in a partially drawn state.\n ConcurrencyControl.fullSpeed concCtl $ do\n\n MainWindow.setFileLoaded mainWin (Just name)\n MainWindow.setStatusMessage mainWin $\n printf \"%s (%d events, %.3fs)\" name nevents timespan\n\n let mevents = Just $ hecEventArray hecs\n eventsViewSetEvents eventsView mevents\n startupInfoViewSetEvents startupView mevents\n summaryViewSetEvents summaryView mevents\n histogramViewSetHECs histogramView (Just hecs)\n traceViewSetHECs traceView hecs\n traces' <- traceViewGetTraces traceView\n timelineWindowSetHECs timelineWin (Just hecs)\n timelineWindowSetTraces timelineWin traces'\n\n -- We set user 'traceMarker' events as initial bookmarks.\n let usrMarkers = extractUserMarkers hecs\n bookmarkViewClear bookmarkView\n sequence_ [ bookmarkViewAdd bookmarkView ts label\n | (ts, label) <- usrMarkers ]\n timelineWindowSetBookmarks timelineWin (map fst usrMarkers)\n\n if nevents == 0\n then continueWith NoEventlogLoaded\n else continueWith EventlogLoaded\n { mfilename = mfilename\n , hecs = hecs\n , selection = PointSelection 0\n , cursorPos = 0\n }\n\n dispatch EventExportDialog\n EventlogLoaded {mfilename} = do\n exportFileDialog mainWin (fromMaybe \"\" mfilename) $ \\filename' format ->\n post (EventFileExport filename' format)\n continue\n\n dispatch (EventFileExport filename format)\n EventlogLoaded {hecs} = do\n viewParams <- timelineGetViewParameters timelineWin\n let viewParams' = viewParams {\n detail = 1,\n bwMode = False,\n labelsMode = False\n }\n let yScaleArea = timelineGetYScaleArea timelineWin\n case format of\n FormatPDF ->\n saveAsPDF filename hecs viewParams' yScaleArea\n FormatPNG ->\n saveAsPNG filename hecs viewParams' yScaleArea\n continue\n\n dispatch EventLaunchWebsite _ = do\n GtkExtras.launchProgramForURI \"http://www.haskell.org/haskellwiki/ThreadScope\"\n continue\n\n dispatch EventLaunchTutorial _ = do\n GtkExtras.launchProgramForURI \"http://www.haskell.org/haskellwiki/ThreadScope_Tour\"\n continue\n\n dispatch EventAboutDialog _ = do\n aboutDialog mainWin\n continue\n\n dispatch (EventShowSidebar visible) _ = do\n MainWindow.sidebarSetVisibility mainWin visible\n continue\n\n dispatch (EventShowEvents visible) _ = do\n MainWindow.eventsSetVisibility mainWin visible\n continue\n\n dispatch EventTimelineJumpStart _ = do\n timelineScrollToBeginning timelineWin\n eventsViewScrollToLine eventsView 0\n continue\n\n dispatch EventTimelineJumpEnd EventlogLoaded{hecs} = do\n timelineScrollToEnd timelineWin\n let (_,end) = bounds (hecEventArray hecs)\n eventsViewScrollToLine eventsView end\n continue\n\n dispatch EventTimelineJumpCursor EventlogLoaded{cursorPos} = do\n timelineCentreOnCursor timelineWin --TODO: pass selection here\n eventsViewScrollToLine eventsView cursorPos\n continue\n\n dispatch EventTimelineScrollLeft _ = do\n timelineScrollLeft timelineWin\n continue\n\n dispatch EventTimelineScrollRight _ = do\n timelineScrollRight timelineWin\n continue\n dispatch EventTimelineZoomIn _ = do\n timelineZoomIn timelineWin\n continue\n dispatch EventTimelineZoomOut _ = do\n timelineZoomOut timelineWin\n continue\n dispatch EventTimelineZoomToFit _ = do\n timelineZoomToFit timelineWin\n continue\n\n dispatch (EventTimelineLabelsMode labelsMode) _ = do\n timelineSetLabelsMode timelineWin labelsMode\n continue\n\n dispatch (EventTimelineShowBW showBW) _ = do\n timelineSetBWMode timelineWin showBW\n continue\n\n dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do\n let cursorTs' = eventIndexToTimestamp hecs cursorPos'\n selection' = PointSelection cursorTs'\n mselection <- timelineSetSelection timelineWin selection'\n setSelection cursorPos' Nothing mselection\n\n dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs'))\n EventlogLoaded{hecs} = do\n let cursorPos' = timestampToEventIndex hecs cursorTs'\n mselection <- timelineSetSelection timelineWin selection'\n setSelection cursorPos' Nothing mselection\n\n dispatch (EventCursorChangedSelection selection'@(RangeSelection start end))\n EventlogLoaded{hecs} = do\n let cursorPos' = timestampToEventIndex hecs start\n mrange = Just (cursorPos', timestampToEventIndex hecs end)\n mselection <- timelineSetSelection timelineWin selection'\n setSelection cursorPos' mrange mselection\n\n dispatch (EventTracesChanged traces) _ = do\n timelineWindowSetTraces timelineWin traces\n continue\n\n dispatch EventBookmarkAdd EventlogLoaded{selection} = do\n case selection of\n PointSelection a -> bookmarkViewAdd bookmarkView a \"\"\n RangeSelection a b -> do bookmarkViewAdd bookmarkView a \"\"\n bookmarkViewAdd bookmarkView b \"\"\n --TODO: should have a way to add/set a single bookmark for the timeline\n -- rather than this hack where we ask the bookmark view for the whole lot.\n ts <- bookmarkViewGet bookmarkView\n timelineWindowSetBookmarks timelineWin (map fst ts)\n continue\n\n dispatch (EventBookmarkRemove n) _ = do\n bookmarkViewRemove bookmarkView n\n --TODO: should have a way to add/set a single bookmark for the timeline\n -- rather than this hack where we ask the bookmark view for the whole lot.\n ts <- bookmarkViewGet bookmarkView\n timelineWindowSetBookmarks timelineWin (map fst ts)\n continue\n\n dispatch (EventBookmarkEdit n v) _ = do\n bookmarkViewSetLabel bookmarkView n v\n continue\n\n dispatch (EventUserError doing exception) _ = do\n let headline = \"There was a problem \" ++ doing ++ \".\"\n explanation = show exception\n errorMessageDialog mainWin headline explanation\n continue\n\n dispatch _ NoEventlogLoaded = continue\n\n loadEvents mfilename registerEvents = do\n ConcurrencyControl.fullSpeed concCtl $\n ProgressView.withProgress mainWin $ \\progress -> do\n (hecs, name, nevents, timespan) <- registerEvents progress\n -- This is a desperate hack to avoid the \"segfault on reload\" bug\n -- http://trac.haskell.org/ThreadScope/ticket/1\n -- It should be enough to let other threads finish and so avoid\n -- re-entering gtk C code (see ticket for the dirty details).\n --\n -- Unfortunately it halts drawing of the loaded events if the user\n -- manages to move the mouse away from the window during the delay.\n -- threadDelay 100000 -- 1/10th of a second\n post (EventSetState hecs mfilename name nevents timespan)\n return ()\n\n async doing action =\n forkIO (action `catch` \\e -> post (EventUserError doing e))\n\n setSelection cursorPos' _ (Just selection'@(PointSelection _)) = do\n eventsViewSetCursor eventsView cursorPos' Nothing\n histogramViewSetInterval histogramView Nothing\n summaryViewSetInterval summaryView Nothing\n continueWith eventlogState {\n selection = selection',\n cursorPos = cursorPos'\n }\n setSelection cursorPos' mrange (Just selection'@(RangeSelection start end)) = do\n eventsViewSetCursor eventsView cursorPos' mrange\n histogramViewSetInterval histogramView (Just (start, end))\n summaryViewSetInterval summaryView (Just (start, end))\n continueWith eventlogState {\n selection = selection',\n cursorPos = cursorPos'\n }\n setSelection _ _ Nothing = continue\n\n post = postEvent eventQueue\n continue = continueWith eventlogState\n continueWith = return . Right\n\n-------------------------------------------------------------------------------\n\nrunGUI :: Maybe (Either FilePath String) -> IO ()\nrunGUI initialTrace = do\n Gtk.initGUI\n\n App.initApp\n\n uiEnv <- constructUI\n\n let post = postEvent (eventQueue uiEnv)\n\n case initialTrace of\n Nothing -> return ()\n Just (Left filename) -> post (EventFileLoad filename)\n Just (Right traceName) -> post (EventTestLoad traceName)\n\n doneVar <- newEmptyMVar\n\n forkIO $ do\n res <- try $ eventLoop uiEnv NoEventlogLoaded\n Gtk.mainQuit\n putMVar doneVar (res :: Either SomeException ())\n\n#ifndef mingw32_HOST_OS\n installHandler sigINT (Catch $ post EventQuit) Nothing\n#endif\n\n -- Enter Gtk+ main event loop.\n Gtk.mainGUI\n\n -- Wait for child event loop to terminate\n -- This lets us wait for any exceptions.\n either throwIO return =<< takeMVar doneVar\n" }, { "path": "GUI/MainWindow.hs", "content": "{-# LANGUAGE TemplateHaskell #-}\nmodule GUI.MainWindow (\n MainWindow,\n mainWindowNew,\n MainWindowActions(..),\n\n setFileLoaded,\n setStatusMessage,\n sidebarSetVisibility,\n eventsSetVisibility,\n\n ) where\n\nimport Graphics.UI.Gtk as Gtk\nimport qualified System.Glib.GObject as Glib\n\nimport GUI.DataFiles (loadLogo)\n\n-------------------------------------------------------------------------------\n\ndata MainWindow = MainWindow {\n mainWindow :: Window,\n\n sidebarBox,\n eventsBox :: Widget,\n\n statusBar :: Statusbar,\n statusBarCxt :: ContextId\n }\n\ninstance Glib.GObjectClass MainWindow where\n toGObject = toGObject . mainWindow\n unsafeCastGObject = error \"cannot downcast to MainView type\"\n\ninstance Gtk.WidgetClass MainWindow\ninstance Gtk.ContainerClass MainWindow\ninstance Gtk.BinClass MainWindow\ninstance Gtk.WindowClass MainWindow\n\ndata MainWindowActions = MainWindowActions {\n\n -- Menu actions\n mainWinOpen :: IO (),\n mainWinExport :: IO (),\n mainWinQuit :: IO (),\n mainWinViewSidebar :: Bool -> IO (),\n mainWinViewEvents :: Bool -> IO (),\n mainWinViewBW :: Bool -> IO (),\n mainWinViewReload :: IO (),\n mainWinWebsite :: IO (),\n mainWinTutorial :: IO (),\n mainWinAbout :: IO (),\n\n -- Toolbar actions\n mainWinJumpStart :: IO (),\n mainWinJumpEnd :: IO (),\n mainWinJumpCursor :: IO (),\n mainWinJumpZoomIn :: IO (),\n mainWinJumpZoomOut :: IO (),\n mainWinJumpZoomFit :: IO (),\n mainWinScrollLeft :: IO (),\n mainWinScrollRight :: IO (),\n mainWinDisplayLabels :: Bool -> IO ()\n }\n\n-------------------------------------------------------------------------------\n\nsetFileLoaded :: MainWindow -> Maybe FilePath -> IO ()\nsetFileLoaded mainWin Nothing =\n set (mainWindow mainWin) [\n windowTitle := \"ThreadScope\"\n ]\nsetFileLoaded mainWin (Just file) =\n set (mainWindow mainWin) [\n windowTitle := file ++ \" - ThreadScope\"\n ]\n\nsetStatusMessage :: MainWindow -> String -> IO ()\nsetStatusMessage mainWin msg = do\n statusbarPop (statusBar mainWin) (statusBarCxt mainWin)\n statusbarPush (statusBar mainWin) (statusBarCxt mainWin) (' ':msg)\n return ()\n\nsidebarSetVisibility :: MainWindow -> Bool -> IO ()\nsidebarSetVisibility mainWin visible =\n set (sidebarBox mainWin) [ widgetVisible := visible ]\n\neventsSetVisibility :: MainWindow -> Bool -> IO ()\neventsSetVisibility mainWin visible =\n set (eventsBox mainWin) [ widgetVisible := visible ]\n\n-------------------------------------------------------------------------------\n\nmainWindowNew :: Builder -> MainWindowActions -> IO MainWindow\nmainWindowNew builder actions = do\n\n let getWidget cast name = builderGetObject builder cast name\n\n\n mainWindow <- getWidget castToWindow \"main_window\"\n statusBar <- getWidget castToStatusbar \"statusbar\"\n\n sidebarBox <- getWidget castToWidget \"sidebar\"\n eventsBox <- getWidget castToWidget \"eventsbox\"\n\n bwToggle <- getWidget castToCheckMenuItem \"black_and_white\"\n labModeToggle <- getWidget castToCheckMenuItem \"view_labels_mode\"\n sidebarToggle <- getWidget castToCheckMenuItem \"view_sidebar\"\n eventsToggle <- getWidget castToCheckMenuItem \"view_events\"\n openMenuItem <- getWidget castToMenuItem \"openMenuItem\"\n exportMenuItem <- getWidget castToMenuItem \"exportMenuItem\"\n reloadMenuItem <- getWidget castToMenuItem \"view_reload\"\n quitMenuItem <- getWidget castToMenuItem \"quitMenuItem\"\n websiteMenuItem <- getWidget castToMenuItem \"websiteMenuItem\"\n tutorialMenuItem <- getWidget castToMenuItem \"tutorialMenuItem\"\n aboutMenuItem <- getWidget castToMenuItem \"aboutMenuItem\"\n\n firstMenuItem <- getWidget castToMenuItem \"move_first\"\n centreMenuItem <- getWidget castToMenuItem \"move_centre\"\n lastMenuItem <- getWidget castToMenuItem \"move_last\"\n\n zoomInMenuItem <- getWidget castToMenuItem \"move_zoomin\"\n zoomOutMenuItem <- getWidget castToMenuItem \"move_zoomout\"\n zoomFitMenuItem <- getWidget castToMenuItem \"move_zoomfit\"\n\n openButton <- getWidget castToToolButton \"cpus_open\"\n\n firstButton <- getWidget castToToolButton \"cpus_first\"\n centreButton <- getWidget castToToolButton \"cpus_centre\"\n lastButton <- getWidget castToToolButton \"cpus_last\"\n\n zoomInButton <- getWidget castToToolButton \"cpus_zoomin\"\n zoomOutButton <- getWidget castToToolButton \"cpus_zoomout\"\n zoomFitButton <- getWidget castToToolButton \"cpus_zoomfit\"\n\n ------------------------------------------------------------------------\n -- Show everything\n widgetShowAll mainWindow\n\n ------------------------------------------------------------------------\n\n logo <- $loadLogo\n set mainWindow [ windowIcon := logo ]\n\n ------------------------------------------------------------------------\n -- Status bar functionality\n\n statusBarCxt <- statusbarGetContextId statusBar \"file\"\n statusbarPush statusBar statusBarCxt \"No eventlog loaded.\"\n\n ------------------------------------------------------------------------\n -- Bind all the events\n\n -- Menus\n on openMenuItem menuItemActivate $ mainWinOpen actions\n on exportMenuItem menuItemActivate $ mainWinExport actions\n\n on quitMenuItem menuItemActivate $ mainWinQuit actions\n on mainWindow objectDestroy $ mainWinQuit actions\n\n on sidebarToggle checkMenuItemToggled $ checkMenuItemGetActive sidebarToggle\n >>= mainWinViewSidebar actions\n on eventsToggle checkMenuItemToggled $ checkMenuItemGetActive eventsToggle\n >>= mainWinViewEvents actions\n on bwToggle checkMenuItemToggled $ checkMenuItemGetActive bwToggle\n >>= mainWinViewBW actions\n on labModeToggle checkMenuItemToggled $ checkMenuItemGetActive labModeToggle\n >>= mainWinDisplayLabels actions\n on reloadMenuItem menuItemActivate $ mainWinViewReload actions\n\n on websiteMenuItem menuItemActivate $ mainWinWebsite actions\n on tutorialMenuItem menuItemActivate $ mainWinTutorial actions\n on aboutMenuItem menuItemActivate $ mainWinAbout actions\n\n on firstMenuItem menuItemActivate $ mainWinJumpStart actions\n on centreMenuItem menuItemActivate $ mainWinJumpCursor actions\n on lastMenuItem menuItemActivate $ mainWinJumpEnd actions\n\n on zoomInMenuItem menuItemActivate $ mainWinJumpZoomIn actions\n on zoomOutMenuItem menuItemActivate $ mainWinJumpZoomOut actions\n on zoomFitMenuItem menuItemActivate $ mainWinJumpZoomFit actions\n\n -- Toolbar\n onToolButtonClicked openButton $ mainWinOpen actions\n\n onToolButtonClicked firstButton $ mainWinJumpStart actions\n onToolButtonClicked centreButton $ mainWinJumpCursor actions\n onToolButtonClicked lastButton $ mainWinJumpEnd actions\n\n onToolButtonClicked zoomInButton $ mainWinJumpZoomIn actions\n onToolButtonClicked zoomOutButton $ mainWinJumpZoomOut actions\n onToolButtonClicked zoomFitButton $ mainWinJumpZoomFit actions\n\n return MainWindow {..}\n" }, { "path": "GUI/ProgressView.hs", "content": "{-# LANGUAGE DeriveDataTypeable #-}\n\nmodule GUI.ProgressView (\n ProgressView,\n withProgress,\n setText,\n setTitle,\n setProgress,\n startPulse,\n ) where\n\nimport Graphics.Rendering.Cairo\nimport Graphics.UI.Gtk as Gtk\nimport GUI.GtkExtras\n\nimport qualified Control.Concurrent as Concurrent\nimport Control.Exception\nimport Data.Typeable\nimport Control.Monad.Trans\n\ndata ProgressView = ProgressView {\n progressWindow :: Gtk.Window,\n progressLabel :: Gtk.Label,\n progressBar :: Gtk.ProgressBar\n }\n\n-- | Perform a long-running operation and display a progress window. The\n-- operation has access to the progress window and it is expected to update it\n-- using 'setText' and 'setProgress'\n--\n-- The user may cancel the operation at any time.\n--\nwithProgress :: WindowClass win => win -> (ProgressView -> IO a) -> IO (Maybe a)\nwithProgress parent action = do\n self <- Concurrent.myThreadId\n let cancel = throwTo self OperationInterrupted\n bracket (new parent cancel) close $ \\progress ->\n fmap Just (action progress)\n `catch` \\OperationInterrupted -> return Nothing\n\ndata OperationInterrupted = OperationInterrupted\n deriving (Typeable, Show)\ninstance Exception OperationInterrupted\n\nsetText :: ProgressView -> String -> IO ()\nsetText view msg =\n set (progressBar view) [\n progressBarText := msg\n ]\n\nsetTitle :: ProgressView -> String -> IO ()\nsetTitle view msg = do\n set (progressWindow view) [ windowTitle := msg ]\n set (progressLabel view) [ labelLabel := \"\" ++ msg ++ \"\" ]\n\nstartPulse :: ProgressView -> IO (IO ())\nstartPulse view = do\n let pulse = do\n progressBarPulse (progressBar view)\n Concurrent.threadDelay 200000\n pulse\n thread <- Concurrent.forkIO $\n pulse `catch` \\OperationInterrupted -> return ()\n let stop = throwTo thread OperationInterrupted\n waitGUI\n return stop\n\nsetProgress :: ProgressView -> Int -> Int -> IO ()\nsetProgress view total current = do\n let frac = fromIntegral current / fromIntegral total\n set (progressBar view) [ progressBarFraction := frac ]\n waitGUI\n\nclose :: ProgressView -> IO ()\nclose view = widgetDestroy (progressWindow view)\n\nnew :: WindowClass win => win -> IO () -> IO ProgressView\nnew parent cancelAction = do\n win <- windowNew\n set win [\n containerBorderWidth := 10,\n windowTitle := \"\",\n windowTransientFor := toWindow parent,\n windowModal := True,\n windowWindowPosition := WinPosCenterOnParent,\n windowDefaultWidth := 400,\n windowSkipTaskbarHint := True\n ]\n\n progText <- labelNew (Nothing :: Maybe String)\n set progText [\n miscXalign := 0,\n labelUseMarkup := True\n ]\n\n progress <- progressBarNew\n\n cancel <- buttonNewFromStock stockCancel\n cancel `on` buttonActivated $ (widgetDestroy win >> cancelAction)\n win `on` destroyEvent $ lift cancelAction >> return True\n on win keyPressEvent $ do\n keyVal <- eventKeyVal\n case keyVal of\n 0xff1b -> liftIO $ cancelAction >> return True\n _ -> return False\n\n vbox <- vBoxNew False 20\n hbox <- hBoxNew False 0\n boxPackStart vbox progText PackRepel 10\n boxPackStart vbox progress PackGrow 5\n boxPackStart vbox hbox PackNatural 5\n boxPackEnd hbox cancel PackNatural 0\n containerAdd win vbox\n\n widgetShowAll win\n\n return ProgressView {\n progressWindow = win,\n progressLabel = progText,\n progressBar = progress\n }\n" }, { "path": "GUI/SaveAs.hs", "content": "module GUI.SaveAs (saveAsPDF, saveAsPNG) where\n\n-- Imports for ThreadScope\nimport GUI.Timeline.Render (renderTraces, renderYScaleArea)\nimport GUI.Timeline.Render.Constants\nimport GUI.Timeline.Ticks (renderXScaleArea)\nimport GUI.Types\nimport Events.HECs\n\n-- Imports for GTK\nimport Graphics.UI.Gtk hiding (rectangle)\nimport Graphics.Rendering.Cairo\n ( Render\n , Operator(..)\n , Format(..)\n , rectangle\n , getOperator\n , setOperator\n , fill\n , translate\n , liftIO\n , withPDFSurface\n , renderWith\n , withImageSurface\n , surfaceWriteToPNG\n )\n\nsaveAs :: HECs -> ViewParameters -> Double -> DrawingArea\n -> (Int, Int, Render ())\nsaveAs hecs params'@ViewParameters{xScaleAreaHeight, width,\n height = oldHeight {-, histogramHeight-}}\n yScaleAreaWidth yScaleArea =\n let histTotalHeight = histXScaleHeight -- + histogramHeight\n params@ViewParameters{height} =\n params'{ viewTraces = viewTraces params' -- ++ [TraceHistogram]\n , height = oldHeight + histTotalHeight + tracePad\n }\n w = ceiling yScaleAreaWidth + width\n h = xScaleAreaHeight + height\n drawTraces = renderTraces params hecs (Rectangle 0 0 width height)\n drawXScale = renderXScaleArea params hecs\n drawYScale = renderYScaleArea params hecs yScaleArea\n -- Functions renderTraces and renderXScaleArea draw to the left of 0\n -- which is not seen in the normal mode, but would be seen in export,\n -- so it has to be cleared before renderYScaleArea is written on top:\n clearLeftArea = do\n rectangle 0 0 yScaleAreaWidth (fromIntegral h)\n op <- getOperator\n setOperator OperatorClear\n fill\n setOperator op\n drawAll = do\n translate yScaleAreaWidth (fromIntegral xScaleAreaHeight)\n drawTraces\n translate 0 (- fromIntegral xScaleAreaHeight)\n drawXScale\n translate (-yScaleAreaWidth) 0\n clearLeftArea\n translate 0 (fromIntegral xScaleAreaHeight)\n drawYScale\n in (w, h, drawAll)\n\nsaveAsPDF :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()\nsaveAsPDF filename hecs params yScaleArea = do\n Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea\n let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea\n withPDFSurface filename (fromIntegral w') (fromIntegral h') $ \\surface ->\n renderWith surface drawAll\n\nsaveAsPNG :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()\nsaveAsPNG filename hecs params yScaleArea = do\n Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea\n let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea\n withImageSurface FormatARGB32 w' h' $ \\surface -> do\n renderWith surface drawAll\n surfaceWriteToPNG surface filename\n" }, { "path": "GUI/StartupInfoView.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ViewPatterns #-}\nmodule GUI.StartupInfoView (\n StartupInfoView,\n startupInfoViewNew,\n startupInfoViewSetEvents,\n ) where\n\nimport GHC.RTS.Events\n\nimport Graphics.UI.Gtk\nimport qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat\n\nimport Data.Array\nimport Data.List\nimport Data.Maybe\nimport Data.Time\nimport Data.Time.Clock.POSIX\nimport Data.Text (Text)\nimport qualified Data.Text as T\n\n-------------------------------------------------------------------------------\n\ndata StartupInfoView = StartupInfoView\n { labelProgName :: Label\n , storeProgArgs :: ListStore Text\n , storeProgEnv :: ListStore (Text, Text)\n , labelProgStartTime :: Label\n , labelProgRtsId :: Label\n }\n\ndata StartupInfoState\n = StartupInfoEmpty\n | StartupInfoLoaded\n { progName :: Maybe Text\n , progArgs :: Maybe [Text]\n , progEnv :: Maybe [(Text, Text)]\n , progStartTime :: Maybe UTCTime\n , progRtsId :: Maybe Text\n }\n\n-------------------------------------------------------------------------------\n\nstartupInfoViewNew :: Builder -> IO StartupInfoView\nstartupInfoViewNew builder = do\n\n let getWidget cast = builderGetObject builder cast\n\n labelProgName <- getWidget castToLabel (\"labelProgName\" :: Text)\n treeviewProgArgs <- getWidget castToTreeView (\"treeviewProgArguments\" :: Text)\n treeviewProgEnv <- getWidget castToTreeView (\"treeviewProgEnvironment\" :: Text)\n labelProgStartTime <- getWidget castToLabel (\"labelProgStartTime\" :: Text)\n labelProgRtsId <- getWidget castToLabel (\"labelProgRtsIdentifier\" :: Text)\n\n storeProgArgs <- listStoreNew []\n columnArgs <- treeViewColumnNew\n cellArgs <- cellRendererTextNew\n\n treeViewColumnPackStart columnArgs cellArgs True\n treeViewAppendColumn treeviewProgArgs columnArgs\n\n Compat.treeViewSetModel treeviewProgArgs (Just storeProgArgs)\n\n set cellArgs [ cellTextEditable := True ]\n cellLayoutSetAttributes columnArgs cellArgs storeProgArgs $ \\arg ->\n [ cellText := arg ]\n\n storeProgEnv <- listStoreNew []\n columnVar <- treeViewColumnNew\n cellVar <- cellRendererTextNew\n columnValue <- treeViewColumnNew\n cellValue <- cellRendererTextNew\n\n treeViewColumnPackStart columnVar cellVar False\n treeViewColumnPackStart columnValue cellValue True\n treeViewAppendColumn treeviewProgEnv columnVar\n treeViewAppendColumn treeviewProgEnv columnValue\n\n Compat.treeViewSetModel treeviewProgEnv (Just storeProgEnv)\n\n cellLayoutSetAttributes columnVar cellVar storeProgEnv $ \\(var,_) ->\n [ cellText := var ]\n\n set cellValue [ cellTextEditable := True ]\n cellLayoutSetAttributes columnValue cellValue storeProgEnv $ \\(_,value) ->\n [ cellText := value ]\n\n let startupInfoView = StartupInfoView{..}\n\n return startupInfoView\n\n-------------------------------------------------------------------------------\n\nstartupInfoViewSetEvents :: StartupInfoView -> Maybe (Array Int Event) -> IO ()\nstartupInfoViewSetEvents view mevents =\n updateStartupInfo view (maybe StartupInfoEmpty processEvents mevents)\n\n--TODO: none of this handles the possibility of an eventlog containing multiple\n-- OS processes. Note that the capset arg is ignored in the events below.\n\nprocessEvents :: Array Int Event -> StartupInfoState\nprocessEvents = foldl' accum (StartupInfoLoaded Nothing Nothing Nothing Nothing Nothing)\n . take 1000\n . elems\n where\n accum info (Event _ (ProgramArgs _ (name:args)) _) =\n info {\n progName = Just name,\n progArgs = Just args\n }\n\n accum info (Event _ (ProgramEnv _ env) _) =\n info { progEnv = Just (sort (parseEnv env)) }\n\n accum info (Event _ (RtsIdentifier _ rtsid) _) =\n info { progRtsId = Just rtsid }\n\n accum info (Event timestamp (WallClockTime _ sec nsec) _) =\n -- WallClockTime records the wall clock time of *this* event\n -- which occurs some time after startup, so we can just subtract\n -- the timestamp since that is the relative time since startup.\n let wallTimePosix :: NominalDiffTime\n wallTimePosix = fromIntegral sec\n + (fromIntegral nsec / nanoseconds)\n - (fromIntegral timestamp / nanoseconds)\n nanoseconds = 1000000000\n wallTimeUTC = posixSecondsToUTCTime wallTimePosix\n in info { progStartTime = Just wallTimeUTC }\n\n accum info _ = info\n\n -- convert [\"foo=bar\", ...] to [(\"foo\", \"bar\"), ...]\n parseEnv env = [ (var, value) | (var, T.drop 1 -> value) <- map (T.span (/='=')) env ]\n\nupdateStartupInfo :: StartupInfoView -> StartupInfoState -> IO ()\nupdateStartupInfo StartupInfoView{..} StartupInfoLoaded{..} = do\n set labelProgName [ labelText := fromMaybe \"(unknown)\" progName ]\n set labelProgStartTime [ labelText := maybe \"(unknown)\" show progStartTime ]\n set labelProgRtsId [ labelText := fromMaybe \"(unknown)\" progRtsId ]\n listStoreClear storeProgArgs\n mapM_ (listStoreAppend storeProgArgs) (fromMaybe [] progArgs)\n listStoreClear storeProgEnv\n mapM_ (listStoreAppend storeProgEnv) (fromMaybe [] progEnv)\n\nupdateStartupInfo StartupInfoView{..} StartupInfoEmpty = do\n set labelProgName [ labelText := (\"\" :: Text) ]\n set labelProgStartTime [ labelText := (\"\" :: Text) ]\n set labelProgRtsId [ labelText := (\"\" :: Text) ]\n listStoreClear storeProgArgs\n listStoreClear storeProgEnv\n" }, { "path": "GUI/SummaryView.hs", "content": "module GUI.SummaryView (\n SummaryView,\n summaryViewNew,\n summaryViewSetEvents,\n summaryViewSetInterval,\n ) where\n\nimport GHC.RTS.Events\n\nimport GUI.Types\n\nimport Graphics.UI.Gtk\nimport qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat\n\nimport Control.Exception (assert)\nimport Control.Monad\nimport Data.Array\nimport qualified Data.IntMap as IM\nimport Data.IORef\nimport Data.List as L\nimport Data.Maybe\nimport Data.Word (Word64)\nimport Numeric (showFFloat)\nimport Text.Printf\n\n------------------------------------------------------------------------------\n\ntype Events = Array Int Event\n\ndata SummaryView = SummaryView {\n\n -- we cache the stats for the whole interval\n cacheEventsStats :: !(IORef (Maybe (Events, SummaryStats, Bool)))\n\n -- widgets for time stuff\n , labelTimeTotal :: Label\n , labelTimeMutator :: Label\n , labelTimeGC :: Label\n , labelTimeProductivity :: Label\n\n -- widgets for heap stuff\n , labelHeapMaxSize\n , labelHeapMaxResidency\n , labelHeapAllocTotal\n , labelHeapAllocRate\n , labelHeapMaxSlop :: (Label, Label, Label, Label)\n , tableHeap :: Widget\n\n -- widgets for GC stuff\n , labelGcCopied :: (Label, Label, Label, Label)\n , labelGcParWorkBalance :: Label\n , storeGcStats :: ListStore GcStatsEntry\n , tableGc :: Widget\n\n -- widgets for sparks stuff\n , storeSparkStats :: ListStore (Cap, SparkCounts)\n }\n\n------------------------------------------------------------------------------\n\nsummaryViewNew :: Builder -> IO SummaryView\nsummaryViewNew builder = do\n cacheEventsStats <- newIORef Nothing\n\n let getWidget cast = builderGetObject builder cast\n getLabel = getWidget castToLabel\n getHeapLabels w1 w2 w3 w4 = liftM4 (,,,) (getLabel w1) (getLabel w2)\n (getLabel w3) (getLabel w4)\n\n labelTimeTotal <- getWidget castToLabel \"labelTimeTotal\"\n labelTimeMutator <- getWidget castToLabel \"labelTimeMutator\"\n labelTimeGC <- getWidget castToLabel \"labelTimeGC\"\n labelTimeProductivity <- getWidget castToLabel \"labelTimeProductivity\"\n\n\n labelHeapMaxSize <- getHeapLabels \"labelHeapMaxSize\" \"labelHeapMaxSizeUnit\"\n \"labelHeapMaxSizeBytes\" \"labelHeapMaxSizeUnit1\"\n labelHeapMaxResidency <- getHeapLabels \"labelHeapMaxResidency\" \"labelHeapMaxResidencyUnit\"\n \"labelHeapMaxResidencyBytes\" \"labelHeapMaxResidencyUnit1\"\n labelHeapAllocTotal <- getHeapLabels \"labelHeapAllocTotal\" \"labelHeapAllocTotalUnit\"\n \"labelHeapAllocTotalBytes\" \"labelHeapAllocTotalUnit1\"\n labelHeapAllocRate <- getHeapLabels \"labelHeapAllocRate\" \"labelHeapAllocRateUnit\"\n \"labelHeapAllocRateBytes\" \"labelHeapAllocRateUnit1\"\n labelHeapMaxSlop <- getHeapLabels \"labelHeapMaxSlop\" \"labelHeapMaxSlopUnit\"\n \"labelHeapMaxSlopBytes\" \"labelHeapMaxSlopUnit1\"\n tableHeap <- getWidget castToWidget \"tableHeap\"\n\n labelGcCopied <- getHeapLabels \"labelGcCopied\" \"labelGcCopiedUnit\"\n \"labelGcCopiedBytes\" \"labelGcCopiedUnit1\"\n labelGcParWorkBalance <- getWidget castToLabel \"labelGcParWorkBalance\"\n storeGcStats <- listStoreNew []\n tableGc <- getWidget castToWidget \"tableGC\"\n\n storeSparkStats <- listStoreNew []\n\n let summaryView = SummaryView{..}\n\n treeviewGcStats <- getWidget castToTreeView \"treeviewGcStats\"\n Compat.treeViewSetModel treeviewGcStats (Just storeGcStats)\n let addGcColumn = addColumn treeviewGcStats storeGcStats\n addGcColumn \"Generation\" $ \\(GcStatsEntry gen _ _ _ _ _) ->\n [ cellText := if gen == -1 then \"GC Total\" else \"Gen \" ++ show gen ]\n addGcColumn \"Collections\" $ \\(GcStatsEntry _ colls _ _ _ _) ->\n [ cellText := show colls ]\n addGcColumn \"Par collections\" $ \\(GcStatsEntry _ _ pcolls _ _ _) ->\n [ cellText := show pcolls ]\n addGcColumn \"Elapsed time\" $ \\(GcStatsEntry _ _ _ time _ _) ->\n [ cellText := (printf \"%5.2fs\" (timeToSecondsDbl time) :: String) ]\n addGcColumn \"Avg pause\" $ \\(GcStatsEntry _ _ _ _ avgpause _) ->\n [ cellText := (printf \"%3.4fs\" avgpause :: String) ]\n addGcColumn \"Max pause\" $ \\(GcStatsEntry _ _ _ _ _ maxpause) ->\n [ cellText := (printf \"%3.4fs\" maxpause :: String) ]\n\n treeviewSparkStats <- getWidget castToTreeView \"treeviewSparkStats\"\n Compat.treeViewSetModel treeviewSparkStats (Just storeSparkStats)\n let addSparksColumn = addColumn treeviewSparkStats storeSparkStats\n addSparksColumn \"HEC\" $ \\(hec, _) ->\n [ cellText := if hec == -1 then \"Total\" else \"HEC \" ++ show hec ]\n addSparksColumn \"Total\" $ \\(_, SparkCounts total _ _ _ _ _) ->\n [ cellText := show total ]\n addSparksColumn \"Converted\" $ \\(_, SparkCounts _ conv _ _ _ _) ->\n [ cellText := show conv ]\n addSparksColumn \"Overflowed\" $ \\(_, SparkCounts _ _ ovf _ _ _) ->\n [ cellText := show ovf ]\n addSparksColumn \"Dud\" $ \\(_, SparkCounts _ _ _ dud _ _) ->\n [ cellText := show dud ]\n addSparksColumn \"GCed\" $ \\(_, SparkCounts _ _ _ _ gc _) ->\n [ cellText := show gc ]\n addSparksColumn \"Fizzled\" $ \\(_, SparkCounts _ _ _ _ _ fiz) ->\n [ cellText := show fiz ]\n\n return summaryView\n\n where\n addColumn view store title mkAttrs = do\n col <- treeViewColumnNew\n cell <- cellRendererTextNew\n treeViewColumnSetTitle col title\n treeViewColumnPackStart col cell False\n treeViewAppendColumn view col\n cellLayoutSetAttributes col cell store mkAttrs\n\n\n------------------------------------------------------------------------------\n\nsummaryViewSetEvents :: SummaryView -> Maybe (Array Int Event) -> IO ()\nsummaryViewSetEvents view@SummaryView{cacheEventsStats} Nothing = do\n writeIORef cacheEventsStats Nothing\n setSummaryStatsEmpty view\n\nsummaryViewSetEvents view@SummaryView{cacheEventsStats} (Just events) = do\n let stats = summaryStats events Nothing\n -- this is an almost certain indicator that there\n -- are no heap events in the eventlog:\n hasHeapEvents = heapMaxSize (summHeapStats stats) /= Just 0\n writeIORef cacheEventsStats (Just (events, stats, hasHeapEvents))\n setSummaryStats view stats hasHeapEvents\n\n\nsummaryViewSetInterval :: SummaryView -> Maybe Interval -> IO ()\nsummaryViewSetInterval view@SummaryView{cacheEventsStats} Nothing = do\n cache <- readIORef cacheEventsStats\n case cache of\n Nothing -> return ()\n Just (_, stats, hasHeap) -> setSummaryStats view stats hasHeap\n\nsummaryViewSetInterval view@SummaryView{cacheEventsStats} (Just interval) = do\n cache <- readIORef cacheEventsStats\n case cache of\n Nothing -> return ()\n Just (events, _, hasHeap) -> setSummaryStats view stats hasHeap\n where stats = summaryStats events (Just interval)\n\n------------------------------------------------------------------------------\n\nsetSummaryStats :: SummaryView -> SummaryStats -> Bool -> IO ()\nsetSummaryStats view SummaryStats{..} hasHeapEvents = do\n setTimeStats view summTimeStats\n if hasHeapEvents\n then do setHeapStatsAvailable view True\n setHeapStats view summHeapStats\n setGcStats view summGcStats\n else setHeapStatsAvailable view False\n setSparkStats view summSparkStats\n\nsetTimeStats :: SummaryView -> TimeStats -> IO ()\nsetTimeStats SummaryView{..} TimeStats{..} =\n mapM_ (\\(label, text) -> set label [ labelText := text ])\n [ (labelTimeTotal , showTimeWithUnit timeTotal)\n , (labelTimeMutator , showTimeWithUnit timeMutator)\n , (labelTimeGC , showTimeWithUnit timeGC)\n , (labelTimeProductivity, showFFloat (Just 1) (timeProductivity * 100) \"% of mutator vs total\")\n ]\n\nsetHeapStats :: SummaryView -> HeapStats -> IO ()\nsetHeapStats SummaryView{..} HeapStats{..} = do\n setHeapStatLabels labelHeapMaxSize heapMaxSize \"\" \"\"\n setHeapStatLabels labelHeapMaxResidency heapMaxResidency \"\" \"\"\n setHeapStatLabels labelHeapAllocTotal heapTotalAlloc \"\" \"\"\n setHeapStatLabels labelHeapAllocRate heapAllocRate \"/s\" \" per second (of mutator time)\"\n setHeapStatLabels labelHeapMaxSlop heapMaxSlop \"\" \"\"\n setHeapStatLabels labelGcCopied heapCopiedDuringGc \"\" \"\"\n where\n setHeapStatLabels labels stat unitSuffix unitSuffixLong =\n let texts = case stat of\n Nothing -> (\"N/A\", \"\", \"\", \"\")\n Just b -> ( formatBytesInUnit b u, formatUnit u ++ unitSuffix\n , formatBytes b, \"bytes\" ++ unitSuffixLong)\n where u = getByteUnit b\n in setLabels labels texts\n\n setLabels (short,shortunit,long,longunit) (short', shortunit', long', longunit') = do\n mapM_ (\\(label, text) -> set label [ labelText := text ])\n [ (short, short'), (shortunit, shortunit')\n , (long, long'), (longunit, longunit') ]\n\n\nsetGcStats :: SummaryView -> GcStats -> IO ()\nsetGcStats SummaryView{..} GcStats{..} = do\n let balText = maybe \"N/A\"\n (printf \"%.2f%% (serial 0%%, perfect 100%%)\")\n gcParWorkBalance\n set labelGcParWorkBalance [ labelText := balText ]\n listStoreClear storeGcStats\n mapM_ (listStoreAppend storeGcStats) (gcTotalStats:gcGenStats)\n\nsetSparkStats :: SummaryView -> SparkStats -> IO ()\nsetSparkStats SummaryView{..} SparkStats{..} = do\n listStoreClear storeSparkStats\n mapM_ (listStoreAppend storeSparkStats) ((-1,totalSparkStats):capSparkStats)\n\ndata ByteUnit = TiB | GiB | MiB | KiB | B deriving Show\n\nbyteUnitVal :: ByteUnit -> Word64\nbyteUnitVal TiB = 2^40\nbyteUnitVal GiB = 2^30\nbyteUnitVal MiB = 2^20\nbyteUnitVal KiB = 2^10\nbyteUnitVal B = 1\n\ngetByteUnit :: Word64 -> ByteUnit\ngetByteUnit b\n | b >= 2^40 = TiB\n | b >= 2^30 = GiB\n | b >= 2^20 = MiB\n | b >= 2^10 = KiB\n | otherwise = B\n\nformatBytesInUnit :: Word64 -> ByteUnit -> String\nformatBytesInUnit n u =\n formatFixed (fromIntegral n / fromIntegral (byteUnitVal u))\n where\n formatFixed x = showFFloat (Just 1) x \"\"\n\nformatUnit :: ByteUnit -> String\nformatUnit = show\n\nformatBytes :: Word64 -> String\nformatBytes b = ppWithCommas b\n\nppWithCommas :: Word64 -> String\nppWithCommas =\n let spl [] = []\n spl l = let (c3, cs) = L.splitAt 3 l\n in c3 : spl cs\n in L.reverse . L.intercalate \",\" . spl . L.reverse . show\n\nsetSummaryStatsEmpty :: SummaryView -> IO ()\nsetSummaryStatsEmpty SummaryView{..} = do\n mapM_ (\\label -> set label [ labelText := \"\"\n , widgetTooltipText\n := (Nothing :: Maybe String) ]) $\n [ labelTimeTotal, labelTimeMutator\n , labelTimeGC, labelTimeProductivity ] ++\n [ w\n | (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency\n , labelHeapAllocTotal, labelHeapAllocRate\n , labelHeapMaxSlop, labelGcCopied ]\n , w <- [ a,b,c,d] ]\n listStoreClear storeGcStats\n listStoreClear storeSparkStats\n\nsetHeapStatsAvailable :: SummaryView -> Bool -> IO ()\nsetHeapStatsAvailable SummaryView{..} available\n | available = do\n forM_ unavailableWidgets $ \\widget ->\n set widget [ widgetTooltipText := (Nothing :: Maybe String)\n , widgetSensitive := True ]\n\n | otherwise = do\n forM_ allLabels $ \\label -> set label [ labelText := \"\" ]\n listStoreClear storeGcStats\n\n forM_ unavailableLabels $ \\label ->\n set label [ labelText := \"(unavailable)\" ]\n\n forM_ unavailableWidgets $ \\widget ->\n set widget [ widgetTooltipText := Just msgInfoUnavailable, widgetSensitive := False ]\n\n where\n allLabels =\n [ labelTimeMutator, labelTimeGC\n , labelTimeProductivity, labelGcParWorkBalance ] ++\n [ w | (a,b,c,d) <- [ labelHeapMaxSize, labelHeapMaxResidency\n , labelHeapAllocTotal, labelHeapAllocRate\n , labelHeapMaxSlop, labelGcCopied ]\n , w <- [ a,b,c,d] ]\n unavailableLabels =\n [ labelTimeMutator, labelTimeGC\n , labelTimeProductivity, labelGcParWorkBalance\n , case labelGcCopied of (w,_,_,_) -> w ] ++\n [ c | (_,_,c,_) <- [ labelHeapMaxSize, labelHeapMaxResidency\n , labelHeapAllocTotal, labelHeapAllocRate\n , labelHeapMaxSlop ] ]\n unavailableWidgets = [ toWidget labelTimeMutator, toWidget labelTimeGC\n , toWidget labelTimeProductivity\n , tableHeap, tableGc ]\n msgInfoUnavailable = \"This eventlog does not contain heap or GC information.\"\n\n------------------------------------------------------------------------------\n-- Calculating the stats we want to display\n--\n\ndata SummaryStats = SummaryStats {\n summTimeStats :: TimeStats,\n summHeapStats :: HeapStats,\n summGcStats :: GcStats,\n summSparkStats :: SparkStats\n }\n\ndata TimeStats = TimeStats {\n timeTotal :: !Word64, -- we really should have a better type for elapsed time\n timeGC :: !Word64,\n timeMutator :: !Word64,\n timeProductivity :: !Double\n }\n\ndata HeapStats = HeapStats {\n heapMaxSize :: Maybe Word64,\n heapMaxResidency :: Maybe Word64,\n heapMaxSlop :: Maybe Word64,\n heapTotalAlloc :: Maybe Word64,\n heapAllocRate :: Maybe Word64,\n heapCopiedDuringGc :: Maybe Word64\n }\n\ndata GcStats = GcStats {\n gcNumThreads :: !Int,\n gcParWorkBalance :: !(Maybe Double),\n gcGenStats :: [GcStatsEntry],\n gcTotalStats :: !GcStatsEntry\n }\ndata GcStatsEntry = GcStatsEntry !Int !Int !Int !Word64 !Double !Double\n\ndata SparkStats = SparkStats {\n capSparkStats :: [(Cap, SparkCounts)],\n totalSparkStats :: !SparkCounts\n }\ndata SparkCounts = SparkCounts !Word64 !Word64 !Word64 !Word64 !Word64 !Word64\n\n\n-- | Take the events, and optionally some sub-range, and generate the summary\n-- stats for that range.\n--\n-- We take a two-step approach:\n-- * a single pass over the events, accumulating into an intermediate\n-- 'StatsAccum' record,\n-- * then look at that 'StatsAccum' record and construct the various final\n-- stats that we want to present.\n--\nsummaryStats :: Array Int Event -> Maybe Interval -> SummaryStats\nsummaryStats events minterval =\n SummaryStats {\n summHeapStats = hs,\n summGcStats = gs,\n summSparkStats = ss,\n summTimeStats = ts\n }\n where\n !statsAccum = accumStats events minterval\n\n gs = gcStats statsAccum\n ss = sparkStats statsAccum\n ts = timeStats events minterval gs\n hs = heapStats statsAccum ts\n\n\n-- | Linearly accumulate the stats from the events array,\n-- either the full thing or some sub-range.\naccumStats :: Array Int Event -> Maybe Interval -> StatsAccum\naccumStats events minterval =\n foldl' accumEvent start [ events ! i | i <- range eventsRange ]\n where\n eventsRange = selectEventRange events minterval\n\n -- If we're starting from time zero then we know many of the stats\n -- also start at from, where as from other points it's just unknown\n start | fst eventsRange == 0 = zeroStatsAccum\n | otherwise = emptyStatsAccum\n\n-- | Given the event array and a time interval, return the range of array\n-- indicies containing that interval. The Nothing interval means to select\n-- the whole array range.\n--\nselectEventRange :: Array Int Event -> Maybe Interval -> (Int, Int)\nselectEventRange arr Nothing = bounds arr\nselectEventRange arr (Just (start, end)) = (lbound, ubound)\n where\n !lbound = either snd id $ findArrayRange cmp arr start\n !ubound = either fst id $ findArrayRange cmp arr end\n cmp ts (Event ts' _ _) = compare ts ts'\n\n findArrayRange :: (key -> val -> Ordering)\n -> Array Int val -> key -> Either (Int,Int) Int\n findArrayRange cmp arr key =\n binarySearch a0 b0 key\n where\n (a0,b0) = bounds arr\n\n binarySearch a b key\n | a > b = Left (b,a)\n | otherwise = case cmp key (arr ! mid) of\n LT -> binarySearch a (mid-1) key\n EQ -> Right mid\n GT -> binarySearch (mid+1) b key\n where mid = (a + b) `div` 2\n\n------------------------------------------------------------------------------\n-- Final step where we convert from StatsAccum to various presentation forms\n\ntimeStats :: Array Int Event -> Maybe Interval -> GcStats -> TimeStats\ntimeStats events minterval\n GcStats { gcTotalStats = GcStatsEntry _ _ _ timeGC _ _ } =\n TimeStats {..}\n where\n timeTotal = intervalEnd - intervalStart\n timeMutator = timeTotal - timeGC\n timeProductivity = timeToSecondsDbl timeMutator\n / timeToSecondsDbl timeTotal\n\n (intervalStart, intervalEnd) =\n case minterval of\n Just (s,e) -> (s, e)\n Nothing -> (0, evTime (events ! ub))\n where\n (_lb, ub) = bounds events\n\n\nheapStats :: StatsAccum -> TimeStats -> HeapStats\nheapStats StatsAccum{..} TimeStats{timeMutator} =\n HeapStats {\n heapMaxSize = dmaxMemory,\n heapMaxResidency = dmaxResidency,\n heapMaxSlop = dmaxSlop,\n heapTotalAlloc = if totalAlloc == 0\n then Nothing\n else Just totalAlloc,\n heapAllocRate = if timeMutator == 0 || totalAlloc == 0\n then Nothing\n else Just $ truncate (fromIntegral totalAlloc / timeToSecondsDbl timeMutator),\n heapCopiedDuringGc = if dcopied == Just 0\n then Nothing\n else dcopied\n }\n where\n totalAlloc = sum [ end - start\n | (end,start) <- IM.elems dallocTable ]\n\n\ngcStats :: StatsAccum -> GcStats\ngcStats StatsAccum{..} =\n GcStats {\n gcNumThreads = nThreads,\n gcParWorkBalance,\n gcGenStats = [ mkGcStatsEntry gen (gcGather gen)\n | gen <- gens ],\n gcTotalStats = mkGcStatsEntry gcGenTot (gcGather gcGenTot)\n }\n where\n nThreads = fromMaybe 1 dmaxParNThreads\n\n gcParWorkBalance | nThreads <= 1\n || fromMaybe 0 dparMaxCopied <= 0 = Nothing\n | otherwise =\n Just $\n 100 * ((maybe 0 fromIntegral dparTotCopied\n / maybe 0 fromIntegral dparMaxCopied) - 1)\n / (fromIntegral nThreads - 1)\n\n gens = [0..maxGeneration]\n where\n -- Does not work for generationless GCs, but works reasonably\n -- for > 2 gens and perfectly for 2 gens.\n maxGeneration = maximum $ 1\n : [ maxGen\n | RtsGC { gcGenStat } <- IM.elems dGCTable\n , not (IM.null gcGenStat)\n , let (maxGen, _) = IM.findMax gcGenStat ]\n\n gcGather :: Gen -> GenStat\n gcGather gen = gcSum gen $ map gcGenStat $ IM.elems dGCTable\n -- TODO: Consider per-HEC display of GC stats and then use\n -- the values summed over all generations at key gcGenTot at each cap.\n\n gcSum :: Gen -> [IM.IntMap GenStat] -> GenStat\n gcSum gen l =\n GenStat (sumPr gcAll) (sumPr gcPar)\n (gcElapsed mainGen) (gcMaxPause mainGen)\n where\n l_genGC = map (IM.findWithDefault emptyGenStat gen) l\n sumPr proj = sum $ map proj l_genGC\n _maxPr proj = L.maximum $ map proj l_genGC\n _minPr proj = L.minimum $ filter (> 0) $ map proj l_genGC\n -- This would be the most balanced way of aggregating gcElapsed,\n -- if only the event times were accurate.\n _avgPr proj = let vs = filter (> 0) $ map proj l_genGC\n in sum vs `div` fromIntegral (length vs)\n -- But since the times include scheduling noise,\n -- we only use the times from the main cap for each GC\n -- and so get readings almost identical to +RTS -s.\n mainGen = IM.findWithDefault emptyGenStat gen mainStat\n\n mainStat = gcGenStat (fromMaybe (defaultGC 0) dGCMain)\n\n mkGcStatsEntry :: Gen -> GenStat -> GcStatsEntry\n mkGcStatsEntry gen GenStat{..} =\n GcStatsEntry gen gcAll gcPar gcElapsedS gcAvgPauseS gcMaxPauseS\n where\n gcElapsedS = gcElapsed\n gcMaxPauseS = timeToSecondsDbl gcMaxPause\n gcAvgPauseS\n | gcAll == 0 = 0\n | otherwise = timeToSeconds $\n fromIntegral gcElapsed / fromIntegral gcAll\n\n\nsparkStats :: StatsAccum -> SparkStats\nsparkStats StatsAccum{dsparkTable} =\n SparkStats {\n capSparkStats =\n [ (cap, mkSparkStats sparkCounts)\n | (cap, sparkCounts) <- capsSparkCounts ],\n\n totalSparkStats =\n mkSparkStats $\n foldl' (binopSparks (+)) zeroSparks\n [ sparkCounts | (_cap, sparkCounts) <- capsSparkCounts ]\n }\n where\n capsSparkCounts =\n [ (cap, sparkCounts)\n | (cap, (countsEnd, countsStart)) <- IM.assocs dsparkTable\n , let sparkCounts = binopSparks (-) countsEnd countsStart ]\n\n mkSparkStats RtsSpark {sparkCreated, sparkDud, sparkOverflowed,\n sparkConverted, sparkFizzled, sparkGCd} =\n -- in our final presentation we show the total created,\n -- and the breakdown of that into outcomes:\n SparkCounts (sparkCreated + sparkDud + sparkOverflowed)\n sparkConverted sparkOverflowed\n sparkDud sparkGCd sparkFizzled\n\n\n------------------------------------------------------------------------------\n\nshowTimeWithUnit :: Integral a => a -> String\nshowTimeWithUnit t =\n showFFloat (Just 3) t'' unit\n where\n (t'', unit) =\n case timeToSecondsDbl t of\n t' | t' < 1e-6 -> (t' / 1e-9, \"ns\")\n | t' < 1e-3 -> (t' / 1e-6, \"μs\")\n | t' < 1 -> (t' / 1e-3, \"ms\")\n | otherwise -> (t', \"s\")\n\ntimeToSecondsDbl :: Integral a => a -> Double\ntimeToSecondsDbl t = timeToSeconds $ fromIntegral t\n\ntimeToSeconds :: Double -> Double\ntimeToSeconds t = t / tIME_RESOLUTION\n where tIME_RESOLUTION = 1000000\n\n------------------------------------------------------------------------------\n-- The single-pass stats accumulation stuff\n--\n\n-- | Data collected and computed gradually while events are scanned.\ndata StatsAccum = StatsAccum\n { dallocTable :: !(IM.IntMap (Word64, Word64)) -- indexed by caps\n , dcopied :: !(Maybe Word64)\n , dmaxResidency :: !(Maybe Word64)\n , dmaxSlop :: !(Maybe Word64)\n , dmaxMemory :: !(Maybe Word64)\n--, dmaxFrag :: Maybe Word64 -- not important enough\n , dGCTable :: !(IM.IntMap RtsGC) -- indexed by caps\n -- Here we store the official +RTS -s timings of GCs,\n -- that is times aggregated from the main caps of all GCs.\n -- For now only gcElapsed and gcMaxPause are needed, so the rest\n -- of the fields stays at default values.\n , dGCMain :: !(Maybe RtsGC)\n , dparMaxCopied :: !(Maybe Word64)\n , dparTotCopied :: !(Maybe Word64)\n , dmaxParNThreads :: !(Maybe Int)\n--, dtaskTable -- of questionable usefulness, hard to get\n , dsparkTable :: !(IM.IntMap (RtsSpark, RtsSpark)) -- indexed by caps\n--, dInitExitT -- TODO. At least init time can be included in the total\n -- time registered in the eventlog. Can we measure this\n -- as the time between some initial events?\n--, dGCTime -- Is better computed after all events are scanned,\n -- e.g., because the same info can be used to calculate\n -- per-cap GCTime and other per-cap stats.\n--, dtotalTime -- TODO: can we measure this excluding INIT or EXIT times?\n }\n\ndata RtsSpark = RtsSpark\n { sparkCreated, sparkDud, sparkOverflowed\n , sparkConverted, sparkFizzled, sparkGCd :: !Word64\n }\n\nzeroSparks :: RtsSpark\nzeroSparks = RtsSpark 0 0 0 0 0 0\n\nbinopSparks :: (Word64 -> Word64 -> Word64) -> RtsSpark -> RtsSpark -> RtsSpark\nbinopSparks op (RtsSpark crt1 dud1 ovf1 cnv1 fiz1 gcd1)\n (RtsSpark crt2 dud2 ovf2 cnv2 fiz2 gcd2) =\n RtsSpark (crt1 `op` crt2) (dud1 `op` dud2) (ovf1 `op` ovf2)\n (cnv1 `op` cnv2) (fiz1 `op` fiz2) (gcd1 `op` gcd2)\n\ntype Gen = Int\n\ntype Cap = Int\n\ndata GcMode =\n ModeInit | ModeStart | ModeSync Cap | ModeGHC Cap Gen | ModeEnd | ModeIdle\n deriving Eq\n\ndata RtsGC = RtsGC\n { gcMode :: !GcMode\n , gcStartTime :: !Timestamp\n , gcGenStat :: !(IM.IntMap GenStat) -- indexed by generations\n }\n\n-- Index at the @gcGenStat@ map at which we store the sum of stats over all\n-- generations, or the single set of stats for non-genenerational GC models.\ngcGenTot :: Gen\ngcGenTot = -1\n\ndata GenStat = GenStat\n { -- Sum over all seqential and pararell GC invocations.\n gcAll :: !Int\n , -- Only parallel GCs. For GC models without stop-the-world par, always 0.\n gcPar :: !Int\n , gcElapsed :: !Timestamp\n , gcMaxPause :: !Timestamp\n }\n\nemptyStatsAccum :: StatsAccum\nemptyStatsAccum = StatsAccum\n { dallocTable = IM.empty\n , dcopied = Nothing\n , dmaxResidency = Nothing\n , dmaxSlop = Nothing\n , dmaxMemory = Nothing\n , dGCTable = IM.empty\n , dGCMain = Nothing\n , dparMaxCopied = Nothing\n , dparTotCopied = Nothing\n , dmaxParNThreads = Nothing\n , dsparkTable = IM.empty\n }\n\n-- | At the beginning of a program run, we know for sure several of the\n-- stats start at zero:\nzeroStatsAccum :: StatsAccum\nzeroStatsAccum = emptyStatsAccum {\n dcopied = Just 0,\n dmaxResidency = Just 0,\n dmaxSlop = Just 0,\n dmaxMemory = Just 0,\n dallocTable = -- a hack: we assume no more than 999 caps\n IM.fromDistinctAscList $ zip [0..999] $ repeat (0, 0)\n -- FIXME: but also, we should have a way to init to 0 for all caps.\n }\n\ndefaultGC :: Timestamp -> RtsGC\ndefaultGC time = RtsGC\n { gcMode = ModeInit\n , gcStartTime = time\n , gcGenStat = IM.empty\n }\n\nemptyGenStat :: GenStat\nemptyGenStat = GenStat\n { gcAll = 0\n , gcPar = 0\n , gcElapsed = 0\n , gcMaxPause = 0\n }\n\n-- Fail only when assertions are turned on.\nerrorAs :: String -> a -> a\nerrorAs msg a = assert (error msg) a\n\naccumEvent :: StatsAccum -> Event -> StatsAccum\naccumEvent !statsAccum ev =\n let -- For events that contain a counter with a running sum.\n -- Eventually we'll subtract the last found\n -- event from the first. Intervals beginning at time 0\n -- are a special case, because morally the first event should have\n -- value 0, but it may be absent, so we start with @Just (0, 0)@.\n alterCounter n Nothing = Just (n, n)\n alterCounter n (Just (_previous, first)) = Just (n, first)\n -- For events that contain discrete increments. We assume the event\n -- is emitted close to the end of the process it measures,\n -- so we ignore the first found event, because most of the process\n -- could have happened before the start of the current interval.\n -- This is consistent with @alterCounter@. For interval beginning\n -- at time 0, we start with @Just 0@.\n alterIncrement _ Nothing = Just 0\n alterIncrement n (Just k) = Just (k + n)\n -- For events that contain sampled values, where a max is sought.\n alterMax n Nothing = Just n\n alterMax n (Just k) | n > k = Just n\n alterMax _ jk = jk\n -- Scan events, updating summary data.\n scan !sd@StatsAccum{..} Event{evTime, evSpec, evCap} =\n let cap = fromMaybe (error \"Error: missing cap; use 'ghc-events validate' to verify the eventlog\") evCap\n capGC = IM.findWithDefault (defaultGC evTime) cap dGCTable\n in case evSpec of\n HeapAllocated{allocBytes} ->\n sd { dallocTable =\n IM.alter (alterCounter allocBytes) cap dallocTable }\n HeapLive{liveBytes} ->\n sd { dmaxResidency = alterMax liveBytes dmaxResidency}\n HeapSize{sizeBytes} ->\n sd { dmaxMemory = alterMax sizeBytes dmaxMemory}\n StartGC ->\n assert (gcMode capGC `elem` [ModeInit, ModeEnd, ModeIdle]) $\n let newGC = capGC { gcMode = ModeStart\n , gcStartTime = evTime\n }\n -- TODO: Index with generations, not caps?\n in sd { dGCTable = IM.insert cap newGC dGCTable }\n GlobalSyncGC ->\n -- All caps must be stopped. Those that take part in the GC\n -- are in ModeInit or ModeStart, those that do not\n -- are in ModeInit, ModeEnd or ModeIdle.\n assert (L.all (notModeGHCEtc . gcMode) (IM.elems dGCTable)) $\n sd { dGCTable = IM.mapWithKey setSync dGCTable }\n where\n notModeGHCEtc ModeGHC{} = False\n notModeGHCEtc ModeSync{} = False\n notModeGHCEtc _ = True\n someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable)\n setSync capKey dGC@RtsGC{gcGenStat}\n | someInit =\n -- If even one cap could possibly have started GC before\n -- the start of the selected interval, skip the GC on all caps.\n -- We don't verify the overwritten modes in this case.\n -- TODO: we could be smarter and defer the decision to EndGC,\n -- when we can deduce if the suspect caps take part in GC\n -- or not at all.\n dGC { gcMode = ModeInit }\n | otherwise =\n let totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat\n in case gcMode dGC of\n -- Cap takes part in the GC (not known if seq or par).\n -- Here is the moment where all caps taking place in the GC\n -- are identified and we can aggregate all their data\n -- at once (currently we just increment a counter for each).\n -- The EndGC events can come much later for some caps and at\n -- that time other caps are already inside their new GC.\n ModeStart ->\n dGC { gcMode = ModeSync cap\n , gcGenStat =\n if capKey == cap\n then IM.insert gcGenTot\n totGC{ gcAll = gcAll totGC + 1 }\n gcGenStat\n else gcGenStat\n }\n -- Cap is not in the GC. Mark it as idle to complete\n -- the identification of caps that take part\n -- in the current GC. Without overwriting the mode,\n -- the cap could be processed later on as if\n -- it took part in the GC, giving wrong results.\n ModeEnd -> dGC { gcMode = ModeIdle }\n ModeIdle -> dGC\n -- Impossible.\n ModeInit -> errorAs \"scanEvents: GlobalSyncGC ModeInit\" dGC\n ModeSync{} -> errorAs \"scanEvents: GlobalSyncGC ModeSync\" dGC\n ModeGHC{} -> -- error \"scanEvents: GlobalSyncGC ModeGHC\"\n dGC -- workaround for #46\n GCStatsGHC{..} ->\n -- All caps must be stopped. Those that take part in the GC\n -- are in ModeInit or ModeSync, those that do not\n -- are in ModeInit or ModeIdle.\n assert (L.all (notModeStartEtc . gcMode) (IM.elems dGCTable)) $\n sd { dcopied = alterIncrement copied dcopied -- sum over caps\n , dmaxSlop = alterMax slop dmaxSlop -- max over all caps\n , dGCTable = IM.mapWithKey setParSeq dGCTable\n , dparMaxCopied = alterIncrement parMaxCopied dparMaxCopied\n , dparTotCopied = alterIncrement parTotCopied dparTotCopied\n , dmaxParNThreads = alterMax parNThreads dmaxParNThreads\n }\n where\n notModeStartEtc ModeStart = False\n notModeStartEtc ModeGHC{} = False\n notModeStartEtc ModeEnd = False\n notModeStartEtc _ = True\n someInit = L.any ((== ModeInit) . gcMode) (IM.elems dGCTable)\n setParSeq capKey dGC@RtsGC{gcGenStat}\n | someInit =\n -- Just starting the selected interval, so skip the GC.\n dGC\n | otherwise =\n let genGC = IM.findWithDefault emptyGenStat gen gcGenStat\n totGC = IM.findWithDefault emptyGenStat gcGenTot gcGenStat\n in case gcMode dGC of\n -- Cap takes part in seq GC.\n ModeSync capSync | parNThreads == 1 ->\n assert (cap == capSync) $\n dGC { gcMode = ModeGHC cap gen\n , gcGenStat =\n -- Already inserted into gcGenTot in GlobalSyncGC,\n -- so only inserting into gen.\n if capKey == cap\n then IM.insert gen\n genGC{ gcAll = gcAll genGC + 1 }\n gcGenStat\n else gcGenStat\n }\n -- Cap takes part in par GC.\n ModeSync capSync ->\n assert (cap == capSync) $\n assert (parNThreads > 1) $\n dGC { gcMode = ModeGHC cap gen\n , gcGenStat =\n if capKey == cap\n then IM.insert gen\n genGC{ gcAll = gcAll genGC + 1\n , gcPar = gcPar genGC + 1\n }\n (IM.insert gcGenTot\n -- Already incremented gcAll in SyncGC.\n totGC{ gcPar = gcPar totGC + 1 }\n gcGenStat)\n else gcGenStat\n }\n -- Cap not in the current GC, leave it alone.\n ModeIdle -> dGC\n -- Impossible.\n ModeInit -> errorAs \"scanEvents: GCStatsGHC ModeInit\" dGC\n ModeGHC{} -> -- error \"scanEvents: GCStatsGHC ModeGHC\"\n dGC -- workaround for #46\n -- The last two cases are copied from case @GlobalSyncGC@\n -- to work around low-resolution timestamps (#35).\n -- Normally, these states would be impossible here, because\n -- @GlobalSyncGC@ would already transition away from these\n -- states. But if @GlobalSyncGC@ comes too early, the states\n -- can appear here. The computed stats are usually only\n -- slightly different than if @GlobalSyncGC@ made the state\n -- transitions, because the timestamps of @GCStatsGHC@\n -- and @GlobalSyncGC@ are normally only slightly different.\n --\n -- Cap takes part in the GC (not known if seq or par).\n -- Here is the moment where all caps taking place in the GC\n -- are identified and we can aggregate all their data\n -- at once (currently we just increment a counter for each).\n -- The EndGC events can come much later for some caps and at\n -- that time other caps are already inside their new GC.\n ModeStart ->\n dGC { gcMode = ModeSync cap\n , gcGenStat =\n if capKey == cap\n then IM.insert gcGenTot\n totGC{ gcAll = gcAll totGC + 1 }\n gcGenStat\n else gcGenStat\n }\n -- Cap is not in the GC. Mark it as idle to complete\n -- the identification of caps that take part\n -- in the current GC. Without overwriting the mode,\n -- the cap could be processed later on as if\n -- it took part in the GC, giving wrong results.\n ModeEnd -> dGC { gcMode = ModeIdle }\n EndGC ->\n assert (gcMode capGC `notElem` [ModeEnd, ModeIdle]) $\n let endedGC = capGC { gcMode = ModeEnd }\n duration = evTime - gcStartTime capGC\n timeGC gen gstat =\n let genGC =\n IM.findWithDefault emptyGenStat gen (gcGenStat gstat)\n newGenGC =\n genGC { gcElapsed = gcElapsed genGC + duration\n , gcMaxPause = max (gcMaxPause genGC) duration\n }\n in gstat { gcGenStat = IM.insert gen newGenGC\n (gcGenStat gstat) }\n timeGenTot = timeGC gcGenTot endedGC\n updateMainCap mainCap _ dgm | mainCap /= cap = dgm\n updateMainCap _ currentGen dgm =\n -- We are at the EndGC event of the main cap of current GC.\n -- The timings from this cap are the only that +RTS -s uses.\n -- We will record them in the dGCMain field to be able\n -- to display a look-alike of +RTS -s.\n timeGC currentGen dgm\n in case gcMode capGC of\n -- We don't know the exact timing of this GC started before\n -- the selected interval, so we skip it and clear its mode.\n ModeInit -> sd { dGCTable = IM.insert cap endedGC dGCTable }\n -- There is no GlobalSyncGC nor GCStatsGHC for this GC.\n -- Consequently, we can't determine the main cap,\n -- so skip it and and clear its mode.\n ModeStart -> sd { dGCTable = IM.insert cap endedGC dGCTable }\n -- There is no GCStatsGHC for this GC. Gather partial data.\n ModeSync mainCap ->\n let dgm = fromMaybe (defaultGC evTime) dGCMain\n mainGenTot = updateMainCap mainCap gcGenTot dgm\n in sd { dGCTable = IM.insert cap timeGenTot dGCTable\n , dGCMain = Just mainGenTot\n }\n -- All is known, so we update the times.\n ModeGHC mainCap gen ->\n let newTime = timeGC gen timeGenTot\n dgm = fromMaybe (defaultGC evTime) dGCMain\n mainGenTot = updateMainCap mainCap gcGenTot dgm\n newMain = updateMainCap mainCap gen mainGenTot\n in sd { dGCTable = IM.insert cap newTime dGCTable\n , dGCMain = Just newMain\n }\n ModeEnd -> errorAs \"scanEvents: EndGC ModeEnd\" sd\n ModeIdle -> errorAs \"scanEvents: EndGC ModeIdle\"\n $ sd { dGCTable = IM.insert cap endedGC dGCTable }\n SparkCounters crt dud ovf cnv fiz gcd _rem ->\n -- We are guaranteed the first spark counters event has all zeroes,\n -- do we don't need to rig the counters for maximal interval.\n let current = RtsSpark crt dud ovf cnv fiz gcd\n in sd { dsparkTable =\n IM.alter (alterCounter current) cap dsparkTable }\n _ -> sd\n in scan statsAccum ev\n" }, { "path": "GUI/Timeline/Activity.hs", "content": "module GUI.Timeline.Activity (\n renderActivity\n ) where\n\nimport GUI.Timeline.Render.Constants\n\nimport Events.HECs\nimport Events.EventTree\nimport Events.EventDuration\nimport GUI.Types\nimport GUI.ViewerColours\n\nimport Graphics.Rendering.Cairo\n\nimport Control.Monad\nimport Data.List\n\n-- ToDo:\n-- - we average over the slice, but the point is drawn at the beginning\n-- of the slice rather than in the middle.\n\n-----------------------------------------------------------------------------\n\nrenderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp\n -> Render ()\n\nrenderActivity ViewParameters{..} hecs start0 end0 = do\n let\n slice = ceiling (fromIntegral activity_detail * scaleValue)\n\n -- round the start time down, and the end time up, to a slice boundary\n start = (start0 `div` slice) * slice\n end = ((end0 + slice) `div` slice) * slice\n\n hec_profs = map (actProfile slice start end)\n (map (\\ (t, _, _) -> t) (hecTrees hecs))\n total_prof = map sum (transpose hec_profs)\n\n-- liftIO $ printf \"%s\\n\" (show (map length hec_profs))\n-- liftIO $ printf \"%s\\n\" (show (map (take 20) hec_profs))\n drawActivity hecs start end slice total_prof\n (if not bwMode then runningColour else black)\n\nactivity_detail :: Int\nactivity_detail = 4 -- in pixels\n\n-- for each timeslice, the amount of time spent in the mutator\n-- during that period.\nactProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp]\nactProfile slice start0 end0 t\n = {- trace (show flat) $ -} chopped\n\n where\n -- do an extra slice at both ends\n start = if start0 < slice then start0 else start0 - slice\n end = end0 + slice\n\n flat = flatten start t []\n chopped0 = chop 0 start flat\n\n chopped | start0 < slice = 0 : chopped0\n | otherwise = chopped0\n\n flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree]\n flatten _start DurationTreeEmpty rest = rest\n flatten start t@(DurationSplit s split e l r _run _) rest\n | e <= start = rest\n | end <= s = rest\n | start >= split = flatten start r rest\n | end <= split = flatten start l rest\n | e - s > slice = flatten start l $ flatten start r rest\n | otherwise = t : rest\n flatten _start t@(DurationTreeLeaf _) rest\n = t : rest\n\n chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp]\n chop sofar start _ts\n | start >= end = if sofar > 0 then [sofar] else []\n chop sofar start []\n = sofar : chop 0 (start+slice) []\n chop sofar start (t : ts)\n | e <= start\n = if sofar /= 0\n then error \"chop\"\n else chop sofar start ts\n | s >= start + slice\n = sofar : chop 0 (start + slice) (t : ts)\n | e > start + slice\n = (sofar + time_in_this_slice t) : chop 0 (start + slice) (t : ts)\n | otherwise\n = chop (sofar + time_in_this_slice t) start ts\n where\n (s, e)\n | DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev)\n | DurationSplit s _ e _ _ _run _ <- t = (s, e)\n\n mi = min (start + slice) e\n ma = max start s\n duration = if mi < ma then 0 else mi - ma\n\n time_in_this_slice t = case t of\n DurationTreeLeaf ThreadRun{} -> duration\n DurationTreeLeaf _ -> 0\n DurationSplit _ _ _ _ _ run _ ->\n round (fromIntegral (run * duration) / fromIntegral (e-s))\n DurationTreeEmpty -> error \"time_in_this_slice\"\n\ndrawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp]\n -> Color\n -> Render ()\ndrawActivity hecs start end slice ts color = do\n case ts of\n [] -> return ()\n t:ts -> do\n-- liftIO $ printf \"ts: %s\\n\" (show (t:ts))\n-- liftIO $ printf \"off: %s\\n\" (show (map off (t:ts) :: [Double]))\n let dstart = fromIntegral start\n dend = fromIntegral end\n dslice = fromIntegral slice\n dheight = fromIntegral activityGraphHeight\n\n-- funky gradients don't seem to work:\n-- withLinearPattern 0 0 0 dheight $ \\pattern -> do\n-- patternAddColorStopRGB pattern 0 0.8 0.8 0.8\n-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0\n-- rectangle dstart 0 dend dheight\n-- setSource pattern\n-- fill\n\n newPath\n moveTo (dstart-dslice/2) (off t)\n zipWithM_ lineTo (tail [dstart-dslice/2, dstart+dslice/2 ..]) (map off ts)\n setSourceRGBAhex black 1.0\n setLineWidth 1\n strokePreserve\n\n lineTo dend dheight\n lineTo dstart dheight\n setSourceRGBAhex color 1.0\n fill\n\n-- funky gradients don't seem to work:\n-- save\n-- withLinearPattern 0 0 0 dheight $ \\pattern -> do\n-- patternAddColorStopRGB pattern 0 0 1.0 0\n-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0\n-- setSource pattern\n-- -- identityMatrix\n-- -- setFillRule FillRuleEvenOdd\n-- fillPreserve\n-- restore\n\n save\n forM_ [0 .. hecCount hecs - 1] $ \\h -> do\n let y = fromIntegral (floor (fromIntegral h * dheight / fromIntegral (hecCount hecs))) - 0.5\n setSourceRGBAhex black 0.3\n moveTo dstart y\n lineTo dend y\n dashedLine1\n restore\n\n where\n off t = fromIntegral activityGraphHeight -\n fromIntegral (t * fromIntegral activityGraphHeight) /\n fromIntegral (fromIntegral (hecCount hecs) * slice)\n\n-- | Draw a dashed line along the current path.\ndashedLine1 :: Render ()\ndashedLine1 = do\n save\n identityMatrix\n let dash = fromIntegral ox\n setDash [dash, dash] 0.0\n setLineWidth 1\n stroke\n restore\n" }, { "path": "GUI/Timeline/CairoDrawing.hs", "content": "-------------------------------------------------------------------------------\n--- $Id: CairoDrawing.hs#3 2009/07/18 22:48:30 REDMOND\\\\satnams $\n--- $Source: //depot/satnams/haskell/ThreadScope/CairoDrawing.hs $\n-------------------------------------------------------------------------------\n\nmodule GUI.Timeline.CairoDrawing\nwhere\n\nimport Graphics.Rendering.Cairo\nimport qualified Graphics.Rendering.Cairo as C\nimport Control.Monad\n\n-------------------------------------------------------------------------------\n\n{-# INLINE draw_line #-}\ndraw_line :: (Integral a, Integral b, Integral c, Integral d) =>\n (a, b) -> (c, d) -> Render ()\ndraw_line (x0, y0) (x1, y1)\n = do move_to (x0, y0)\n lineTo (fromIntegral x1) (fromIntegral y1)\n stroke\n\n{-# INLINE move_to #-}\nmove_to :: (Integral a, Integral b) => (a, b) -> Render ()\nmove_to (x, y)\n = moveTo (fromIntegral x) (fromIntegral y)\n\n{-# INLINE rel_line_to #-}\nrel_line_to :: (Integral a, Integral b) => (a, b) -> Render ()\nrel_line_to (x, y)\n = relLineTo (fromIntegral x) (fromIntegral y)\n\n-------------------------------------------------------------------------------\n\n{-# INLINE draw_rectangle #-}\ndraw_rectangle :: (Integral x, Integral y, Integral w, Integral h)\n => x -> y -> w -> h\n -> Render ()\ndraw_rectangle x y w h = do\n rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)\n C.fill\n\n-------------------------------------------------------------------------------\n\n{-# INLINE draw_outlined_rectangle #-}\ndraw_outlined_rectangle :: (Integral x, Integral y, Integral w, Integral h)\n => x -> y -> w -> h\n -> Render ()\ndraw_outlined_rectangle x y w h = do\n rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)\n fillPreserve\n setLineWidth 1\n setSourceRGBA 0 0 0 0.7\n stroke\n\n-------------------------------------------------------------------------------\n\n{-# INLINE draw_rectangle_opt #-}\ndraw_rectangle_opt :: (Integral x, Integral y, Integral w, Integral h)\n => Bool -> x -> y -> w -> h\n -> Render ()\ndraw_rectangle_opt opt x y w h\n = draw_rectangle_opt' opt (fromIntegral x) (fromIntegral y)\n (fromIntegral w) (fromIntegral h)\n\ndraw_rectangle_opt' :: Bool -> Double -> Double -> Double -> Double\n -> Render ()\ndraw_rectangle_opt' opt x y w h\n = do rectangle x y (1.0 `max` w) h\n C.fill\n when opt $ do\n setLineWidth 1\n setSourceRGBA 0 0 0 0.7\n rectangle x y w h\n stroke\n\n-------------------------------------------------------------------------------\n\n{-# INLINE draw_rectangle_outline #-}\ndraw_rectangle_outline :: (Integral x, Integral y, Integral w, Integral h)\n => x -> y -> w -> h\n -> Render ()\ndraw_rectangle_outline x y w h = do\n setLineWidth 2\n rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)\n stroke\n\n-------------------------------------------------------------------------------\n\nclearWhite :: Render ()\nclearWhite = do\n save\n setOperator OperatorSource\n setSourceRGBA 0xffff 0xffff 0xffff 0xffff\n paint\n restore\n" }, { "path": "GUI/Timeline/HEC.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\nmodule GUI.Timeline.HEC (\n renderHEC,\n renderInstantHEC,\n ) where\n\nimport GUI.Timeline.Render.Constants\n\nimport Events.EventDuration\nimport Events.EventTree\nimport GUI.Timeline.CairoDrawing\nimport GUI.Types\nimport GUI.ViewerColours\n\nimport Graphics.Rendering.Cairo\n\nimport GHC.RTS.Events hiding (Event, GCIdle, GCWork)\nimport qualified GHC.RTS.Events as GHC\n\nimport Control.Monad\nimport qualified Data.IntMap as IM\nimport Data.Maybe\nimport Data.Monoid\nimport Data.Text (Text)\nimport qualified Data.Text as T\nimport qualified Data.Text.Lazy as TL\nimport qualified Data.Text.Lazy.Builder as TB\nimport qualified Data.Text.Lazy.Builder.Int as TB (decimal)\nimport Prelude\n\nrenderHEC :: ViewParameters -> Timestamp -> Timestamp\n -> IM.IntMap Text -> (DurationTree,EventTree)\n -> Render ()\nrenderHEC params@ViewParameters{..} start end perfNames (dtree,etree) = do\n renderDurations params start end dtree\n when (scaleValue < detailThreshold) $\n case etree of\n EventTree ltime etime tree -> do\n renderEvents params ltime etime start end (fromIntegral detail)\n perfNames tree\n return ()\n\nrenderInstantHEC :: ViewParameters -> Timestamp -> Timestamp\n -> IM.IntMap Text -> EventTree\n -> Render ()\nrenderInstantHEC params start end\n perfNames (EventTree ltime etime tree) = do\n let instantDetail = 1\n renderEvents params ltime etime start end instantDetail perfNames tree\n return ()\n\ndetailThreshold :: Double\ndetailThreshold = 3\n\n-------------------------------------------------------------------------------\n-- draws the trace for a single HEC\n\nrenderDurations :: ViewParameters\n -> Timestamp -> Timestamp -> DurationTree\n -> Render ()\n\nrenderDurations _ _ _ DurationTreeEmpty = return ()\n\nrenderDurations params startPos endPos (DurationTreeLeaf e)\n | inView startPos endPos e = drawDuration params e\n | otherwise = return ()\n\nrenderDurations params@ViewParameters{..} !startPos !endPos\n (DurationSplit s splitTime e lhs rhs runAv gcAv)\n | startPos < splitTime && endPos >= splitTime &&\n (fromIntegral (e - s) / scaleValue) <= fromIntegral detail\n = -- View spans both left and right sub-tree.\n -- trace (printf \"renderDurations (average): start:%d end:%d s:%d e:%d\" startPos endPos s e) $\n drawAverageDuration params s e runAv gcAv\n\n | otherwise\n = -- trace (printf \"renderDurations: start:%d end:%d s:%d e:%d\" startPos endPos s e) $\n do when (startPos < splitTime) $\n renderDurations params startPos endPos lhs\n when (endPos >= splitTime) $\n renderDurations params startPos endPos rhs\n\n-------------------------------------------------------------------------------\n\nrenderEvents :: ViewParameters\n -> Timestamp -- start time of this tree node\n -> Timestamp -- end time of this tree node\n -> Timestamp -> Timestamp -> Double\n -> IM.IntMap Text -> EventNode\n -> Render Bool\n\nrenderEvents params !_s !_e !startPos !endPos ewidth\n perfNames (EventTreeLeaf es)\n = let within = [ e | e <- es, let t = evTime e, t >= startPos && t < endPos ]\n untilTrue _ [] = return False\n untilTrue f (x : xs) = do\n b <- f x\n if b then return b else untilTrue f xs\n in untilTrue (drawEvent params ewidth perfNames) within\n\nrenderEvents params !_s !_e !startPos !endPos ewidth\n perfNames (EventTreeOne ev)\n | t >= startPos && t < endPos = drawEvent params ewidth perfNames ev\n | otherwise = return False\n where t = evTime ev\n\nrenderEvents params@ViewParameters{..} !s !e !startPos !endPos ewidth\n perfNames (EventSplit splitTime lhs rhs)\n | startPos < splitTime && endPos >= splitTime &&\n (fromIntegral (e - s) / scaleValue) <= ewidth\n = do drawnLhs <-\n renderEvents params s splitTime startPos endPos ewidth perfNames lhs\n if not drawnLhs\n then\n renderEvents params splitTime e startPos endPos ewidth perfNames rhs\n else return True\n | otherwise\n = do drawnLhs <-\n if startPos < splitTime\n then\n renderEvents params s splitTime startPos endPos ewidth perfNames lhs\n else return False\n drawnRhs <-\n if endPos >= splitTime\n then\n renderEvents params splitTime e startPos endPos ewidth perfNames rhs\n else return False\n return $ drawnLhs || drawnRhs\n\n-------------------------------------------------------------------------------\n-- An event is in view if it is not outside the view.\n\ninView :: Timestamp -> Timestamp -> EventDuration -> Bool\ninView viewStart viewEnd event =\n not (eStart > viewEnd || eEnd <= viewStart)\n where\n eStart = startTimeOf event\n eEnd = endTimeOf event\n\n-------------------------------------------------------------------------------\n\ndrawAverageDuration :: ViewParameters\n -> Timestamp -> Timestamp -> Timestamp -> Timestamp\n -> Render ()\ndrawAverageDuration ViewParameters{..} startTime endTime runAv gcAv = do\n setSourceRGBAhex (if not bwMode then runningColour else black) 1.0\n when (runAv > 0) $\n draw_rectangle startTime hecBarOff -- x, y\n (endTime - startTime) -- w\n hecBarHeight\n setSourceRGBAhex black 1.0\n --move_to (oxs + startTime, 0)\n --relMoveTo (4/scaleValue) 13\n --unscaledText scaleValue (show nrEvents)\n setSourceRGBAhex (if not bwMode then gcColour else black) gcRatio\n draw_rectangle startTime -- x\n (hecBarOff+hecBarHeight) -- y\n (endTime - startTime) -- w\n (hecBarHeight `div` 2) -- h\n\n where\n duration = endTime - startTime\n-- runRatio :: Double\n-- runRatio = (fromIntegral runAv) / (fromIntegral duration)\n gcRatio :: Double\n gcRatio = (fromIntegral gcAv) / (fromIntegral duration)\n\n-------------------------------------------------------------------------------\n\nunscaledText :: String -> Render ()\nunscaledText text\n = do m <- getMatrix\n identityMatrix\n showText text\n setMatrix m\n\n-------------------------------------------------------------------------------\n\ntextWidth :: Double -> String -> Render TextExtents\ntextWidth _scaleValue text\n = do m <- getMatrix\n identityMatrix\n tExtent <- textExtents text\n setMatrix m\n return tExtent\n\n-------------------------------------------------------------------------------\n\ndrawDuration :: ViewParameters -> EventDuration -> Render ()\ndrawDuration ViewParameters{..} (ThreadRun t s startTime endTime) = do\n setSourceRGBAhex (if not bwMode then runningColour else black) 1.0\n setLineWidth (1/scaleValue)\n draw_rectangle_opt False\n startTime -- x\n hecBarOff -- y\n (endTime - startTime) -- w\n hecBarHeight -- h\n -- Optionally label the bar with the threadID if there is room\n tExtent <- textWidth scaleValue tStr\n let tw = textExtentsWidth tExtent\n th = textExtentsHeight tExtent\n when (tw + 6 < fromIntegral rectWidth) $ do\n setSourceRGBAhex labelTextColour 1.0\n move_to (fromIntegral startTime + truncate (4*scaleValue),\n hecBarOff + (hecBarHeight + round th) `quot` 2)\n unscaledText tStr\n\n -- Optionally write the reason for the thread being stopped\n -- depending on the zoom value\n labelAt labelsMode endTime $\n T.pack $ show t ++ \" \" ++ showThreadStopStatus s\n where\n rectWidth = truncate (fromIntegral (endTime - startTime) / scaleValue) -- as pixels\n tStr = show t\n\ndrawDuration ViewParameters{..} (GCStart startTime endTime)\n = gcBar (if bwMode then black else gcStartColour) startTime endTime\n\ndrawDuration ViewParameters{..} (GCWork startTime endTime)\n = gcBar (if bwMode then black else gcWorkColour) startTime endTime\n\ndrawDuration ViewParameters{..} (GCIdle startTime endTime)\n = gcBar (if bwMode then black else gcIdleColour) startTime endTime\n\ndrawDuration ViewParameters{..} (GCEnd startTime endTime)\n = gcBar (if bwMode then black else gcEndColour) startTime endTime\n\ngcBar :: Color -> Timestamp -> Timestamp -> Render ()\ngcBar col !startTime !endTime = do\n setSourceRGBAhex col 1.0\n draw_rectangle_opt False\n startTime -- x\n (hecBarOff+hecBarHeight) -- y\n (endTime - startTime) -- w\n (hecBarHeight `div` 2) -- h\n\nlabelAt :: Bool -> Timestamp -> Text -> Render ()\nlabelAt labelsMode t str\n | not labelsMode = return ()\n | otherwise = do\n setSourceRGB 0.0 0.0 0.0\n move_to (t, hecBarOff+hecBarHeight+12)\n save\n identityMatrix\n rotate (pi/4)\n showText str\n restore\n\ndrawEvent :: ViewParameters -> Double -> IM.IntMap Text -> GHC.Event\n -> Render Bool\ndrawEvent params ewidth perfNames event =\n let renderI = renderInstantEvent params perfNames event ewidth\n in case evSpec event of\n CreateThread{} -> renderI createThreadColour\n RequestSeqGC{} -> renderI seqGCReqColour\n RequestParGC{} -> renderI parGCReqColour\n MigrateThread{} -> renderI migrateThreadColour\n WakeupThread{} -> renderI threadWakeupColour\n Shutdown{} -> renderI shutdownColour\n\n SparkCreate{} -> renderI createdConvertedColour\n SparkDud{} -> renderI fizzledDudsColour\n SparkOverflow{} -> renderI overflowedColour\n SparkRun{} -> renderI createdConvertedColour\n SparkSteal{} -> renderI createdConvertedColour\n SparkFizzle{} -> renderI fizzledDudsColour\n SparkGC{} -> renderI gcColour\n\n UserMessage{} -> renderI userMessageColour\n\n PerfCounter{} -> renderI createdConvertedColour\n PerfTracepoint{} -> renderI shutdownColour\n PerfName{} -> return False\n\n RunThread{} -> return False\n StopThread{} -> return False\n StartGC{} -> return False\n\n _ -> return False\n\nrenderInstantEvent :: ViewParameters -> IM.IntMap Text -> GHC.Event\n -> Double -> Color\n -> Render Bool\nrenderInstantEvent ViewParameters{..} perfNames event ewidth color = do\n setSourceRGBAhex color 1.0\n setLineWidth (ewidth * scaleValue)\n let t = evTime event\n draw_line (t, hecBarOff-4) (t, hecBarOff+hecBarHeight+4)\n let numToLabel :: EventInfo -> Maybe Text\n numToLabel PerfCounter{perfNum, period} | period == 0 =\n IM.lookup (fromIntegral perfNum) perfNames\n numToLabel PerfCounter{perfNum, period} = do\n name <- IM.lookup (fromIntegral perfNum) perfNames\n return $ toText $\n TB.fromText name <> \" <\" <> TB.decimal (period + 1) <> \" times>\"\n numToLabel PerfTracepoint{perfNum} = do\n name <- IM.lookup (fromIntegral perfNum) perfNames\n return $ toText $ \"tracepoint: \" <> TB.fromText name\n numToLabel _ = Nothing\n showLabel espec = fromMaybe (toText $ buildEventInfo espec) (numToLabel espec)\n labelAt labelsMode t $ showLabel (evSpec event)\n return True\n where\n toText = TL.toStrict . TB.toLazyText\n\n-------------------------------------------------------------------------------\n" }, { "path": "GUI/Timeline/Motion.hs", "content": "module GUI.Timeline.Motion (\n zoomIn, zoomOut, zoomToFit,\n scrollLeft, scrollRight, scrollToBeginning, scrollToEnd, scrollTo, centreOnCursor,\n vscrollDown, vscrollUp,\n ) where\n\nimport GUI.Timeline.Types\nimport GUI.Timeline.Sparks\nimport Events.HECs\n\nimport Graphics.UI.Gtk\n\nimport Data.IORef\nimport Control.Monad\n-- import Text.Printf\n-- import Debug.Trace\n\n-------------------------------------------------------------------------------\n-- Zoom in works by expanding the current view such that the\n-- left hand edge of the original view remains at the same\n-- position and the zoom in factor is 2.\n-- For example, zoom into the time range 1.0 3.0\n-- produces a new view with the time range 1.0 2.0\n\nzoomIn :: TimelineState -> Timestamp -> IO ()\nzoomIn = zoom (/2)\n\nzoomOut :: TimelineState -> Timestamp -> IO ()\nzoomOut = zoom (*2)\n\nzoom :: (Double -> Double) -> TimelineState -> Timestamp -> IO ()\nzoom factor TimelineState{timelineAdj, scaleIORef} cursor = do\n scaleValue <- readIORef scaleIORef\n -- TODO: we'd need HECs, as below, to fit maxScale to graphs at hand\n let maxScale = 10000000000 -- big enough for hours of eventlogs\n clampedFactor =\n if factor scaleValue < 0.2 || factor scaleValue > maxScale\n then id\n else factor\n newScaleValue = clampedFactor scaleValue\n writeIORef scaleIORef newScaleValue\n\n hadj_value <- adjustmentGetValue timelineAdj\n hadj_pagesize <- adjustmentGetPageSize timelineAdj -- Get size of bar\n\n let newPageSize = clampedFactor hadj_pagesize\n adjustmentSetPageSize timelineAdj newPageSize\n\n let cursord = fromIntegral cursor\n when (cursord >= hadj_value && cursord < hadj_value + hadj_pagesize) $\n adjustmentSetValue timelineAdj $\n cursord - clampedFactor (cursord - hadj_value)\n\n let pageshift = 0.9 * newPageSize\n let nudge = 0.1 * newPageSize\n\n adjustmentSetStepIncrement timelineAdj nudge\n adjustmentSetPageIncrement timelineAdj pageshift\n\n-------------------------------------------------------------------------------\n\nzoomToFit :: TimelineState -> Maybe HECs -> IO ()\nzoomToFit TimelineState{scaleIORef, maxSpkIORef,timelineAdj,\n timelineDrawingArea} mb_hecs = do\n case mb_hecs of\n Nothing -> return ()\n Just hecs -> do\n let lastTx = hecLastEventTime hecs\n upper = fromIntegral lastTx\n lower = 0\n Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea\n let newScaleValue = upper / fromIntegral w\n (sliceAll, profAll) = treesProfile newScaleValue 0 lastTx hecs\n -- TODO: verify that no empty lists possible below\n maxmap l = maximum (0 : map (maxSparkRenderedValue sliceAll) l)\n maxAll = map maxmap profAll\n newMaxSpkValue = maximum (0 : maxAll)\n\n writeIORef scaleIORef newScaleValue\n writeIORef maxSpkIORef newMaxSpkValue\n\n -- Configure the horizontal scrollbar units to correspond to micro-secs.\n adjustmentSetLower timelineAdj lower\n adjustmentSetValue timelineAdj lower\n adjustmentSetUpper timelineAdj upper\n adjustmentSetPageSize timelineAdj upper\n -- TODO: this seems suspicious:\n adjustmentSetStepIncrement timelineAdj 0\n adjustmentSetPageIncrement timelineAdj 0\n\n-------------------------------------------------------------------------------\n\nscrollLeft, scrollRight, scrollToBeginning, scrollToEnd :: TimelineState -> IO ()\n\nscrollLeft = scroll (\\val page l _ -> l `max` (val - page/2))\nscrollRight = scroll (\\val page _ u -> (u - page) `min` (val + page/2))\nscrollToBeginning = scroll (\\_ _ l _ -> l)\nscrollToEnd = scroll (\\_ _ _ u -> u)\n\nscrollTo :: TimelineState -> Double -> IO ()\nscrollTo s x = scroll (\\_ _ _ _ -> x) s\n\ncentreOnCursor :: TimelineState -> Timestamp -> IO ()\n\ncentreOnCursor state cursor =\n scroll (\\_ page l _u -> max l (fromIntegral cursor - page/2)) state\n\nscroll :: (Double -> Double -> Double -> Double -> Double)\n -> TimelineState -> IO ()\nscroll adjust TimelineState{timelineAdj} = do\n hadj_value <- adjustmentGetValue timelineAdj\n hadj_pagesize <- adjustmentGetPageSize timelineAdj\n hadj_lower <- adjustmentGetLower timelineAdj\n hadj_upper <- adjustmentGetUpper timelineAdj\n let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper\n newValue' = max hadj_lower (min (hadj_upper - hadj_pagesize) newValue)\n adjustmentSetValue timelineAdj newValue'\n\nvscrollDown, vscrollUp :: TimelineState -> IO ()\nvscrollDown = vscroll (\\val page _l u -> (u - page) `min` (val + page/8))\nvscrollUp = vscroll (\\val page l _u -> l `max` (val - page/8))\n\nvscroll :: (Double -> Double -> Double -> Double -> Double)\n -> TimelineState -> IO ()\nvscroll adjust TimelineState{timelineVAdj} = do\n hadj_value <- adjustmentGetValue timelineVAdj\n hadj_pagesize <- adjustmentGetPageSize timelineVAdj\n hadj_lower <- adjustmentGetLower timelineVAdj\n hadj_upper <- adjustmentGetUpper timelineVAdj\n let newValue = adjust hadj_value hadj_pagesize hadj_lower hadj_upper\n adjustmentSetValue timelineVAdj newValue\n adjustmentValueChanged timelineVAdj\n\n-- -----------------------------------------------------------------------------\n" }, { "path": "GUI/Timeline/Render/Constants.hs", "content": "module GUI.Timeline.Render.Constants (\n ox, firstTraceY, tracePad,\n hecTraceHeight, hecInstantHeight, hecSparksHeight,\n hecBarOff, hecBarHeight, hecLabelExtra,\n activityGraphHeight, stdHistogramHeight, histXScaleHeight,\n ticksHeight, ticksPad\n ) where\n\n-------------------------------------------------------------------------------\n\n-- The standard gap in various graphs\n\nox :: Int\nox = 10\n\n-- Origin for traces\n\nfirstTraceY :: Int\nfirstTraceY = 13\n\n-- Gap between traces in the timeline view\n\ntracePad :: Int\ntracePad = 20\n\n-- HEC bar height\n\nhecTraceHeight, hecInstantHeight, hecBarHeight, hecBarOff, hecLabelExtra :: Int\n\nhecTraceHeight = 40\nhecInstantHeight = 25\nhecBarHeight = 20\nhecBarOff = 10\n\n-- extra space to allow between HECs when labels are on.\n-- ToDo: should be calculated somehow\nhecLabelExtra = 80\n\n-- Activity graph\n\nactivityGraphHeight :: Int\nactivityGraphHeight = 100\n\n-- Height of the spark graphs.\nhecSparksHeight :: Int\nhecSparksHeight = activityGraphHeight\n\n-- Histogram graph height when displayed with other traces (e.g., in PNG/PDF).\nstdHistogramHeight :: Int\nstdHistogramHeight = hecSparksHeight\n\n-- The X scale of histogram has this constant height, as opposed\n-- to the timeline X scale, which takes its height from the .ui file.\nhistXScaleHeight :: Int\nhistXScaleHeight = 30\n\n-- Ticks\n\nticksHeight :: Int\nticksHeight = 20\n\nticksPad :: Int\nticksPad = 20\n" }, { "path": "GUI/Timeline/Render.hs", "content": "{-# LANGUAGE CPP #-}\nmodule GUI.Timeline.Render (\n renderView,\n renderTraces,\n updateXScaleArea,\n renderYScaleArea,\n updateYScaleArea,\n calculateTotalTimelineHeight,\n toWholePixels,\n ) where\n\nimport GUI.Timeline.Types\nimport GUI.Timeline.Render.Constants\nimport GUI.Timeline.Ticks\nimport GUI.Timeline.HEC\nimport GUI.Timeline.Sparks\nimport GUI.Timeline.Activity\n\nimport Events.HECs\nimport GUI.Types\nimport GUI.ViewerColours\nimport GUI.Timeline.CairoDrawing\n\nimport Graphics.UI.Gtk hiding (rectangle)\nimport Graphics.Rendering.Cairo\n ( Render\n , Content(..)\n , Operator(..)\n , Surface\n , liftIO\n , withTargetSurface\n , createSimilarSurface\n , renderWith\n , surfaceFinish\n , clip\n , setSourceSurface\n , setOperator\n , paint\n , setLineWidth\n , moveTo\n , lineTo\n , stroke\n , rectangle\n , fill\n , save\n , scale\n , translate\n , restore\n , setSourceRGBA\n )\n\nimport Data.IORef\nimport Control.Monad\nimport qualified Data.Text as T\n\nimport qualified Graphics.UI.Gtk.Cairo as C\n\n-------------------------------------------------------------------------------\n\n-- | This function redraws the currently visible part of the\n-- main trace canvas plus related canvases.\n--\nrenderView :: TimelineState\n -> ViewParameters\n -> HECs -> TimeSelection -> [Timestamp]\n -> Rectangle -> IO ()\nrenderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView}\n params hecs selection bookmarks rect = do\n\n -- Get state information from user-interface components\n Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea\n vadj_value <- adjustmentGetValue timelineVAdj\n\n prev_view <- readIORef timelinePrevView\n\n -- TODO: get rid of this Just\n Just win <- widgetGetWindow timelineDrawingArea\n renderWithDrawWindow win $ do\n\n let renderToNewSurface = do\n new_surface <- withTargetSurface $ \\surface ->\n liftIO $ createSimilarSurface surface ContentColor w (height params)\n renderWith new_surface $ do\n clearWhite\n renderTraces params hecs rect\n return new_surface\n\n surface <-\n case prev_view of\n Nothing -> renderToNewSurface\n\n Just (old_params, surface)\n | old_params == params\n -> return surface\n\n | width old_params == width params &&\n height old_params == height params\n -> do\n if old_params { hadjValue = hadjValue params } == params\n -- only the hadjValue changed\n && abs (hadjValue params - hadjValue old_params) <\n fromIntegral (width params) * scaleValue params\n -- and the views overlap...\n then\n scrollView surface old_params params hecs\n else do\n renderWith surface $ do\n clearWhite; renderTraces params hecs rect\n return surface\n\n | otherwise\n -> do surfaceFinish surface\n renderToNewSurface\n\n liftIO $ writeIORef timelinePrevView (Just (params, surface))\n\n C.rectangle rect\n clip\n setSourceSurface surface 0 (-vadj_value)\n -- ^^ this is where we adjust for the vertical scrollbar\n setOperator OperatorSource\n paint\n renderBookmarks bookmarks params\n drawSelection params selection\n\n-------------------------------------------------------------------------------\n\n-- Render the bookmarks\nrenderBookmarks :: [Timestamp] -> ViewParameters -> Render ()\nrenderBookmarks bookmarks vp@ViewParameters{height} = do\n setLineWidth 1\n setSourceRGBAhex bookmarkColour 1.0\n sequence_\n [ do moveTo x 0\n lineTo x (fromIntegral height)\n stroke\n | bookmark <- bookmarks\n , let x = timestampToView vp bookmark ]\n\n-------------------------------------------------------------------------------\n\ndrawSelection :: ViewParameters -> TimeSelection -> Render ()\ndrawSelection vp@ViewParameters{height} (PointSelection x) = do\n setLineWidth 3\n setOperator OperatorOver\n setSourceRGBAhex blue 1.0\n moveTo xv 0\n lineTo xv (fromIntegral height)\n stroke\n where\n xv = timestampToView vp x\n\ndrawSelection vp@ViewParameters{height} (RangeSelection x x') = do\n setLineWidth 1.5\n setOperator OperatorOver\n\n setSourceRGBAhex blue 0.25\n rectangle xv 0 (xv' - xv) (fromIntegral height)\n fill\n\n setSourceRGBAhex blue 1.0\n moveTo xv 0\n lineTo xv (fromIntegral height)\n moveTo xv' 0\n lineTo xv' (fromIntegral height)\n stroke\n where\n xv = timestampToView vp x\n xv' = timestampToView vp x'\n\n-------------------------------------------------------------------------------\n\n-- We currently have two different way of converting from logical units\n-- (i.e. timestamps in micro-seconds) to device units (i.e. pixels):\n-- * the first is to set the cairo context to the appropriate scale\n-- * the second is to do the conversion ourself\n--\n-- While in principle the first is superior due to the simplicity: cairo\n-- lets us use Double as the logical unit and scaling factor. In practice\n-- however cairo does not support the full Double range because internally\n-- it makes use of a 32bit fixed point float format. With very large scaling\n-- factors we end up with artifacts like lines disappearing.\n--\n-- So sadly we will probably have to convert to using the second method.\n\n-- | Use cairo to convert from logical units (timestamps) to device units\n--\nwithViewScale :: ViewParameters -> Render () -> Render ()\nwithViewScale ViewParameters{scaleValue, hadjValue} inner = do\n save\n scale (1/scaleValue) 1.0\n translate (-hadjValue) 0\n inner\n restore\n\n-- | Manually convert from logical units (timestamps) to device units.\n--\ntimestampToView :: ViewParameters -> Timestamp -> Double\ntimestampToView ViewParameters{scaleValue, hadjValue} ts =\n (fromIntegral ts - hadjValue) / scaleValue\n\n-------------------------------------------------------------------------------\n-- This function draws the current view of all the HECs with Cairo.\n\nrenderTraces :: ViewParameters -> HECs -> Rectangle\n -> Render ()\nrenderTraces params@ViewParameters{..} hecs (Rectangle rx _ry rw _rh) = do\n let scale_rx = fromIntegral rx * scaleValue\n scale_rw = fromIntegral rw * scaleValue\n scale_width = fromIntegral width * scaleValue\n\n startPos :: Timestamp\n startPos = fromIntegral $ truncate (scale_rx + hadjValue)\n\n endPos :: Timestamp\n endPos = minimum [\n ceiling (hadjValue + scale_width),\n ceiling (hadjValue + scale_rx + scale_rw),\n hecLastEventTime hecs\n ]\n\n -- For spark traces, round the start time down, and the end time up,\n -- to a slice boundary:\n start = (startPos `div` slice) * slice\n end = ((endPos + slice) `div` slice) * slice\n (slice, prof) = treesProfile scaleValue start end hecs\n\n withViewScale params $ do\n -- Render the vertical rulers across all the traces.\n renderVRulers scaleValue startPos endPos height XScaleTime\n\n -- This function helps to render a single HEC.\n -- Traces are rendered even if the y-region falls outside visible area.\n -- OTOH, trace rendering function tend to drawn only the visible\n -- x-region of the graph.\n let renderTrace trace y = do\n save\n translate 0 (fromIntegral y)\n case trace of\n TraceHEC c ->\n let (dtree, etree, _) = hecTrees hecs !! c\n in renderHEC params startPos endPos\n (perfNames hecs) (dtree, etree)\n TraceInstantHEC c ->\n let (_, etree, _) = hecTrees hecs !! c\n in renderInstantHEC params startPos endPos\n (perfNames hecs) etree\n TraceCreationHEC c ->\n renderSparkCreation params slice start end (prof !! c)\n TraceConversionHEC c ->\n renderSparkConversion params slice start end (prof !! c)\n TracePoolHEC c ->\n let maxP = maxSparkPool hecs\n in renderSparkPool slice start end (prof !! c) maxP\n TraceHistogram ->\n renderSparkHistogram params hecs\n TraceGroup _ -> error \"renderTrace\"\n TraceActivity ->\n renderActivity params hecs startPos endPos\n restore\n histTotalHeight = histogramHeight + histXScaleHeight\n -- Now render all the HECs.\n zipWithM_ renderTrace viewTraces\n (traceYPositions labelsMode histTotalHeight viewTraces)\n\n-------------------------------------------------------------------------------\n\n-- parameters differ only in the hadjValue, we can scroll ...\nscrollView :: Surface\n -> ViewParameters -> ViewParameters\n -> HECs\n -> Render Surface\nscrollView surface old new hecs = do\n-- scrolling on the same surface seems not to work, I get garbled results.\n-- Not sure what the best way to do this is.\n-- let new_surface = surface\n new_surface <- withTargetSurface $ \\surface ->\n liftIO $ createSimilarSurface surface ContentColor\n (width new) (height new)\n\n renderWith new_surface $ do\n let scale = scaleValue new\n old_hadj = hadjValue old\n new_hadj = hadjValue new\n w = fromIntegral (width new)\n h = fromIntegral (height new)\n off = (old_hadj - new_hadj) / scale\n\n-- liftIO $ printf \"scrollView: old: %f, new %f, dist = %f (%f pixels)\\n\"\n-- old_hadj new_hadj (old_hadj - new_hadj) off\n\n -- copy the content from the old surface to the new surface,\n -- shifted by the appropriate amount.\n setSourceSurface surface off 0\n if old_hadj > new_hadj\n then rectangle off 0 (w - off) h -- scroll right.\n else rectangle 0 0 (w + off) h -- scroll left.\n fill\n\n let rect | old_hadj > new_hadj\n = Rectangle 0 0 (ceiling off) (height new)\n | otherwise\n = Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new)\n\n case rect of\n Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y)\n (fromIntegral w) (fromIntegral h)\n setSourceRGBA 0xffff 0xffff 0xffff 0xffff\n fill\n\n renderTraces new hecs rect\n\n surfaceFinish surface\n return new_surface\n\n--------------------------------------------------------------------------------\n\n-- | Update the X scale widget, based on the state of all timeline areas.\n-- For simplicity, unlike for the traces, we redraw the whole area\n-- and not only the newly exposed area. This is comparatively very cheap.\nupdateXScaleArea :: TimelineState -> Timestamp -> IO ()\nupdateXScaleArea TimelineState{..} lastTx = do\n -- TODO: get rid of this Just\n Just win <- widgetGetWindow timelineXScaleArea\n Rectangle _ _ width _ <- widgetGetAllocation timelineDrawingArea\n Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea\n scaleValue <- readIORef scaleIORef\n -- Snap the view to whole pixels, to avoid blurring.\n hadjValue0 <- adjustmentGetValue timelineAdj\n let hadjValue = toWholePixels scaleValue hadjValue0\n off y = y + xScaleAreaHeight - 17\n renderWithDrawWindow win $\n renderXScale scaleValue hadjValue lastTx width off XScaleTime\n return ()\n\n--------------------------------------------------------------------------------\n\n-- | Render the Y scale area (an axis, ticks and a label for each graph),\n-- based on view parameters and hecs.\nrenderYScaleArea :: ViewParameters -> HECs -> DrawingArea -> Render ()\nrenderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces,\n histogramHeight, minterval}\n hecs yScaleArea = do\n let maxP = maxSparkPool hecs\n maxH = fromIntegral $ maxYHistogram hecs\n Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea\n drawYScaleArea\n maxSpkValue maxP maxH minterval (fromIntegral xoffset) 0\n labelsMode histogramHeight viewTraces yScaleArea\n\n-- | Update the Y scale widget, based on the state of all timeline areas\n-- and on traces (only for graph labels and relative positions).\nupdateYScaleArea :: TimelineState -> Double -> Double -> Maybe Interval\n -> Bool -> [Trace] -> IO ()\nupdateYScaleArea TimelineState{..} maxSparkPool maxYHistogram minterval\n labelsMode traces = do\n -- TODO: get rid of this Just\n Just win <- widgetGetWindow timelineYScaleArea\n maxSpkValue <- readIORef maxSpkIORef\n vadj_value <- adjustmentGetValue timelineVAdj\n Rectangle _ _ xoffset _ <- widgetGetAllocation timelineYScaleArea\n renderWithDrawWindow win $\n drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval\n (fromIntegral xoffset) vadj_value labelsMode stdHistogramHeight traces\n timelineYScaleArea\n\n-- | Render the Y scale area, by rendering an axis, ticks and a label\n-- for each graph-like trace in turn (and only labels for other traces).\ndrawYScaleArea :: Double -> Double -> Double -> Maybe Interval -> Double\n -> Double -> Bool -> Int -> [Trace] -> DrawingArea\n -> Render ()\ndrawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval xoffset\n vadj_value labelsMode histogramHeight traces yScaleArea = do\n let histTotalHeight = histogramHeight + histXScaleHeight\n ys = map (subtract (round vadj_value)) $\n traceYPositions labelsMode histTotalHeight traces\n pcontext <- liftIO $ widgetCreatePangoContext yScaleArea\n zipWithM_\n (drawSingleYScale\n maxSpkValue maxSparkPool maxYHistogram minterval xoffset\n histogramHeight pcontext)\n traces ys\n\n-- | Render a single Y scale axis, set of ticks and label, or only a label,\n-- if the trace is not a graph.\ndrawSingleYScale :: Double -> Double -> Double -> Maybe Interval -> Double -> Int\n -> PangoContext -> Trace -> Int\n -> Render ()\ndrawSingleYScale maxSpkValue maxSparkPool maxYHistogram minterval xoffset\n histogramHeight pcontext trace y = do\n setSourceRGBAhex black 1\n move_to (ox, y + 8)\n layout <- liftIO $ layoutText pcontext (showTrace minterval trace)\n liftIO $ do\n layoutSetWidth layout (Just $ xoffset - 50)\n -- Note: the following does not always work, see the HACK in Timeline.hs\n layoutSetAttributes layout [AttrSize minBound maxBound 8,\n AttrFamily minBound maxBound\n#if MIN_VERSION_gtk3(0,13,0)\n (T.pack \"sans serif\")]\n#else\n \"sans serif\"]\n#endif\n showLayout layout\n case traceMaxSpark maxSpkValue maxSparkPool maxYHistogram trace of\n Just v ->\n renderYScale\n (traceHeight histogramHeight trace) 1 v (xoffset - 13) (fromIntegral y)\n Nothing -> return () -- not a graph-like trace\n\n--------------------------------------------------------------------------------\n\n-- | Calculate Y positions of all traces.\ntraceYPositions :: Bool -> Int -> [Trace] -> [Int]\ntraceYPositions labelsMode histTotalHeight traces =\n scanl (\\a b -> a + (height b) + extra + tracePad) firstTraceY traces\n where\n height b = traceHeight histTotalHeight b\n extra = if labelsMode then hecLabelExtra else 0\n\ntraceHeight :: Int -> Trace -> Int\ntraceHeight _ TraceHEC{} = hecTraceHeight\ntraceHeight _ TraceInstantHEC{} = hecInstantHeight\ntraceHeight _ TraceCreationHEC{} = hecSparksHeight\ntraceHeight _ TraceConversionHEC{} = hecSparksHeight\ntraceHeight _ TracePoolHEC{} = hecSparksHeight\ntraceHeight h TraceHistogram = h\ntraceHeight _ TraceGroup{} = error \"traceHeight\"\ntraceHeight _ TraceActivity = activityGraphHeight\n\n-- | Calculate the total Y span of all traces.\ncalculateTotalTimelineHeight :: Bool -> Int -> [Trace] -> Int\ncalculateTotalTimelineHeight labelsMode histTotalHeight traces =\n last (traceYPositions labelsMode histTotalHeight traces)\n\n-- | Produce a descriptive label for a trace.\nshowTrace :: Maybe Interval -> Trace -> String\nshowTrace _ (TraceHEC n) =\n \"HEC \" ++ show n\nshowTrace _ (TraceInstantHEC n) =\n \"HEC \" ++ show n ++ \"\\nInstant\"\nshowTrace _ (TraceCreationHEC n) =\n \"\\nHEC \" ++ show n ++ \"\\n\\nSpark creation rate (spark/ms)\"\nshowTrace _ (TraceConversionHEC n) =\n \"\\nHEC \" ++ show n ++ \"\\n\\nSpark conversion rate (spark/ms)\"\nshowTrace _ (TracePoolHEC n) =\n \"\\nHEC \" ++ show n ++ \"\\n\\nSpark pool size\"\nshowTrace Nothing TraceHistogram =\n \"Sum of spark times\\n(\" ++ mu ++ \"s)\"\nshowTrace Just{} TraceHistogram =\n \"Sum of selected spark times\\n(\" ++ mu ++ \"s)\"\nshowTrace _ TraceActivity =\n \"Activity\"\nshowTrace _ TraceGroup{} = error \"Render.showTrace\"\n\n-- | Calculate the maximal Y value for a graph-like trace, or Nothing.\ntraceMaxSpark :: Double -> Double -> Double -> Trace -> Maybe Double\ntraceMaxSpark maxS _ _ TraceCreationHEC{} = Just $ maxS * 1000\ntraceMaxSpark maxS _ _ TraceConversionHEC{} = Just $ maxS * 1000\ntraceMaxSpark _ maxP _ TracePoolHEC{} = Just $ maxP\ntraceMaxSpark _ _ maxH TraceHistogram = Just $ maxH\ntraceMaxSpark _ _ _ _ = Nothing\n\n-- | Snap a value to a whole pixel, based on drawing scale.\ntoWholePixels :: Double -> Double -> Double\ntoWholePixels 0 _ = 0\ntoWholePixels scale x = fromIntegral (truncate (x / scale)) * scale\n" }, { "path": "GUI/Timeline/Sparks.hs", "content": "module GUI.Timeline.Sparks (\n treesProfile,\n maxSparkRenderedValue,\n renderSparkCreation,\n renderSparkConversion,\n renderSparkPool,\n renderSparkHistogram,\n ) where\n\nimport GUI.Timeline.Render.Constants\n\nimport Events.HECs\nimport Events.SparkTree\nimport qualified Events.SparkStats as SparkStats\n\nimport GUI.Types\nimport GUI.ViewerColours\nimport GUI.Timeline.Ticks\n\nimport Graphics.Rendering.Cairo\n\nimport Control.Monad\n\n-- Rendering sparks. No approximation nor extrapolation is going on here.\n-- The sample data, recalculated for a given slice size in sparkProfile,\n-- before these functions are called, is straightforwardly rendered.\n\nmaxSparkRenderedValue :: Timestamp -> SparkStats.SparkStats -> Double\nmaxSparkRenderedValue duration c =\n max (SparkStats.rateDud c +\n SparkStats.rateCreated c +\n SparkStats.rateOverflowed c)\n (SparkStats.rateFizzled c +\n SparkStats.rateConverted c +\n SparkStats.rateGCd c)\n / fromIntegral duration\n\nspark_detail :: Int\nspark_detail = 4 -- in pixels\n\ntreesProfile :: Double -> Timestamp -> Timestamp -> HECs\n -> (Timestamp, [[SparkStats.SparkStats]])\ntreesProfile scale start end hecs =\n let slice = ceiling (fromIntegral spark_detail * scale)\n pr trees = let (_, _, stree) = trees\n in sparkProfile slice start end stree\n in (slice, map pr (hecTrees hecs))\n\n\nrenderSparkCreation :: ViewParameters -> Timestamp -> Timestamp -> Timestamp\n -> [SparkStats.SparkStats]\n -> Render ()\nrenderSparkCreation params !slice !start !end prof = do\n let f1 c = SparkStats.rateCreated c\n f2 c = f1 c + SparkStats.rateDud c\n f3 c = f2 c + SparkStats.rateOverflowed c\n renderSpark params slice start end prof\n f1 createdConvertedColour f2 fizzledDudsColour f3 overflowedColour\n\nrenderSparkConversion :: ViewParameters -> Timestamp -> Timestamp -> Timestamp\n -> [SparkStats.SparkStats]\n -> Render ()\nrenderSparkConversion params !slice !start !end prof = do\n let f1 c = SparkStats.rateConverted c\n f2 c = f1 c + SparkStats.rateFizzled c\n f3 c = f2 c + SparkStats.rateGCd c\n renderSpark params slice start end prof\n f1 createdConvertedColour f2 fizzledDudsColour f3 gcColour\n\nrenderSparkPool :: Timestamp -> Timestamp -> Timestamp\n -> [SparkStats.SparkStats]\n -> Double -> Render ()\nrenderSparkPool !slice !start !end prof !maxSparkPool = do\n let f1 c = SparkStats.minPool c\n f2 c = SparkStats.meanPool c\n f3 c = SparkStats.maxPool c\n addSparks outerPercentilesColour maxSparkPool f1 f2 start slice prof\n addSparks outerPercentilesColour maxSparkPool f2 f3 start slice prof\n outlineSparks maxSparkPool f2 start slice prof\n outlineSparks maxSparkPool (const 0) start slice prof\n renderHRulers hecSparksHeight start end\n\nrenderSpark :: ViewParameters -> Timestamp -> Timestamp -> Timestamp\n -> [SparkStats.SparkStats]\n -> (SparkStats.SparkStats -> Double) -> Color\n -> (SparkStats.SparkStats -> Double) -> Color\n -> (SparkStats.SparkStats -> Double) -> Color\n -> Render ()\nrenderSpark ViewParameters{..} slice start end prof f1 c1 f2 c2 f3 c3 = do\n -- maxSpkValue is maximal spark transition rate, so\n -- maxSliceSpark is maximal number of sparks per slice for current data.\n let maxSliceSpark = maxSpkValue * fromIntegral slice\n outlineSparks maxSliceSpark f3 start slice prof\n addSparks c1 maxSliceSpark (const 0) f1 start slice prof\n addSparks c2 maxSliceSpark f1 f2 start slice prof\n addSparks c3 maxSliceSpark f2 f3 start slice prof\n renderHRulers hecSparksHeight start end\n\noff :: Double -> (SparkStats.SparkStats -> Double)\n -> SparkStats.SparkStats\n -> Double\noff maxSliceSpark f t =\n let clipped = min 1 (f t / maxSliceSpark)\n in fromIntegral hecSparksHeight * (1 - clipped)\n\noutlineSparks :: Double\n -> (SparkStats.SparkStats -> Double)\n -> Timestamp -> Timestamp\n -> [SparkStats.SparkStats]\n -> Render ()\noutlineSparks maxSliceSpark f start slice ts = do\n case ts of\n [] -> return ()\n ts -> do\n let dstart = fromIntegral start\n dslice = fromIntegral slice\n points = [dstart-dslice/2, dstart+dslice/2 ..]\n t = zip points (map (off maxSliceSpark f) ts)\n newPath\n moveTo (dstart-dslice/2) (snd $ head t)\n mapM_ (uncurry lineTo) t\n setSourceRGBAhex black 1.0\n setLineWidth 1\n stroke\n\naddSparks :: Color\n -> Double\n -> (SparkStats.SparkStats -> Double)\n -> (SparkStats.SparkStats -> Double)\n -> Timestamp -> Timestamp\n -> [SparkStats.SparkStats]\n -> Render ()\naddSparks colour maxSliceSpark f0 f1 start slice ts = do\n case ts of\n [] -> return ()\n ts -> do\n -- liftIO $ printf \"ts: %s\\n\" (show (map f1 (ts)))\n -- liftIO $ printf \"off: %s\\n\"\n -- (show (map (off maxSliceSpark f1) (ts) :: [Double]))\n let dstart = fromIntegral start\n dslice = fromIntegral slice\n points = [dstart-dslice/2, dstart+dslice/2 ..]\n t0 = zip points (map (off maxSliceSpark f0) ts)\n t1 = zip points (map (off maxSliceSpark f1) ts)\n newPath\n moveTo (dstart-dslice/2) (snd $ head t1)\n mapM_ (uncurry lineTo) t1\n mapM_ (uncurry lineTo) (reverse t0)\n setSourceRGBAhex colour 1.0\n fill\n\n-- | Render the spark duration histogram together with it's X scale and\n-- horizontal and vertical rulers.\nrenderSparkHistogram :: ViewParameters -> HECs -> Render ()\nrenderSparkHistogram ViewParameters{..} hecs =\n let intDoub :: Integral a => a -> Double\n intDoub = fromIntegral\n inR :: Timestamp -> Bool\n inR = case minterval of\n Nothing -> const True\n Just (from, to) -> \\ t -> t >= from && t <= to\n -- TODO: if xs is sorted, we can slightly optimize the filtering\n inRange :: [(Timestamp, Int, Timestamp)] -> [(Int, (Timestamp, Int))]\n inRange xs = [(logdur, (dur, 1))\n | (start, logdur, dur) <- xs, inR start]\n xs = durHistogram hecs\n bars :: [(Double, Double, Int)]\n bars = [(intDoub t, intDoub height, count)\n | (t, (height, count)) <- histogramCounts $ inRange xs]\n -- TODO: data processing up to this point could be done only at interval\n -- changes (keeping @bars@ in ViewParameters and in probably also in IOref.\n -- The rest has to be recomputed at each redraw, because resizing\n -- the window modifies the way the graph is drawn.\n -- TODO: at least pull the above out into a separate function.\n\n -- Define general parameters for visualization.\n width' = width - 5 -- add a little margin on the right\n (w, h) = (intDoub width', intDoub histogramHeight)\n (minX, maxX, maxY) = (intDoub (minXHistogram hecs),\n intDoub (maxXHistogram hecs),\n intDoub (maxYHistogram hecs))\n nBars = max 5 (maxX - minX + 1)\n segmentWidth = w / nBars\n -- Define parameters for drawing the bars.\n gapWidth = 10\n barWidth = segmentWidth - gapWidth\n sX x = gapWidth / 2 + (x - minX) * segmentWidth\n sY y = y * h / (max 2 maxY)\n plotRect (x, y, count) = do\n -- Draw a single bar.\n setSourceRGBAhex blue 1.0\n rectangle (sX x) (sY maxY) barWidth (sY (-y))\n fillPreserve\n setSourceRGBA 0 0 0 0.7\n setLineWidth 1\n stroke\n -- Print the number of sparks in the bar.\n selectFontFace \"sans serif\" FontSlantNormal FontWeightNormal\n setFontSize 10\n let above = sY (-y) > -20\n if above\n then setSourceRGBAhex black 1.0\n else setSourceRGBAhex white 1.0\n moveTo (sX x + 3) (sY (maxY - y) + if above then -3 else 13)\n showText (show count)\n drawHist = forM_ bars plotRect\n -- Define parameters for X scale.\n off y = 16 - y\n xScaleMode = XScaleLog minX segmentWidth\n drawXScale = renderXScale 1 0 maxBound width' off xScaleMode\n -- Define parameters for vertical rulers.\n nB = round nBars\n mult | nB <= 7 = 1\n | nB `mod` 5 == 0 = 5\n | nB `mod` 4 == 0 = 4\n | nB `mod` 3 == 0 = 3\n | nB `mod` 2 == 0 = nB `div` 2\n | otherwise = nB\n drawVRulers = renderVRulers 1 0 (fromIntegral width') histogramHeight\n (XScaleLog undefined (segmentWidth * fromIntegral mult))\n -- Define the horizontal rulers call.\n drawHRulers = renderHRulers histogramHeight 0 (fromIntegral width')\n in do\n -- Start the drawing by wiping out timeline vertical rules\n -- (for PNG/PDF that require clear, transparent background)\n save\n translate hadjValue 0\n scale scaleValue 1\n rectangle 0 (fromIntegral $ - tracePad) (fromIntegral width)\n (fromIntegral $ histogramHeight + histXScaleHeight + 2 * tracePad)\n setSourceRGBAhex white 1\n op <- getOperator\n setOperator OperatorAtop -- TODO: fixme: it paints white vertical rulers\n fill\n setOperator op\n -- Draw the bars.\n drawHist\n -- Draw the rulers on top of the bars (they are partially transparent).\n drawVRulers\n drawHRulers\n -- Move to the bottom and draw the X scale. The Y scale is drawn\n -- independently in another drawing area.\n translate 0 (fromIntegral histogramHeight)\n drawXScale\n restore\n" }, { "path": "GUI/Timeline/Ticks.hs", "content": "{-# LANGUAGE CPP #-}\nmodule GUI.Timeline.Ticks (\n renderVRulers,\n XScaleMode(..),\n renderXScaleArea,\n renderXScale,\n renderHRulers,\n renderYScale,\n mu,\n deZero,\n ) where\n\nimport Events.HECs\nimport GUI.Types\nimport GUI.Timeline.CairoDrawing\nimport GUI.ViewerColours\n\nimport Graphics.Rendering.Cairo\nimport Control.Monad\nimport Text.Printf\n\n-- Minor, semi-major and major ticks are drawn and the absolute period of\n-- the ticks is determined by the zoom level.\n-- There are ten minor ticks to a major tick and a semi-major tick\n-- occurs half way through a major tick (overlapping the corresponding\n-- minor tick).\n-- The timestamp values are in micro-seconds (1e-6) i.e.\n-- a timestamp value of 1000000 represents 1s. The position on the drawing\n-- canvas is in milliseconds (ms) (1e-3).\n-- scaleValue is used to divide a timestamp value to yield a pixel value.\n-- NOTE: the code below will crash if the timestampFor100Pixels is 0.\n-- The zoom factor should be controlled to ensure that this never happens.\n\n-- | Render vertical rulers (solid translucent lines), matching scale ticks.\nrenderVRulers :: Double -> Timestamp -> Timestamp -> Int -> XScaleMode\n -> Render()\nrenderVRulers scaleValue startPos endPos height xScaleMode = do\n let timestampFor100Pixels = truncate (100 * scaleValue)\n snappedTickDuration :: Timestamp\n snappedTickDuration =\n 10 ^ max 0 (truncate (logBase 10 (fromIntegral timestampFor100Pixels)\n :: Double))\n tickWidthInPixels :: Double\n tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue\n firstTick :: Timestamp\n firstTick = snappedTickDuration * (startPos `div` snappedTickDuration)\n setSourceRGBAhex black 0.15\n setLineWidth scaleValue\n case xScaleMode of\n XScaleTime ->\n drawVRulers tickWidthInPixels scaleValue\n (fromIntegral $ firstTick + snappedTickDuration)\n (fromIntegral snappedTickDuration) endPos height\n (1 + fromIntegral (startPos `div` snappedTickDuration))\n XScaleLog _ dx ->\n drawVRulers 1e1000 1 dx dx endPos height 1\n\n-- | Render a single vertical ruler and then recurse.\ndrawVRulers :: Double -> Double -> Double -> Double\n -> Timestamp -> Int -> Int -> Render ()\ndrawVRulers tickWidthInPixels scaleValue pos incr endPos height i =\n if floor pos <= endPos then do\n when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do\n draw_line (veryRoundedPos, 0) (veryRoundedPos, height)\n drawVRulers\n tickWidthInPixels scaleValue (pos + incr) incr endPos height (i + 1)\n else\n return ()\n where\n -- Hack to sync with drawXTicks.\n veryRoundedPos = round $\n scaleValue * fromIntegral (floor (fromIntegral (round pos) / scaleValue))\n atMidTick = i `mod` 5 == 0\n atMajorTick = i `mod` 10 == 0\n\n\n-- | Render the X scale, based on view parameters and hecs.\nrenderXScaleArea :: ViewParameters -> HECs -> Render ()\nrenderXScaleArea ViewParameters{width, scaleValue, hadjValue, xScaleAreaHeight}\n hecs =\n let lastTx = hecLastEventTime hecs\n off y = y + xScaleAreaHeight - 17\n in renderXScale scaleValue hadjValue lastTx width off XScaleTime\n\n\ndata XScaleMode = XScaleTime | XScaleLog Double Double deriving Eq\n\n-- | Render the X (vertical) scale: render X axis and call ticks rendering.\n-- TODO: refactor common parts with renderVRulers, in particular to expose\n-- that ruler positions match tick positions.\nrenderXScale :: Double -> Double -> Timestamp -> Int\n -> (Int -> Int) -> XScaleMode\n -> Render ()\nrenderXScale scaleValue hadjValue lastTx width off xScaleMode = do\n let scale_width = fromIntegral width * scaleValue\n startPos :: Timestamp\n startPos = floor hadjValue\n startLine :: Timestamp\n startLine = floor $ hadjValue / scaleValue\n endPos :: Timestamp\n endPos = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx)\n endLine :: Timestamp\n endLine = ceiling $ min (hadjValue + scale_width) (fromIntegral lastTx)\n / scaleValue\n save\n translate (- fromIntegral startLine) 0\n selectFontFace \"sans serif\" FontSlantNormal FontWeightNormal\n setFontSize 12\n setSourceRGBAhex black 1.0\n-- setLineCap LineCapRound -- TODO: breaks rendering currently (see BrokenX.png)\n setLineWidth 1.0\n draw_line (startLine, off 16) (endLine, off 16)\n let tFor100Pixels = truncate (100 * scaleValue)\n snappedTickDuration :: Timestamp\n snappedTickDuration =\n 10 ^ max 0 (truncate (logBase 10 (fromIntegral tFor100Pixels)\n :: Double))\n tickWidthInPixels :: Double\n tickWidthInPixels = fromIntegral snappedTickDuration / scaleValue\n firstTick :: Timestamp\n firstTick = snappedTickDuration * (startPos `div` snappedTickDuration)\n case xScaleMode of\n XScaleTime ->\n drawXTicks tickWidthInPixels scaleValue (fromIntegral firstTick)\n (fromIntegral snappedTickDuration) endPos off xScaleMode\n (fromIntegral (startPos `div` snappedTickDuration))\n XScaleLog _ segmentWidth ->\n drawXTicks 1e1000 1 0 segmentWidth endPos off xScaleMode 0\n restore\n\n-- | Render a single X scale tick and then recurse.\ndrawXTicks :: Double -> Double -> Double -> Double -> Timestamp\n -> (Int -> Int) -> XScaleMode -> Int\n -> Render ()\ndrawXTicks tickWidthInPixels scaleValue pos incr endPos off xScaleMode i =\n if floor pos <= endPos then do\n when (pos /= 0 || xScaleMode == XScaleTime) $\n draw_line (floor $ fromIntegral x1 / scaleValue, off 16)\n (floor $ fromIntegral x1 / scaleValue, off (16 - tickLength))\n when (atMajorTick || atMidTick || tickWidthInPixels > 70) $ do\n tExtent <- textExtents tickTimeText\n let tExtentWidth = textExtentsWidth tExtent\n move_to (floor $ fromIntegral textPosX / scaleValue, textPosY)\n when (floor (pos + incr) <= endPos\n && (tExtentWidth + tExtentWidth / 3 < width || atMajorTick)) $\n showText tickTimeText\n drawXTicks\n tickWidthInPixels scaleValue (pos + incr) incr endPos off xScaleMode (i+1)\n else\n return ()\n where\n atMidTick = xScaleMode == XScaleTime && i `mod` 5 == 0\n atMajorTick = xScaleMode == XScaleTime && i `mod` 10 == 0\n (textPosX, textPosY) =\n if xScaleMode == XScaleTime\n then (x1 + ceiling (scaleValue * 3), off (-3))\n else (x1 + ceiling (scaleValue * 2), tickLength + 13)\n tickLength | atMajorTick = 16\n | atMidTick = 10\n | otherwise = if xScaleMode == XScaleTime then 6 else 8\n posTime = case xScaleMode of\n XScaleTime -> round pos\n XScaleLog minX _ -> round $ 2 ** (minX + pos / incr)\n tickTimeText = showMultiTime posTime\n width = if atMidTick then 5 * tickWidthInPixels\n else tickWidthInPixels\n -- We cheat at pos 0, to avoid half covering the tick by the grey label area.\n lineWidth = scaleValue\n x1 = round $ if pos == 0 && xScaleMode == XScaleTime then lineWidth else pos\n\n-- | Display the micro-second time unit with an appropriate suffix\n-- depending on the actual time value.\n-- For times < 1e-6 the time is shown in micro-seconds.\n-- For times >= 1e-6 and < 0.1 seconds the time is shown in ms\n-- For times >= 0.5 seconds the time is shown in seconds\nshowMultiTime :: Timestamp -> String\nshowMultiTime pos =\n if pos == 0 then \"0s\"\n else if pos < 1000 then -- Show time as micro-seconds for times < 1e-6\n reformatMS posf ++ (mu ++ \"s\") -- microsecond (1e-6s).\n else if pos < 100000 then -- Show miliseonds for time < 0.1s\n reformatMS (posf / 1000) ++ \"ms\" -- miliseconds 1e-3\n else -- Show time in seconds\n reformatMS (posf / 1000000) ++ \"s\"\n where\n posf :: Double\n posf = fromIntegral pos\n reformatMS :: Show a => a -> String\n reformatMS pos = deZero (show pos)\n\n-------------------------------------------------------------------------------\n\n-- | Render horizontal rulers (dashed translucent lines),\n-- matching scale ticks (visible in the common @incr@ value and starting at 0).\nrenderHRulers :: Int -> Timestamp -> Timestamp -> Render ()\nrenderHRulers hecSparksHeight start end = do\n let dstart = fromIntegral start\n dend = fromIntegral end\n incr = fromIntegral hecSparksHeight / 10\n -- dashed lines across the graphs\n setSourceRGBAhex black 0.15\n setLineWidth 1\n save\n forM_ [0, 5] $ \\h -> do\n let y = h * incr\n moveTo dstart y\n lineTo dend y\n stroke\n restore\n\n-- | Render one of the Y (horizontal) scales: render the Y axis\n-- and call ticks rendering.\nrenderYScale :: Int -> Double -> Double -> Double -> Double -> Render ()\nrenderYScale hecSparksHeight scaleValue maxSpark xoffset yoffset = do\n let -- This is slightly off (by 1% at most), but often avoids decimal dot:\n maxS = if maxSpark < 100\n then maxSpark -- too small, would be visible on screen\n else fromIntegral (2 * (ceiling maxSpark ` div` 2))\n incr = fromIntegral hecSparksHeight / 10\n save\n newPath\n moveTo (xoffset + 12) yoffset\n lineTo (xoffset + 12) (yoffset + fromIntegral hecSparksHeight)\n setSourceRGBAhex black 1.0\n setLineCap LineCapRound\n setLineWidth 1.0 -- TODO: it's not really 1 pixel, due to the scale\n stroke\n selectFontFace \"sans serif\" FontSlantNormal FontWeightNormal\n setFontSize 12\n scale scaleValue 1.0\n setLineWidth 0.5 -- TODO: it's not really 0.5 pixels, due to the scale\n drawYTicks maxS 0 incr xoffset yoffset 0\n restore\n\n-- | Render a single Y scale tick and then recurse.\ndrawYTicks :: Double -> Double -> Double -> Double -> Double -> Int -> Render ()\ndrawYTicks maxS pos incr xoffset yoffset i =\n if i <= 10 then do\n -- TODO: snap to pixels, currently looks semi-transparent\n moveTo (xoffset + 12) (yoffset + majorTick - pos)\n lineTo (xoffset + 12 - tickLength) (yoffset + majorTick - pos)\n stroke\n when (atMajorTick || atMidTick) $ do\n tExtent <- textExtents tickText\n (fewPixels, yPix) <- deviceToUserDistance 3 4\n moveTo (xoffset - textExtentsWidth tExtent - fewPixels)\n (yoffset + majorTick - pos + yPix)\n when (atMidTick || atMajorTick) $\n showText tickText\n drawYTicks maxS (pos + incr) incr xoffset yoffset (i + 1)\n else\n return ()\n where\n atMidTick = i `mod` 5 == 0\n atMajorTick = i `mod` 10 == 0\n majorTick = 10 * incr\n tickText = reformatV (fromIntegral i * maxS / 10)\n tickLength | atMajorTick = 11\n | atMidTick = 9\n | otherwise = 6\n reformatV :: Double -> String\n reformatV v =\n if v < 0.01 && v > 0\n then eps\n else deZero (printf \"%.2f\" v)\n\n-------------------------------------------------------------------------------\n\n-- | The \\'micro\\' symbol.\nmu :: String\n#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1)\n-- this version of cairo doesn't handle Unicode properly.\n-- Thus, we do the encoding by hand:\nmu = \"\\194\\181\"\n#else\n-- Haskell cairo bindings 0.12.1 have proper Unicode support\nmu = \"\\x00b5\"\n#endif\n\n-- | The \\'epsilon\\' symbol.\neps :: String\n#if MIN_VERSION_cairo(0,12,0) && !MIN_VERSION_cairo(0,12,1)\n-- this version of cairo doesn't handle Unicode properly.\n-- Thus, we do the encoding by hand:\neps = \"\\206\\181\"\n#else\n-- Haskell cairo bindings 0.12.1 have proper Unicode support\neps = \"\\x03b5\"\n#endif\n\n\n-- | Remove all meaningless trailing zeroes.\ndeZero :: String -> String\ndeZero s\n | '.' `elem` s =\n reverse . dropWhile (=='.') . dropWhile (=='0') . reverse $ s\n | otherwise = s\n" }, { "path": "GUI/Timeline/Types.hs", "content": "module GUI.Timeline.Types (\n TimelineState(..),\n TimeSelection(..),\n ) where\n\n\nimport GUI.Types\n\nimport Graphics.UI.Gtk\nimport Graphics.Rendering.Cairo\nimport Data.IORef\n\n-----------------------------------------------------------------------------\n\ndata TimelineState = TimelineState {\n timelineDrawingArea :: DrawingArea,\n timelineYScaleArea :: DrawingArea,\n timelineXScaleArea :: DrawingArea,\n timelineAdj :: Adjustment,\n timelineVAdj :: Adjustment,\n\n timelinePrevView :: IORef (Maybe (ViewParameters, Surface)),\n\n -- This scale value is used to map a micro-second value to a pixel unit.\n -- To convert a timestamp value to a pixel value, multiply it by scale.\n -- To convert a pixel value to a micro-second value, divide it by scale.\n scaleIORef :: IORef Double,\n\n -- Maximal number of sparks/slice measured after every zoom to fit.\n maxSpkIORef :: IORef Double\n }\n\n\ndata TimeSelection = PointSelection Timestamp\n | RangeSelection Timestamp Timestamp\n\n-----------------------------------------------------------------------------\n" }, { "path": "GUI/Timeline.hs", "content": "{-# LANGUAGE CPP #-}\nmodule GUI.Timeline (\n TimelineView,\n timelineViewNew,\n TimelineViewActions(..),\n\n timelineSetBWMode,\n timelineSetLabelsMode,\n timelineGetViewParameters,\n timelineGetYScaleArea,\n timelineWindowSetHECs,\n timelineWindowSetTraces,\n timelineWindowSetBookmarks,\n timelineSetSelection,\n TimeSelection(..),\n\n timelineZoomIn,\n timelineZoomOut,\n timelineZoomToFit,\n timelineScrollLeft,\n timelineScrollRight,\n timelineScrollToBeginning,\n timelineScrollToEnd,\n timelineCentreOnCursor,\n ) where\n\nimport GUI.Types\nimport GUI.Timeline.Types\n\nimport GUI.Timeline.Motion\nimport GUI.Timeline.Render\nimport GUI.Timeline.Render.Constants\n\nimport Events.HECs\n\nimport Graphics.UI.Gtk\n\nimport Data.IORef\nimport Data.Ord\nimport Control.Monad\nimport Control.Monad.Trans\nimport qualified Data.Text as T\n\n-----------------------------------------------------------------------------\n-- The CPUs view\n\ndata TimelineView = TimelineView {\n\n timelineState :: TimelineState,\n\n hecsIORef :: IORef (Maybe HECs),\n tracesIORef :: IORef [Trace],\n bookmarkIORef :: IORef [Timestamp],\n\n selectionRef :: IORef TimeSelection,\n labelsModeIORef :: IORef Bool,\n bwmodeIORef :: IORef Bool,\n\n cursorIBeam :: Cursor,\n cursorMove :: Cursor\n }\n\ndata TimelineViewActions = TimelineViewActions {\n timelineViewSelectionChanged :: TimeSelection -> IO ()\n }\n\n-- | Draw some parts of the timeline in black and white rather than colour.\ntimelineSetBWMode :: TimelineView -> Bool -> IO ()\ntimelineSetBWMode timelineWin bwmode = do\n writeIORef (bwmodeIORef timelineWin) bwmode\n widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))\n\ntimelineSetLabelsMode :: TimelineView -> Bool -> IO ()\ntimelineSetLabelsMode timelineWin labelsMode = do\n writeIORef (labelsModeIORef timelineWin) labelsMode\n widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))\n updateTimelineVScroll timelineWin\n\ntimelineGetViewParameters :: TimelineView -> IO ViewParameters\ntimelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef,\n timelineState=TimelineState{..}} = do\n\n Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea\n scaleValue <- readIORef scaleIORef\n maxSpkValue <- readIORef maxSpkIORef\n\n -- snap the view to whole pixels, to avoid blurring\n hadj_value0 <- adjustmentGetValue timelineAdj\n let hadj_value = toWholePixels scaleValue hadj_value0\n\n traces <- readIORef tracesIORef\n bwmode <- readIORef bwmodeIORef\n labelsMode <- readIORef labelsModeIORef\n\n Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea\n let histTotalHeight = stdHistogramHeight + histXScaleHeight\n timelineHeight =\n calculateTotalTimelineHeight labelsMode histTotalHeight traces\n\n return ViewParameters\n { width = w\n , height = timelineHeight\n , viewTraces = traces\n , hadjValue = hadj_value\n , scaleValue = scaleValue\n , maxSpkValue = maxSpkValue\n , detail = 3 --for now\n , bwMode = bwmode\n , labelsMode = labelsMode\n , histogramHeight = stdHistogramHeight\n , minterval = Nothing\n , xScaleAreaHeight = xScaleAreaHeight\n }\n\ntimelineGetYScaleArea :: TimelineView -> DrawingArea\ntimelineGetYScaleArea timelineWin =\n timelineYScaleArea $ timelineState timelineWin\n\ntimelineWindowSetHECs :: TimelineView -> Maybe HECs -> IO ()\ntimelineWindowSetHECs timelineWin@TimelineView{..} mhecs = do\n writeIORef hecsIORef mhecs\n zoomToFit timelineState mhecs\n timelineParamsChanged timelineWin\n\ntimelineWindowSetTraces :: TimelineView -> [Trace] -> IO ()\ntimelineWindowSetTraces timelineWin@TimelineView{tracesIORef} traces = do\n writeIORef tracesIORef traces\n timelineParamsChanged timelineWin\n\ntimelineWindowSetBookmarks :: TimelineView -> [Timestamp] -> IO ()\ntimelineWindowSetBookmarks timelineWin@TimelineView{bookmarkIORef} bookmarks = do\n writeIORef bookmarkIORef bookmarks\n timelineParamsChanged timelineWin\n\n-----------------------------------------------------------------------------\n\ntimelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView\ntimelineViewNew builder actions = do\n\n let getWidget cast = builderGetObject builder cast\n timelineViewport <- getWidget castToWidget \"timeline_viewport\"\n timelineDrawingArea <- getWidget castToDrawingArea \"timeline_drawingarea\"\n timelineYScaleArea <- getWidget castToDrawingArea \"timeline_yscale_area\"\n timelineXScaleArea <- getWidget castToDrawingArea \"timeline_xscale_area\"\n timelineHScrollbar <- getWidget castToHScrollbar \"timeline_hscroll\"\n timelineVScrollbar <- getWidget castToVScrollbar \"timeline_vscroll\"\n timelineAdj <- rangeGetAdjustment timelineHScrollbar\n timelineVAdj <- rangeGetAdjustment timelineVScrollbar\n\n -- HACK: layoutSetAttributes does not work for \\mu, so let's work around\n fd <- fontDescriptionNew\n fontDescriptionSetSize fd 8\n fontDescriptionSetFamily fd \"sans serif\"\n widgetModifyFont timelineYScaleArea (Just fd)\n\n cursorIBeam <- cursorNew Xterm\n cursorMove <- cursorNew Fleur\n\n hecsIORef <- newIORef Nothing\n tracesIORef <- newIORef []\n bookmarkIORef <- newIORef []\n scaleIORef <- newIORef 0\n maxSpkIORef <- newIORef 0\n selectionRef <- newIORef (PointSelection 0)\n bwmodeIORef <- newIORef False\n labelsModeIORef <- newIORef False\n timelinePrevView <- newIORef Nothing\n\n let timelineState = TimelineState{..}\n timelineWin = TimelineView{..}\n\n ------------------------------------------------------------------------\n -- Redrawing labelDrawingArea\n timelineYScaleArea `on` draw $ liftIO $ do\n maybeEventArray <- readIORef hecsIORef\n\n -- Check to see if an event trace has been loaded\n case maybeEventArray of\n Nothing -> return ()\n Just hecs -> do\n traces <- readIORef tracesIORef\n labelsMode <- readIORef labelsModeIORef\n let maxP = maxSparkPool hecs\n maxH = fromIntegral (maxYHistogram hecs)\n updateYScaleArea timelineState maxP maxH Nothing labelsMode traces\n return ()\n\n ------------------------------------------------------------------------\n -- Redrawing XScaleArea\n timelineXScaleArea `on` draw $ liftIO $ do\n maybeEventArray <- readIORef hecsIORef\n\n -- Check to see if an event trace has been loaded\n case maybeEventArray of\n Nothing -> return ()\n Just hecs -> do\n let lastTx = hecLastEventTime hecs\n updateXScaleArea timelineState lastTx\n return ()\n\n ------------------------------------------------------------------------\n -- Allow mouse wheel to be used for zoom in/out\n on timelineViewport scrollEvent $ tryEvent $ do\n dir <- eventScrollDirection\n mods <- eventModifier\n (x, _y) <- eventCoordinates\n x_ts <- liftIO $ viewPointToTime timelineWin x\n liftIO $ case (dir,mods) of\n (ScrollUp, [Control]) -> zoomIn timelineState x_ts\n (ScrollDown, [Control]) -> zoomOut timelineState x_ts\n (ScrollUp, []) -> vscrollUp timelineState\n (ScrollDown, []) -> vscrollDown timelineState\n _ -> return ()\n\n ------------------------------------------------------------------------\n -- Mouse button and selection\n\n widgetSetCursor timelineDrawingArea (Just cursorIBeam)\n\n mouseStateVar <- newIORef None\n\n let withMouseState action = liftIO $ do\n st <- readIORef mouseStateVar\n st' <- action st\n writeIORef mouseStateVar st'\n\n on timelineDrawingArea buttonPressEvent $ do\n (x,_y) <- eventCoordinates\n button <- eventButton\n liftIO $ widgetGrabFocus timelineViewport\n withMouseState (\\st -> mousePress timelineWin st button x)\n return False\n\n on timelineDrawingArea buttonReleaseEvent $ do\n (x,_y) <- eventCoordinates\n button <- eventButton\n withMouseState (\\st -> mouseRelease timelineWin actions st button x)\n return False\n\n widgetAddEvents timelineDrawingArea [Button1MotionMask, Button2MotionMask]\n on timelineDrawingArea motionNotifyEvent $ do\n (x, _y) <- eventCoordinates\n withMouseState (\\st -> mouseMove timelineWin st x)\n return False\n\n on timelineDrawingArea grabBrokenEvent $ do\n withMouseState (mouseMoveCancel timelineWin actions)\n return False\n\n -- Escape key to cancel selection or drag\n on timelineViewport keyPressEvent $ do\n let liftNoMouse a =\n let whenNoMouse None = a >> return None\n whenNoMouse st = return st\n in withMouseState whenNoMouse >> return True\n keyName <- eventKeyName\n keyVal <- eventKeyVal\n#if MIN_VERSION_gtk3(0,13,0)\n case (T.unpack keyName, keyToChar keyVal, keyVal) of\n#else\n case (keyName, keyToChar keyVal, keyVal) of\n#endif\n (\"Right\", _, _) -> liftNoMouse $ scrollRight timelineState\n (\"Left\", _, _) -> liftNoMouse $ scrollLeft timelineState\n (_ , Just '+', _) -> liftNoMouse $ timelineZoomIn timelineWin\n (_ , Just '-', _) -> liftNoMouse $ timelineZoomOut timelineWin\n (_, _, 0xff1b) -> withMouseState (mouseMoveCancel timelineWin actions)\n >> return True\n _ -> return False\n\n ------------------------------------------------------------------------\n -- Scroll bars\n\n onValueChanged timelineAdj $ queueRedrawTimelines timelineState\n onValueChanged timelineVAdj $ queueRedrawTimelines timelineState\n onAdjChanged timelineAdj $ queueRedrawTimelines timelineState\n onAdjChanged timelineVAdj $ queueRedrawTimelines timelineState\n\n ------------------------------------------------------------------------\n -- Redrawing\n\n on timelineDrawingArea draw $ do\n liftIO $ do\n maybeEventArray <- readIORef hecsIORef\n\n -- Check to see if an event trace has been loaded\n case maybeEventArray of\n Nothing -> return ()\n Just hecs -> do\n params <- timelineGetViewParameters timelineWin\n -- render either the whole height of the timeline, or the window, whichever\n -- is larger (this just ensure we fill the background if the timeline is\n -- smaller than the window).\n (Rectangle _ _ w h)<- widgetGetAllocation timelineDrawingArea\n let params' = params { height = max (height params) h }\n selection <- readIORef selectionRef\n bookmarks <- readIORef bookmarkIORef\n\n renderView timelineState params' hecs selection bookmarks (Rectangle 0 0 w h)\n\n return ()\n\n on timelineDrawingArea configureEvent $ do\n liftIO $ configureTimelineDrawingArea timelineWin\n return True\n\n return timelineWin\n\n-------------------------------------------------------------------------------\n\nviewPointToTime :: TimelineView -> Double -> IO Timestamp\nviewPointToTime TimelineView{timelineState=TimelineState{..}} x = do\n hadjValue <- adjustmentGetValue timelineAdj\n scaleValue <- readIORef scaleIORef\n let ts = round (max 0 (hadjValue + x * scaleValue))\n return $! ts\n\nviewPointToTimeNoClamp :: TimelineView -> Double -> IO Double\nviewPointToTimeNoClamp TimelineView{timelineState=TimelineState{..}} x = do\n hadjValue <- adjustmentGetValue timelineAdj\n scaleValue <- readIORef scaleIORef\n let ts = hadjValue + x * scaleValue\n return $! ts\n\nviewRangeToTimeRange :: TimelineView\n -> (Double, Double) -> IO (Timestamp, Timestamp)\nviewRangeToTimeRange view (x, x') = do\n let xMin = min x x'\n xMax = max x x'\n xv <- viewPointToTime view xMin\n xv' <- viewPointToTime view xMax\n return (xv, xv')\n\n-------------------------------------------------------------------------------\n-- Update the internal state and the timeline view after changing which\n-- traces are displayed, or the order of traces.\n\nqueueRedrawTimelines :: TimelineState -> IO ()\nqueueRedrawTimelines TimelineState{..} = do\n widgetQueueDraw timelineDrawingArea\n widgetQueueDraw timelineYScaleArea\n widgetQueueDraw timelineXScaleArea\n\n--FIXME: we are still unclear about which state changes involve which updates\ntimelineParamsChanged :: TimelineView -> IO ()\ntimelineParamsChanged timelineWin@TimelineView{timelineState} = do\n queueRedrawTimelines timelineState\n updateTimelineVScroll timelineWin\n\nconfigureTimelineDrawingArea :: TimelineView -> IO ()\nconfigureTimelineDrawingArea timelineWin@TimelineView{timelineState} = do\n updateTimelineVScroll timelineWin\n updateTimelineHPageSize timelineState\n\nupdateTimelineVScroll :: TimelineView -> IO ()\nupdateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=TimelineState{..}} = do\n traces <- readIORef tracesIORef\n labelsMode <- readIORef labelsModeIORef\n let histTotalHeight = stdHistogramHeight + histXScaleHeight\n h = calculateTotalTimelineHeight labelsMode histTotalHeight traces\n Rectangle _ _ _ winh <- widgetGetAllocation timelineDrawingArea\n let winh' = fromIntegral winh;\n h' = fromIntegral h\n adjustmentSetLower timelineVAdj 0\n adjustmentSetUpper timelineVAdj h'\n\n val <- adjustmentGetValue timelineVAdj\n when (val > h') $ adjustmentSetValue timelineVAdj h'\n\n set timelineVAdj [\n adjustmentPageSize := winh',\n adjustmentStepIncrement := winh' * 0.1,\n adjustmentPageIncrement := winh' * 0.9\n ]\n\n-- when the drawing area is resized, we update the page size of the\n-- adjustment. Everything else stays the same: we don't scale or move\n-- the view at all.\nupdateTimelineHPageSize :: TimelineState -> IO ()\nupdateTimelineHPageSize TimelineState{..} = do\n Rectangle _ _ winw _ <- widgetGetAllocation timelineDrawingArea\n scaleValue <- readIORef scaleIORef\n adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue)\n\n-------------------------------------------------------------------------------\n-- Cursor / selection and mouse interaction\n\ntimelineSetSelection :: TimelineView -> TimeSelection -> IO (Maybe TimeSelection)\ntimelineSetSelection TimelineView{..} selection = do\n mhecs <- readIORef hecsIORef\n case mhecs >>= (adjustSelection selection . hecLastEventTime) of\n Nothing -> return Nothing\n Just selection' -> do\n writeIORef selectionRef selection'\n queueRedrawTimelines timelineState\n return $ Just selection'\n where\n -- Prevent selections that are out of bounds.\n adjustSelection (PointSelection timestamp) lastTx\n | timestamp < 0 || timestamp > lastTx = Nothing\n | otherwise = Just $ PointSelection timestamp\n adjustSelection (RangeSelection start end) lastTx\n | start < 0 && end < 0 || start > lastTx && end > lastTx = Nothing\n | otherwise = Just $ RangeSelection (clampSelection lastTx start) (clampSelection lastTx end)\n\n clampSelection lastTx = clamp (0, lastTx)\n\n-- little state machine\ndata MouseState = None\n | PressLeft !Double -- left mouse button is currently pressed\n -- but not over threshold for dragging\n | DragLeft !Double -- dragging with left mouse button\n | DragMiddle !Double !Double -- dragging with middle mouse button\n\nmousePress :: TimelineView\n -> MouseState -> MouseButton -> Double -> IO MouseState\nmousePress view@TimelineView{..} state button x =\n case (state, button) of\n (None, LeftButton) -> do xv <- viewPointToTime view x\n -- update the view without notifying the client\n selection <- timelineSetSelection view (PointSelection xv)\n case selection of\n Nothing -> return None\n Just _ -> return (PressLeft x)\n (None, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorMove)\n v <- adjustmentGetValue timelineAdj\n return (DragMiddle x v)\n _ -> return state\n where\n TimelineState{timelineAdj, timelineDrawingArea} = timelineState\n\n\nmouseMove :: TimelineView -> MouseState\n -> Double -> IO MouseState\nmouseMove view@TimelineView{..} state x =\n case state of\n None -> return None\n PressLeft x0\n | dragThreshold -> mouseMove view (DragLeft x0) x\n | otherwise -> return (PressLeft x0)\n where\n dragThreshold = abs (x - x0) > 5\n DragLeft x0 -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)\n -- update the view without notifying the client\n selection <- timelineSetSelection view (RangeSelection xv xv')\n case selection of\n Nothing -> return None\n Just _ -> return (DragLeft x0)\n DragMiddle x0 v -> do xv <- viewPointToTimeNoClamp view x\n xv' <- viewPointToTimeNoClamp view x0\n scrollTo timelineState (v + (xv' - xv))\n return (DragMiddle x0 v)\n\n\nmouseMoveCancel :: TimelineView -> TimelineViewActions\n -> MouseState -> IO MouseState\nmouseMoveCancel view@TimelineView{..} TimelineViewActions{..} state =\n case state of\n PressLeft x0 -> do xv <- viewPointToTime view x0\n timelineViewSelectionChanged (PointSelection xv)\n return None\n DragLeft x0 -> do xv <- viewPointToTime view x0\n timelineViewSelectionChanged (PointSelection xv)\n return None\n DragMiddle _ _ -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)\n return None\n None -> return None\n where\n TimelineState{timelineDrawingArea} = timelineState\n\nmouseRelease :: TimelineView -> TimelineViewActions\n -> MouseState -> MouseButton -> Double -> IO MouseState\nmouseRelease view@TimelineView{..} TimelineViewActions{..} state button x =\n case (state, button) of\n (PressLeft x0, LeftButton) -> do xv <- viewPointToTime view x0\n timelineViewSelectionChanged (PointSelection xv)\n return None\n (DragLeft x0, LeftButton) -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)\n timelineViewSelectionChanged (RangeSelection xv xv')\n return None\n (DragMiddle{}, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)\n return None\n _ -> return state\n where\n TimelineState{timelineDrawingArea} = timelineState\n\n\nwidgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO ()\nwidgetSetCursor widget cursor = do\n#if MIN_VERSION_gtk3(0,12,1)\n -- TODO: get rid of this Just\n Just dw <- widgetGetWindow widget\n drawWindowSetCursor dw cursor\n#endif\n return ()\n\n-------------------------------------------------------------------------------\n\ntimelineZoomIn :: TimelineView -> IO ()\ntimelineZoomIn TimelineView{..} = do\n selection <- readIORef selectionRef\n zoomIn timelineState (selectionPoint selection)\n\ntimelineZoomOut :: TimelineView -> IO ()\ntimelineZoomOut TimelineView{..} = do\n selection <- readIORef selectionRef\n zoomOut timelineState (selectionPoint selection)\n\ntimelineZoomToFit :: TimelineView -> IO ()\ntimelineZoomToFit TimelineView{..} = do\n mhecs <- readIORef hecsIORef\n zoomToFit timelineState mhecs\n\ntimelineScrollLeft :: TimelineView -> IO ()\ntimelineScrollLeft TimelineView{timelineState} = scrollLeft timelineState\n\ntimelineScrollRight :: TimelineView -> IO ()\ntimelineScrollRight TimelineView{timelineState} = scrollRight timelineState\n\ntimelineScrollToBeginning :: TimelineView -> IO ()\ntimelineScrollToBeginning TimelineView{timelineState} =\n scrollToBeginning timelineState\n\ntimelineScrollToEnd :: TimelineView -> IO ()\ntimelineScrollToEnd TimelineView{timelineState} =\n scrollToEnd timelineState\n\n-- This one is especially evil since it relies on a shared cursor IORef\ntimelineCentreOnCursor :: TimelineView -> IO ()\ntimelineCentreOnCursor TimelineView{..} = do\n selection <- readIORef selectionRef\n centreOnCursor timelineState (selectionPoint selection)\n\nselectionPoint :: TimeSelection -> Timestamp\nselectionPoint (PointSelection x) = x\nselectionPoint (RangeSelection x x') = midpoint x x'\n where\n midpoint a b = a + (b - a) `div` 2\n" }, { "path": "GUI/TraceView.hs", "content": "module GUI.TraceView (\n TraceView,\n traceViewNew,\n TraceViewActions(..),\n traceViewSetHECs,\n traceViewGetTraces,\n ) where\n\nimport Events.HECs\nimport GUI.Types\n\nimport Graphics.UI.Gtk\nimport qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat\nimport Data.Tree\n\n\n-- | Abstract trace view object.\n--\ndata TraceView = TraceView {\n tracesStore :: TreeStore (Trace, Visibility)\n }\n\ndata Visibility = Visible | Hidden | MixedVisibility\n deriving Eq\n\n-- | The actions to take in response to TraceView events.\n--\ndata TraceViewActions = TraceViewActions {\n traceViewTracesChanged :: [Trace] -> IO ()\n }\n\ntraceViewNew :: Builder -> TraceViewActions -> IO TraceView\ntraceViewNew builder actions = do\n\n tracesTreeView <- builderGetObject builder castToTreeView \"traces_tree\"\n\n tracesStore <- treeStoreNew []\n traceColumn <- treeViewColumnNew\n textcell <- cellRendererTextNew\n togglecell <- cellRendererToggleNew\n\n let traceview = TraceView {..}\n\n treeViewColumnPackStart traceColumn textcell True\n treeViewColumnPackStart traceColumn togglecell False\n treeViewAppendColumn tracesTreeView traceColumn\n\n Compat.treeViewSetModel tracesTreeView (Just tracesStore)\n\n cellLayoutSetAttributes traceColumn textcell tracesStore $ \\(tr, _) ->\n [ cellText := renderTrace tr ]\n\n cellLayoutSetAttributes traceColumn togglecell tracesStore $ \\(_, vis) ->\n [ cellToggleActive := vis == Visible\n , cellToggleInconsistent := vis == MixedVisibility ]\n\n on togglecell cellToggled $ \\str -> do\n let path = stringToTreePath str\n Node (trace, visibility) subtrees <- treeStoreGetTree tracesStore path\n let visibility' = invertVisibility visibility\n treeStoreSetValue tracesStore path (trace, visibility')\n updateChildren tracesStore path subtrees visibility'\n updateParents tracesStore (init path)\n\n traceViewTracesChanged actions =<< traceViewGetTraces traceview\n\n return traceview\n\n where\n renderTrace (TraceHEC hec) = \"HEC \" ++ show hec\n renderTrace (TraceInstantHEC hec) = \"HEC \" ++ show hec\n renderTrace (TraceCreationHEC hec) = \"HEC \" ++ show hec\n renderTrace (TraceConversionHEC hec) = \"HEC \" ++ show hec\n renderTrace (TracePoolHEC hec) = \"HEC \" ++ show hec\n renderTrace (TraceHistogram) = \"Spark Histogram\"\n renderTrace (TraceGroup label) = label\n renderTrace (TraceActivity) = \"Activity Profile\"\n\n updateChildren tracesStore path subtrees visibility' =\n sequence_\n [ do treeStoreSetValue tracesStore path' (trace, visibility')\n updateChildren tracesStore path' subtrees' visibility'\n | (Node (trace, _) subtrees', n) <- zip subtrees [0..]\n , let path' = path ++ [n] ]\n\n updateParents :: TreeStore (Trace, Visibility) -> TreePath -> IO ()\n updateParents _ [] = return ()\n updateParents tracesStore path = do\n Node (trace, _) subtrees <- treeStoreGetTree tracesStore path\n let visibility = accumVisibility [ vis | subtree <- subtrees\n , (_, vis) <- flatten subtree ]\n treeStoreSetValue tracesStore path (trace, visibility)\n updateParents tracesStore (init path)\n\n invertVisibility Hidden = Visible\n invertVisibility _ = Hidden\n\n accumVisibility = foldr1 (\\a b -> if a == b then a else MixedVisibility)\n\n-- Find the HEC traces in the treeStore and replace them\ntraceViewSetHECs :: TraceView -> HECs -> IO ()\ntraceViewSetHECs TraceView{tracesStore} hecs = do\n treeStoreClear tracesStore\n -- for testing only (e.g., to compare with histogram of data from interval\n -- or to compare visually with other traces):\n -- treeStoreInsert tracesStore [] 0 (TraceHistogram, Visible)\n go 0\n treeStoreInsert tracesStore [] 0 (TraceActivity, Visible)\n where\n newT = Node { rootLabel = (TraceGroup \"HEC Traces\", Visible),\n subForest = [ Node { rootLabel = (TraceHEC k, Visible),\n subForest = [] }\n | k <- [ 0 .. hecCount hecs - 1 ] ] }\n newI = Node { rootLabel = (TraceGroup \"Instant Events\", Hidden),\n subForest = [ Node { rootLabel = (TraceInstantHEC k, Hidden),\n subForest = [] }\n | k <- [ 0 .. hecCount hecs - 1 ] ] }\n nCre = Node { rootLabel = (TraceGroup \"Spark Creation\", Hidden),\n subForest = [ Node { rootLabel = (TraceCreationHEC k, Hidden),\n subForest = [] }\n | k <- [ 0 .. hecCount hecs - 1 ] ] }\n nCon = Node { rootLabel = (TraceGroup \"Spark Conversion\", Hidden),\n subForest = [ Node { rootLabel = (TraceConversionHEC k, Hidden),\n subForest = [] }\n | k <- [ 0 .. hecCount hecs - 1 ] ] }\n nPoo = Node { rootLabel = (TraceGroup \"Spark Pool\", Hidden),\n subForest = [ Node { rootLabel = (TracePoolHEC k, Hidden),\n subForest = [] }\n | k <- [ 0 .. hecCount hecs - 1 ] ] }\n go n = do\n m <- treeStoreLookup tracesStore [n]\n case m of\n Nothing -> do\n treeStoreInsertTree tracesStore [] 0 nPoo\n treeStoreInsertTree tracesStore [] 0 nCon\n treeStoreInsertTree tracesStore [] 0 nCre\n treeStoreInsertTree tracesStore [] 0 newI\n treeStoreInsertTree tracesStore [] 0 newT\n Just t ->\n case t of\n Node { rootLabel = (TraceGroup \"HEC Traces\", _) } -> do\n treeStoreRemove tracesStore [n]\n treeStoreInsertTree tracesStore [] n newT\n go (n+1)\n Node { rootLabel = (TraceGroup \"HEC Instant Events\", _) } -> do\n treeStoreRemove tracesStore [n]\n treeStoreInsertTree tracesStore [] n newI\n go (n+1)\n Node { rootLabel = (TraceGroup \"Spark Creation\", _) } -> do\n treeStoreRemove tracesStore [n]\n treeStoreInsertTree tracesStore [] n nCre\n go (n+1)\n Node { rootLabel = (TraceGroup \"Spark Conversion\", _) } -> do\n treeStoreRemove tracesStore [n]\n treeStoreInsertTree tracesStore [] n nCon\n go (n+1)\n Node { rootLabel = (TraceGroup \"Spark Pool\", _) } -> do\n treeStoreRemove tracesStore [n]\n treeStoreInsertTree tracesStore [] n nPoo\n go (n+1)\n Node { rootLabel = (TraceActivity, _) } -> do\n treeStoreRemove tracesStore [n]\n go (n+1)\n _ ->\n go (n+1)\n\ntraceViewGetTraces :: TraceView -> IO [Trace]\ntraceViewGetTraces TraceView{tracesStore} = do\n f <- getTracesStoreContents tracesStore\n return [ t | (t, Visible) <- concatMap flatten f, notGroup t ]\n where\n notGroup (TraceGroup _) = False\n notGroup _ = True\n\ngetTracesStoreContents :: TreeStore a -> IO (Forest a)\ngetTracesStoreContents tracesStore = go 0\n where\n go !n = do\n m <- treeStoreLookup tracesStore [n]\n case m of\n Nothing -> return []\n Just t -> do\n ts <- go (n+1)\n return (t:ts)\n" }, { "path": "GUI/Types.hs", "content": "module GUI.Types (\n ViewParameters(..),\n Trace(..),\n Timestamp,\n Interval,\n ) where\n\nimport GHC.RTS.Events\n\n-----------------------------------------------------------------------------\n\ndata Trace\n = TraceHEC Int\n | TraceInstantHEC Int\n | TraceCreationHEC Int\n | TraceConversionHEC Int\n | TracePoolHEC Int\n | TraceHistogram\n | TraceGroup String\n | TraceActivity\n -- more later ...\n -- | TraceThread ThreadId\n deriving Eq\n\ntype Interval = (Timestamp, Timestamp)\n\n-- the parameters for a timeline render; used to figure out whether\n-- we're drawing the same thing twice.\ndata ViewParameters = ViewParameters {\n width, height :: Int,\n viewTraces :: [Trace],\n hadjValue :: Double,\n scaleValue :: Double,\n maxSpkValue :: Double,\n detail :: Int,\n bwMode, labelsMode :: Bool,\n histogramHeight :: Int,\n minterval :: Maybe Interval,\n xScaleAreaHeight :: Int\n }\n deriving Eq\n" }, { "path": "GUI/ViewerColours.hs", "content": "-------------------------------------------------------------------------------\n--- $Id: ViewerColours.hs#2 2009/07/18 22:48:30 REDMOND\\\\satnams $\n--- $Source: //depot/satnams/haskell/ThreadScope/ViewerColours.hs $\n-------------------------------------------------------------------------------\n\nmodule GUI.ViewerColours (Color, module GUI.ViewerColours) where\n\nimport Graphics.UI.Gtk\nimport Graphics.Rendering.Cairo\n\n-------------------------------------------------------------------------------\n\n-- Colours\n\nrunningColour :: Color\nrunningColour = darkGreen\n\ngcColour :: Color\ngcColour = orange\n\ngcWaitColour :: Color\ngcWaitColour = lightOrange\n\ngcStartColour, gcWorkColour, gcIdleColour, gcEndColour :: Color\ngcStartColour = lightOrange\ngcWorkColour = orange\ngcIdleColour = lightOrange\ngcEndColour = lightOrange\n\ncreateThreadColour :: Color\ncreateThreadColour = lightBlue\n\nseqGCReqColour :: Color\nseqGCReqColour = cyan\n\nparGCReqColour :: Color\nparGCReqColour = darkBlue\n\nmigrateThreadColour :: Color\nmigrateThreadColour = darkRed\n\nthreadWakeupColour :: Color\nthreadWakeupColour = green\n\nshutdownColour :: Color\nshutdownColour = darkBrown\n\nlabelTextColour :: Color\nlabelTextColour = white\n\nbookmarkColour :: Color\nbookmarkColour = Color 0xff00 0x0000 0xff00 -- pinkish\n\nfizzledDudsColour, createdConvertedColour, overflowedColour :: Color\nfizzledDudsColour = grey\ncreatedConvertedColour = darkGreen\noverflowedColour = red\n\nuserMessageColour :: Color\nuserMessageColour = darkRed\n\nouterPercentilesColour :: Color\nouterPercentilesColour = lightGrey\n\n-------------------------------------------------------------------------------\n\nblack :: Color\nblack = Color 0 0 0\n\ngrey :: Color\ngrey = Color 0x8000 0x8000 0x8000\n\nlightGrey :: Color\nlightGrey = Color 0xD000 0xD000 0xD000\n\ngtkBorderGrey :: Color\ngtkBorderGrey = Color 0xF200 0xF100 0xF000\n\nred :: Color\nred = Color 0xFFFF 0 0\n\ngreen :: Color\ngreen = Color 0 0xFFFF 0\n\ndarkGreen :: Color\ndarkGreen = Color 0x0000 0x6600 0x0000\n\nblue :: Color\nblue = Color 0 0 0xFFFF\n\ncyan :: Color\ncyan = Color 0 0xFFFF 0xFFFF\n\nmagenta :: Color\nmagenta = Color 0xFFFF 0 0xFFFF\n\nlightBlue :: Color\nlightBlue = Color 0x6600 0x9900 0xFF00\n\ndarkBlue :: Color\ndarkBlue = Color 0 0 0xBB00\n\npurple :: Color\npurple = Color 0x9900 0x0000 0xcc00\n\ndarkPurple :: Color\ndarkPurple = Color 0x6600 0 0x6600\n\ndarkRed :: Color\ndarkRed = Color 0xcc00 0x0000 0x0000\n\norange :: Color\norange = Color 0xE000 0x7000 0x0000 -- orange\n\nlightOrange :: Color\nlightOrange = Color 0xE000 0xD000 0xB000 -- orange\n\nprofileBackground :: Color\nprofileBackground = Color 0xFFFF 0xFFFF 0xFFFF\n\ntickColour :: Color\ntickColour = Color 0x3333 0x3333 0xFFFF\n\ndarkBrown :: Color\ndarkBrown = Color 0x6600 0 0\n\nyellow :: Color\nyellow = Color 0xff00 0xff00 0x3300\n\nwhite :: Color\nwhite = Color 0xffff 0xffff 0xffff\n\n-------------------------------------------------------------------------------\nsetSourceRGBAhex :: Color -> Double -> Render ()\nsetSourceRGBAhex (Color r g b) t\n = setSourceRGBA (fromIntegral r/0xFFFF) (fromIntegral g/0xFFFF)\n (fromIntegral b/0xFFFF) t\n\n-------------------------------------------------------------------------------\n\n-------------------------------------------------------------------------------\nsetSourceRGBAForStyle :: (Style -> StateType -> IO Color) -> Style -> StateType -> Render ()\nsetSourceRGBAForStyle getColor style state = do\n color <- liftIO $ getColor style state\n setSourceRGBAhex color 1\n\n-------------------------------------------------------------------------------\n" }, { "path": "Graphics/UI/Gtk/ModelView/TreeView/Compat.hs", "content": "{-# LANGUAGE CPP #-}\nmodule Graphics.UI.Gtk.ModelView.TreeView.Compat\n ( treeViewSetModel\n ) where\nimport Graphics.UI.Gtk hiding (treeViewSetModel)\nimport qualified Graphics.UI.Gtk.ModelView.TreeView as Gtk\n#if !MIN_VERSION_gtk3(0, 14, 9)\nimport qualified System.Glib.FFI as Glib\nimport qualified Graphics.UI.GtkInternals as Gtk\n#endif\n\ntreeViewSetModel\n :: (TreeViewClass self, TreeModelClass model)\n => self\n -> Maybe model\n -> IO ()\n#if MIN_VERSION_gtk3(0, 14, 9)\ntreeViewSetModel = Gtk.treeViewSetModel\n#else\ntreeViewSetModel self model = Gtk.treeViewSetModel self\n (maybe (Gtk.TreeModel Glib.nullForeignPtr) toTreeModel model)\n#endif\n" }, { "path": "LICENSE", "content": "The Glasgow Haskell Compiler License\n\nCopyright 2002-2012, The University Court of the University of Glasgow\nand others. All rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n- Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n- Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n- Neither name of the University nor the names of its contributors may be\nused to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF\nGLASGOW AND THE CONTRIBUTORS \"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES,\nINCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND\nFITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE\nUNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT\nLIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY\nOUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH\nDAMAGE.\n" }, { "path": "Main.hs", "content": "module Main where\n\nimport GUI.Main (runGUI)\n\nimport System.Environment\nimport System.Exit\nimport System.Console.GetOpt\nimport Data.Version (showVersion)\nimport Paths_threadscope (version)\n\n-------------------------------------------------------------------------------\n\nmain :: IO ()\nmain = do\n args <- getArgs\n (flags, args') <- parseArgs args\n handleArgs flags args'\n\nhandleArgs :: Flags -> [String] -> IO ()\nhandleArgs flags args\n | flagHelp flags = printHelp\n | flagVersion flags = printVersion\n | otherwise = do\n\n initialTrace <- case (args, flagTest flags) of\n ([filename], Nothing) -> return (Just (Left filename))\n ([], Just tracename) -> return (Just (Right tracename))\n ([], Nothing) -> return Nothing\n _ -> printUsage >> exitFailure\n\n runGUI initialTrace\n\n where\n printVersion = putStrLn (\"ThreadScope version \" ++ showVersion version)\n printUsage = putStrLn usageHeader\n usageHeader = \"Usage: threadscope [eventlog]\\n\" ++\n \" or: threadscope [FLAGS]\"\n helpHeader = usageHeader ++ \"\\n\\nFlags: \"\n printHelp = putStrLn (usageInfo helpHeader flagDescrs\n ++ \"\\nFor more details see http://www.haskell.org/haskellwiki/ThreadScope_Tour\\n\")\n\n\n-------------------------------------------------------------------------------\n\ndata Flags = Flags {\n flagTest :: Maybe FilePath,\n flagVersion :: Bool,\n flagHelp :: Bool\n }\n\ndefaultFlags :: Flags\ndefaultFlags = Flags Nothing False False\n\nflagDescrs :: [OptDescr (Flags -> Flags)]\nflagDescrs =\n [ Option ['h'] [\"help\"]\n (NoArg (\\flags -> flags { flagHelp = True }))\n \"Show this help text\"\n\n , Option ['v'] [\"version\"]\n (NoArg (\\flags -> flags { flagVersion = True }))\n \"Program version\"\n\n , Option ['t'] [\"test\"]\n (ReqArg (\\name flags -> flags { flagTest = Just name }) \"NAME\")\n \"Load a named internal test (see Events/TestEvents.hs)\"\n ]\n\nparseArgs :: [String] -> IO (Flags, [String])\nparseArgs args\n | flagHelp flags = return (flags, args')\n | not (null errs) = printErrors errs\n | otherwise = return (flags, args')\n\n where\n (flags0, args', errs) = getOpt Permute flagDescrs args\n flags = foldr (flip (.)) id flags0 defaultFlags\n\n printErrors errs = do\n putStrLn $ concat errs ++ \"Try --help.\"\n exitFailure\n" }, { "path": "Makefile", "content": "# Makefile for ThreadScope\r\n\r\nGHC = c:/ghc/ghc-6.10.3/bin/ghc\r\n\r\ncabal:\r\n\tcabal install -w $(GHC) --user --prefix=$(HOME)/haskell\r\n\r\n\r\nsdist:\r\n\tcabal sdist\r\n\r\nhaddock:\r\n\tcabal haddock --executables\r\n\r\nclean:\r\n\tcabal clean\r\n" }, { "path": "README.md", "content": "# ThreadScope\n\n[![Hackage](https://img.shields.io/hackage/v/threadscope.svg)](https://hackage.haskell.org/package/threadscope)\n[![Hackage-Deps](https://img.shields.io/hackage-deps/v/threadscope.svg)](http://packdeps.haskellers.com/feed?needle=threadscope)\n![CI](https://github.com/haskell/ThreadScope/workflows/CI/badge.svg?branch=master)\n\n## Using pre-built binaries\n\nCurrently [pre-built binaries](https://github.com/haskell/ThreadScope/releases) for the following platforms are provided:\n\n* Ubuntu 24.04 (64-bit)\n* macOS 14.7\n* Windows Server 2022 (x64)\n\nGTK+3 needs to be installed for these binaries to work.\n\nOn Windows, the [MSYS2](http://www.msys2.org) is the recommended way to install GTK+3. In MSYS2 MINGW64 shell:\n\n```sh\npacman -S $MINGW_PACKAGE_PREFIX-gtk3\n```\n\nthen you can run the threadscope binary from the shell.\n\n## Building from source\n\nUse `git clone` or `cabal get threadscope` to get the source and move into the threadscope directory.\n\nThe code for the Github Actions is a good guide for building from source.\n\n### Linux\n\nGTK+3 is required to be installed. On Ubuntu-like systems:\n\n```sh\nsudo apt install libgtk-3-dev\n```\n\nThen you can build threadscope using cabal:\n\n```sh\ncabal v2-build # to only build the project, or\ncabal v2-install # to build and install the binary\n```\n\nOr using stack:\n\n```sh\nstack build # to only build the project, or\nstack install # to build and install the binary\n```\n\n### macOS\n\nGTK+ is required:\n\n```sh\nbrew install cairo gtk+3 pkg-config\n```\n\nThen you can build threadscope using cabal:\n\n```sh\ncabal --project-file=cabal.project.osx v2-build # to only build the project, or\ncabal --project-file=cabal.project.osx v2-install # to build and install the binary\n```\n\nOr using stack:\n\n```sh\nstack --stack-yaml=stack.osx.yaml build # to only build the project, or\nstack --stack-yaml=stack.osx.yaml install # to install the binary\n```\n\n### Windows\n\n> [!CAUTION]\n> The Windows instructions may be out of date. Contributions to update them would be welcome.\n\n[Chocolatey](https://chocolatey.org/) can be used to install GHC and [MSYS2](https://www.msys2.org/) is the recommended way to install GTK+.\n\n```sh\nchoco install ghc\nrefreshenv\nset PATH=C:\\\\msys64\\\\mingw64\\\\bin;C:\\\\msys64\\\\usr\\\\bin;%PATH%\npacman -Sy mingw-w64-x86_64-gtk3\n```\n\nthen you can build threadscope using cabal:\n\n```sh\ncabal v2-build\n```\n\nOr you can use stack instead.\n\nCAVEAT: gtk3 needs to be installed twice: one for stack's MSYS2 environment and another for local MSYS2 environment.\n\nIn command prompt:\n\n```sh\nstack setup\nstack exec -- pacman --needed -Sy bash pacman pacman-mirrors msys2-runtime msys2-runtime-devel\nstack exec -- pacman -Syu\nstack exec -- pacman -Syuu\nstack exec -- pacman -S base-devel mingw-w64-x86_64-pkg-config mingw-w64-x86_64-toolchain mingw-w64-x86_64-gtk3\nstack install\n```\n\nThen in MSYS2 MINGW64 shell:\n\n```sh\npacman -S $MINGW_PACKAGE_PREFIX-gtk3\necho 'export PATH=$APPDATA/local/bin:$PATH' >> .profile\nsource .profile\nthreadscope\n```\n\nBuilding using stack is not tested in CI. If you find any issues with building with stack, please update the instructions and send a PR.\n" }, { "path": "Setup.hs", "content": "import Distribution.Simple\nmain = defaultMain" }, { "path": "TODO", "content": "BUGS:\n\n- ThreadScope DEADLOCKs occasionally, more often with --debug, why?\n\n- X Window System error sometimes?\n\n- background of some widgets on Windows are white when they are grey in Linux\n\n- Make ^C work on Windows\n\n- resizing the panes causes a grab lockup?\n Happened to Mikolaj on 7.11.2011, too.\n\n- fix, rewrite or disable partial redrawing of the graphs pane\n that causes many of the graphical bugs reported below\n\n- rewrite lots of drawing code to sidestep the fixed point precision\n problem of cairo\n\n- scrolling to the right, we get some over-rendering at the boundary\n causing a thick line\n\n- (probably the same as above)\n the gray vertical lines get sometimes randomly darker when scrolling\n by moving the scrollbar handle slowly to the right (probably caused\n by testing an x coordinate up to integral division by slice or without\n taking into account the hadj_value, so the line is drawn\n many times when scrolling)\n\n- scrolling when event labels are on chops off some labels\n\n- rendering bug when scrolling: we need to clip to the rectangle being\n drawn, otherwise we overwrite other parts of the window when there\n are long bars being drawn, which makes some events disappear.\n\n- sideways scrolling leaves curve rendering artifacts (e.g., the thicker\n fragments of the flat line at the end of the Activity graph)\n\n- sometimes 2 labels are written on top of each other even at max zoom,\n e.g. \"thread 3 yielding\" and \"thread 3 is runnable\"\n\n- some sequence of enabling/disabling labels and traces leave the timeline\ntoo short to display all traces; refreshing fixed this\n\n- may be a feature: filling graphs with colours is from line 1 upwards,\n not line 0, so lines at level 0 seem under the filled area, not level with it\n\n- a few levels of zoom in and then zoom out sometimes results in only\n the rightmost fragment of the timeline shown, no indication in the scrollbar\n that scroll is possible, but scrolling indeed fixes the view\n\n- ticking the trace boxes off sometimes shows a black rectangle in place\n of the switched off graph\n\n\nOTHER:\n\n- sort bookmark view by time?\n\n- Delete key deletes bookmarks?\n\n- hotkey to add a bookmark?\n\n- 25%/50%/75% percentiles for pool size, see\nhttp://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.10.6199\nfigure 15\nWARNING: unlike mean, the median and other percentiles can't be computed\nfrom percentiles of subnodes of the trees --- they need the whole data\nfor the interval in question at each level of the tree. This increases\nthe cost from O(n) to O(n * log n), where n is the total number of samples.\nAdditional log n factor, in comparison with mean, is probably inevitable\nunless we put the data in an array, because otherwise we have to\nsort the data for each interval to find the k-th element.\nAn extra problem is that to get accurate percentiles for splices\nthat do not match a single subtree node, we have to get the whole\ndata for the splice again, completely repeating the calculations.\nThen the preprocessing via creating the tree would only be useful\nif the tree stores the whole data at each tree level, already partitioned\nand the data for each slice may be gathered cheaply (but a bit inaccurately,\nsee the use of SparkStats.rescale in the current code) by only looking\nat a few nodes of the tree at a single level, instead of traversing\na very long list. There are better data structures than the spark tree\nfor quick lookup of sorted data, so let's remove the pool sizes from\nthe spark tree altogether and hack them separately (or use the better\nstructures for everything). Use the trick with calculating percentiles\nfrom all raw data, but after quantizing it into a histogram,\nto make it tractable; the trick is orthogonal to the change of data\nrepresentation to multi-level array aggregates, but with old data\nrepresentation it may be too slow\n\n- resample the data (morally) uniformly, unless the sampling\nis changed from GC time points to equal intervals\n(note that with resampling, with enough extra inserted sample points,\nthe median approaches the mean, so calculating the median for pool size\ndoes not make sense; however, percentiles still make sense --- they are\nnot just mean*(n/m), e.g., for y=5, all percentiles are 5,\nwhile for y=x, from 0 to 10, they differ, regardless of sample density\nand uniformity, except trivial cases)\n\n- remove the grey halo in trivial cases of pool size,\nlike the line: ___/----, but keep min/max for ___/\\___\n\n- make sure the user understands that the _areas_ are proportional\nto the total number and curve points to rates and that the green area\nin spark creation and the total area in spark conversion are equal;\nperhaps tell so in the help tab or in the timeline text summary tab\n\n- the same aggregate style for the activity graph, to see min/max\n(the green area does convey the total runtime, so perhaps mark min\njust as a line, no grey shadow); or just redo it completely as the pool graphs\n\n- test, in particular the quality of sampling, on the parfib suite;\nideally generate sampled events from accurate events and compare visually\nand/or numerically\n\n- either change scale together with zoom level (and keep a colored box\nshowing how much pictures space corresponds to how many sparks (should be\nprobably constant)) or (this one implemented currently:)\nstart with the best scale for the complete view\nand the let the peaks be clipped, let the user manually readjust scale then\n\n- limit the use of save/restore and similar crude hacks\n\n- in zoom out, activity and spark graphs seem cut off at the ends,\nwhich is mathematically correct, but one more slice or even pixel\non each end would make it look better, without compromising correctness\ntoo much (just make sure the extra space does not grow with zoom level!);\nthe sparks and Activity are already rendered with (up to?) one extra slice\nat the ends, but somehow this does not show (perhaps one is not enough)\n\n- perhaps enlarge the main timeline canvas to the right to the nearest tick\n\n- perhaps draw the trace labels vertically and reduce the size\nof the Y axis area\n\n- click and drag the view (or the selected interval,\n perhaps shift-click or control-click when starting to drag)\n\n- draw the detailed view in the background\n\n- bookmarks\n - save\n - measure the time between two markers\n\n- search for events in the event window, also filter events using regexps;\nalternatively, adding more categories of events to the RTS could help\nso that the user can enable only the needed events\n\n- indicate when one thread wakes up another thread, or a thread is migrated;\nperhaps draw lines/arrows between the events?\n\n- event list view\n - respond to page up / page down / arrows (FOCUS)\n - interact with bookmarks\n\n- left pane for\n - bookmarks\n - list of traces\n - traces would be a tree-view, e.g.\n * HECs\n * 0\n * 1 etc.\n * Threads\n * 0\n * 1 etc.\n * RTS\n * live heap\n * ETW / Linux Performance counters\n * cache misses\n * stalls\n * etc.\n - some way to reorder the traces? dragging and dropping?\n - when rendering threads, we want some way to indicate the time\n between creation and death - colour grey?\n\n- a better progress bar\n\n- animate zoom level transitions:\nways to make the zoom in/out less confusing for users\n(e.g. the sudden appearance of spikiness once thresholds)\nanimating the transitions would make it clearer\ngenerate the bitmap of the higher resolution new view,\nand animate it expanding to cover the new view\nit'd be quick since it's just bitmap scaling\nso the user can see the region in the old view\nthat is expanding out to become the new view\n\n- let the user set the interval size/scale,\nas an advanced option, _separately_ for each graph stack,\neach HEC, each visible region at the current zoom level,\neach selected region (if they are implemented)\n\n- a button for vertical zoom (clip graphs if they don't fit at that zoom)\nand/or select regions of time in the view and zoom only that region of display;\n\n- an option to automatically change scale at zoom in to take\ninto account only the visible and smoothed part of the graphs\n\n- label coloured areas with a mouseover, according to what they represent\n\n- move the text entents stuff out of drawing ThreadRuns\n\n- overlay ETW events\n\n- integrate strace events in the event view on Linux (note that\nlinux perf events are already available in TS)\n\n- colour threads differently\n\n- thread names rather than numbers\n\n- live heap graph\n\n- summary analysis\n\n- perhaps draw the graphs even if only the fully-accurate,\nper-spark events are present in the logs (by transforming them\nto the sampled format)\n\n- and/or extrapolate data for large zoom levels with scarce samples\nby slated lines, not just horizontal lines (which work great with\nnumerous enough samples, though)\n\n- merge adjacent 0 samples:\nif we have equal adjacent samples we just take the second/last\ncan be done when it's still a list, before making the tree;\nsimple linear pass, and lazy too;\ndoes not make sense in per-spark events mode\n\n- use the extra info about when the spark pool gets full and empty;\nwe know when the spark pool becomes empty because we can observe\nthat the threads evaluating sparks terminate; similarly, we know overflow\nonly occurs when the pool is full; but note the following:\n\"dcoutts: also noticed that we cannot currently reliably discover when the spark\nqueue is empty. I had thought that \"the\" spark thread terminating\nimplied that the queue is empty, however there can be multiple spark\nthreads and they can also terminate when there are other threads on that\ncapability's run queue (normal forkIO work takes precedence over\nevaluating sparks)\"\n\n- consider making the graphs more accurate by drilling down the tree\nto the base events at each slice borders:\nthey don't go down to the base events at each slice boundary\nbut only at the two viewport borders (hence the extra slices\nat the ends dcoutts noticed).\nThe current state generally this results in smoothing the curve,\nbut a side-effect is that the graphs grow higher visually\n(the max is higher) as the zoom level increases.\n\n- or increase the accuracy by dividing increments not by the slice\nlength (implicitly), but the length of the sum of tree node spans\nthat cover the slice, similarly as in gnuplot graphs\n\n- perhaps we should change the spark event sampling to emit events\nevery N sparks rather than at GC; but only if experiments (do more accurate\nsampling and compare the general look of the graphs)\nshow that linear extrapolation of the GC data is not correct\n(large spark transitions happen in the long periods between GC\nand we don't know when exactly) (the 4K pool size guarantees that at least\nwith large visible absolute spark transition, the invisible transitions\ncan't be huge in proportion to the visible ones, so then linear extrapolation\nis correct))\n\n- use adaptive interval, depending on the sample density at the viewed fragment\n\n- perhaps, depending on sample density, alternate between raw data,\nmin/max, percentiles; so the raw data line slowly explodes into a band,\na big smudge, like a string of beads, that gets even more detailed\nand perhaps wider, when data density/uniformity allows it;\nin other words: a thin line means we only guess that's where the data might be\na thicker one, with mix/max means we have some data,\nbut too irregular/scarce to say more, and full thickness line,\nwith percentiles means we have enough data or evenly distributed enough\nto say all\n\n- have *configurable* colors, like in Eden; where to save them?\n\n- Eden TV has good visualisation for messages between processes & nodes,\n(steal it, when we do more work on Cloud Haskell)\n\n- show time corresponding to the eventlog buffer flushing,\nafter the event for this introduced\n\n- verify correctness of the input eventlog before visualizing; define a method\nof passing the error report from ghc-events to TS and displaying it; have\na grace period when that can be disabled via an option, until RTS and validation\nstabilize\n\n- perhaps the far left and far right bars on the histogram should be in red,\nsince extreme spark sizes are usually bad (or mark it in some other way)\n\n- or colour stacked bars of the histogram according to strategy label\n\n- determine which bars represent too small and too large sparks\nbased on the estimation of spark overhead divided by spark duration, etc.\n\n- dynamic strategy labelling (lots of stuff has to be done elsewhere, first)\n\n- mousing over or clicking a bar should tell \"1.3s worth of sparks (28 total)\nthat took between 16--64ms to evaluate\"; people want to know the number\nof sparks as well as the total eval time, in particular kosmikus wants\nto know this\n\n- either show \"Loading\" when calculating spark duration histogram\nfor a selected range on the timeline graph, or store precomputed data\nin the data structures for speedy drawing of the main timeline graphs,\nhowever they are (re)implemented in the end (mipmap or tress or anything)\n\n- manage histogram interval selection as gimp does: drag to create a selection,\nthen move the selection, etc.\n\n- extend the selection stuff, e.g. keep bookmarks sorted and let you select multiple bookmarks which would then give you a range selection\n\n- 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\n\n- 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)?\n\n- 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\n\n- select a region and display it in a separate tab\n(e.g. next to the events tab)\n\n- scroll around the graph image via a small zoomed out window\n\"The Information Mural: A Technique for Displaying\nand Navigating Large Information Spaces\"\n\n- zoom histogram for granularity: increase the number of bars,\nkeeping the min/max unchanged; that requires log with base other than 2\n\n- zoom histogram for detail: keep the number of bars the same,\nbut change the scale to only show sparks between a narrower min/max;\nfor this log 2 is enough, with a constant offset\n\n- compare any of the graphs for the whole time and for the interval: either\nby opening/detaching window/pane dedicated to the interval data\nor by a permanent tab in the bottom pane with selectable traces\nthat only ever show the data from the selected interval\nand when you zoom it, the interval changes in the upper pane\n(but histogram should not be among those traces, because it does not scroll,\ndoes not have the time X axis, and generally does not fit and is confusing)\n\n- perhaps use the tab with traces to guide what is exported to PDF/PNG;\nalso, since histogram is not among the traces, use some other UI element\nto specify in the histogram should be shown (currently disabled permanently)\n\n- events in the info pane should be searchable, and possibly numbered\n\n- selecting a range of events (via a shift-click) in the info pane should create a selection as might be done with the mouse.\n\n- select and copy events from the info pane to the OS clipboard\n\n- perhaps, on the X scale of timeline, show only offsets, to save space:\nthat is, only give the full time for the left point of the view and all other\ntimes relative to that, e.g., 2.356 s, +1ms, +2ms, etc.\n\n- and add a way to add a bookmark for a user-specified event, or a kind of events\n\n- medium-term: let the user configure which instant events shown in the trace\n\n- medium-term: user-defined visualisation frequency for the new trace (at least)\nand any other tricks needed to visualize instant events well (show density\neven if many events at almost the same spot and so the shades of green cue\nis not possible) and fast (in particular, don't draw many lines at the same spot)\nsome random user feedback on the \"lots of events\" use case of traceEvents:\n1. I don't need/use bookmarking (I can use the visual clues to jump), or even grep the event log\n2. I find the visualization helpful, but disturbing, because it hides other information\n3. it would be great to be able to visually distinguish different \"messages\"\n4. 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)\n\n- make TS useful for par-monad: generate and visualize user code / libs events, make the same kind of granularity histogram as for sparks, etc.\n\n- make TS useful for concurrent code: forkIO concurrency events, properly implement the event merging for the cluster use case\n\n- make TS useful for sequential code, in addition to showing the GC pattern\n\n- make TS useful for the cloud haskell use cases\n\n- 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\n\n- 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\n\n- a button to snap scale to a power of 10, that'd solve:\n I need a way to show two different eventlog files with the same time\n scale. The attached picture was generated from two different files, but I\n couldn't find a way to make the time scale consistent. I expect this is\n because the 'zoom' button scales the plot based on the total length of the\n eventlog file, instead of using a fixed pixels/second ratio, which it what I\n really need.\nAlternatively, have dialog to set the time scale specifically,\nas in an electronic oscilloscope, but in our case, with zoom levels\nthat multiply/divide the scale by 2, detailed settings are rather irrelevant.\n\n- another idea illustrated by an electronic oscilloscope: folding a graph\nat all occurrences of an event and showing the overlaid plot\n Given a regex named \"compute iteration N start\", find all instances of\n of this event within a user-defined time interval, and overlay the plots on\n top of each other. Ideally, each plot would be drawn partially transparent,\n so the color would be brighter when most instances were active at the same\n time since the event start. Alternatively, could could just average all the\n instances.\n I want to see if different iterations behave similarly.\n On an electronic oscilloscope this would be done the\n \"trigger\" setting. On an oscilloscope the beam traces from left to\n right on the display. When it runs off the right-hand-side it waits\n for a particular event in the signal before it starts tracing again.\n For a continuous signal the event would be that signal reaching a\n given threshold -- and the trigger knob on the bottom right-hand-side\n sets this threshold. Due to persistence-of-vision, you'd see many\n separate traces overlaid on the display. For ThreadScope the trigger\n should be a particular event selected with a regex.\n\n- show a histogram of the time difference between non-overlapping event pairs.\n Specifically, If I have events named \"image filter iteration N start\" and\n \"image filter iteration N end\" I want a histogram of how long those\n iterations took.\n\n- highlight the HEC of the current event selected in the Raw Events view\n(in the timeline)\n\n- for small screens with many HECs, make it possible to zoom the canvas\nvertically (perhaps via M-mouse wheel?)\n" }, { "path": "cabal.project", "content": "-- see http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html for more information\n\npackages: .\n" }, { "path": "cabal.project.osx", "content": "packages: .\nconstraints: gtk +have-quartz-gtk\n" }, { "path": "include/windows_cconv.h", "content": "#ifndef __WINDOWS_CCONV_H\n#define __WINDOWS_CCONV_H\n\n#if defined(i386_HOST_ARCH)\n# define WINDOWS_CCONV stdcall\n#elif defined(x86_64_HOST_ARCH)\n# define WINDOWS_CCONV ccall\n#else\n# error Unknown mingw32 arch\n#endif\n\n#endif\n" }, { "path": "index.html", "content": "\n\n\n\n\n\nThreadScope: A Graphical Profiler for Parallel and Concurrent Haskell \nPrograms\n\n\n\n\n\n

\"\" \nThreadScope

\n

Please see

\n\nhttp://www.haskell.org/haskellwiki/ThreadScope

\nand the guided tour at

\n\nhttp://www.haskell.org/haskellwiki/ThreadScope_Tour

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