diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ - 0.1 - - * No Protolude, numhask dependencies - * No default langugage extensions in package.yaml - * No tdigest diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,47 @@ +0.14 +=== +* Added charting +* Added Perf.Chart +* refactored reportMain +* expanded ReportOptions +* added more algorithms to Example +* refactored Perf.BigO +* added PerfDumpOptions +* reportOrg2D ==> report2D +* added reportBigO +* added reportTasty' +* added reportToConsole & parseClock +* refactored SpaceStats +* added tickIOWith, timesN & timesNWith +* removed measureM from Measure +* added multiN + + +0.13 +=== +* replaced rdtsc with clocks library. + +0.12.0.0 +=== +* added reportMain and support for executable development. +* refactored app/perf-explore +* created app/perf-bench and aded as a `cabal bench` thing. + +0.11.0.0 +=== +* added Perf.Count +* GHC 9.6.2 support + +0.10.0 +=== +* GHC 9.2.1 support +* inclusion of BigO + +0.9.0 +=== +* Removed deepseq dependency + +0.8.0 +=== +* GHC 9.0.1 support +* internal fixes to remove numhask dependency diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Author name here (c) 2018 +Copyright (c) 2018, Tony Day All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Author name here nor the names of other + * Neither the name of Tony Day nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/bench.hs b/app/bench.hs new file mode 100644 --- /dev/null +++ b/app/bench.hs @@ -0,0 +1,12 @@ +-- | Sum example, measured using default settings. +module Main where + +import Data.List qualified as List +import Perf +import Prelude + +main :: IO () +main = do + let l = 1000 + let a = ExampleSum + reportMain defaultReportOptions (List.intercalate "-" [show a, show @Int l]) (testExample . examplePattern a) diff --git a/app/explore.hs b/app/explore.hs new file mode 100644 --- /dev/null +++ b/app/explore.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | basic measurement and callibration +module Main where + +import Control.DeepSeq +import Control.Monad +import Control.Monad.State.Lazy +import Data.List (intercalate) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import GHC.Exts +import GHC.Generics +import Optics.Core +import Options.Applicative +import Options.Applicative.Help.Pretty +import Perf +import Prelude + +data Run = RunExample | RunExampleIO | RunSums | RunLengths | RunNoOps | RunTicks deriving (Eq, Show) + +data AppConfig = AppConfig + { appRun :: Run, + appExample :: Example, + appReportOptions :: ReportOptions + } + deriving (Eq, Show, Generic) + +defaultAppConfig :: AppConfig +defaultAppConfig = AppConfig RunExample ExampleSum defaultReportOptions + +parseRun :: Parser Run +parseRun = + flag' RunSums (long "sums" <> help "run on sum algorithms") + <|> flag' RunLengths (long "lengths" <> help "run on length algorithms") + <|> flag' RunExample (long "example" <> help "run on the example algorithm" <> style (annotate bold)) + <|> flag' RunExampleIO (long "exampleIO" <> help "exampleIO test") + <|> flag' RunNoOps (long "noops" <> help "noops test") + <|> flag' RunTicks (long "ticks" <> help "tick test") + <|> pure RunExample + +appParser :: AppConfig -> Parser AppConfig +appParser def = + AppConfig + <$> parseRun + <*> parseExample + <*> parseReportOptions (view #appReportOptions def) + +appConfig :: AppConfig -> ParserInfo AppConfig +appConfig def = + info + (appParser def <**> helper) + (fullDesc <> header "Examples of perf usage (defaults in bold)") + +-- | * exampleIO +exampleIO :: (Semigroup t) => PerfT IO t () +exampleIO = do + txt <- fam "file-read" (Text.readFile "src/Perf.hs") + n <- ffap "length" Text.length txt + fam "print-result" (Text.putStrLn $ "length of file is: " <> Text.pack (show n)) + +-- | * sums +-- | measure the various versions of a tick. +statTicks :: (NFData t, NFData b) => Text -> (t -> b) -> t -> Int -> StatDType -> StateT (Map.Map [Text] Double) IO () +statTicks l f a n s = do + addStat [l, "tick"] . statD s . fmap fromIntegral =<< lift (fst <$> multi tick n f a) + addStat [l, "tickWHNF"] . statD s . fmap fromIntegral =<< lift (fst <$> multi tickWHNF n f a) + addStat [l, "tickLazy"] . statD s . fmap fromIntegral =<< lift (fst <$> multi tickLazy n f a) + addStat [l, "tickForce"] . statD s . fmap fromIntegral =<< lift (fst <$> multi tickForce n f a) + addStat [l, "tickForceArgs"] . statD s . fmap fromIntegral =<< lift (fst <$> multi tickForceArgs n f a) + addStat [l, "stepTime"] . statD s . fmap fromIntegral =<< lift (mconcat . fmap snd . take 1 . Map.toList <$> execPerfT (toMeasureN n stepTime) (f |$| a)) + addStat [l, "times"] . statD s . fmap fromIntegral =<< lift (mconcat . fmap snd . take 1 . Map.toList <$> execPerfT (times n) (f |$| a)) + addStat [l, "timesn"] . statD s . fmap fromIntegral =<< lift (mconcat . fmap snd . Map.toList <$> execPerfT (pure <$> timesN n) (f |$| a)) + +statTicksSum :: (NFData b, Enum b, Num b) => SumPattern b -> Int -> StatDType -> StateT (Map.Map [Text] Double) IO () +statTicksSum (SumFuse label f a) n s = statTicks label f a n s +statTicksSum (SumFusePoly label f a) n s = statTicks label f a n s +statTicksSum (SumPoly label f a) n s = statTicks label f a n s +statTicksSum (SumMono label f a) n s = statTicks label f a n s + +statTicksSums :: Int -> Int -> StatDType -> IO (Map.Map [Text] Double) +statTicksSums n l s = flip execStateT Map.empty $ mapM_ (\x -> statTicksSum x n s) (allSums l) + +-- * no-op testing + +perfNoOps :: (Semigroup a) => Measure IO a -> IO (Map.Map Text a) +perfNoOps meas = + execPerfT meas $ do + liftIO $ warmup 1000 + fap "const" (const ()) () + fam "pure" (pure ()) + +main :: IO () +main = do + o <- execParser (appConfig defaultAppConfig) + let repOptions = appReportOptions o + let n = reportN repOptions + let s = reportStatDType repOptions + let mt = reportMeasureType repOptions + let c = reportClock repOptions + let !l = reportLength repOptions + let a = appExample o + let r = appRun o + + case r of + RunExample -> do + reportMain + repOptions + (intercalate "-" [show r, show a, show l]) + (testExample . examplePattern a) + RunExampleIO -> do + m1 <- execPerfT (measureDs mt c 1) exampleIO + (_, (m', m2)) <- outer "outer-total" (measureDs mt c 1) (measureDs mt c 1) exampleIO + let ms = mconcat [Map.mapKeys (\x -> ["normal", x]) m1, Map.mapKeys (\x -> ["outer", x]) (m2 <> m')] + putStrLn "" + let o' = replaceDefaultFilePath (intercalate "-" [show r, show mt, show s]) repOptions + report o' (fmap (statD s) <$> ms) + RunSums -> do + m <- statSums n l (measureDs mt c) + let o' = replaceDefaultFilePath (intercalate "-" [show r, show mt, show n, show l, show s]) repOptions + report o' (statify s m) + RunLengths -> do + m <- statLengths n l (measureDs mt c) + let o' = replaceDefaultFilePath (intercalate "-" [show r, show mt, show n, show l, show s]) repOptions + report o' (statify s m) + RunNoOps -> do + m <- perfNoOps (measureDs mt c n) + let o' = replaceDefaultFilePath (intercalate "-" [show r, show mt, show n]) repOptions + report o' (allStats 4 (Map.mapKeys (: []) m)) + RunTicks -> do + m <- statTicksSums n l s + report2D m diff --git a/perf.cabal b/perf.cabal --- a/perf.cabal +++ b/perf.cabal @@ -1,52 +1,136 @@ cabal-version: 3.0 -name: perf -version: 0.6.0 -synopsis: Low-level run time measurement. -description: A set of tools to accurately measure time performance of Haskell programs. - perf aims to be lightweight by having minimal dependencies on standard libraries. - See the Perf module for an example and full API documentation. -category: project -homepage: https://github.com/tonyday567/perf#readme -bug-reports: https://github.com/tonyday567/perf/issues -author: Tony Day, Marco Zocca -maintainer: tonyday567@gmail.com -copyright: Tony Day -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -extra-source-files: - CHANGELOG.md +name: perf +version: 0.14.2.1 +license: BSD-3-Clause +license-file: LICENSE +copyright: Tony Day (c) 2018 +category: performance +author: Tony Day, Marco Zocca +maintainer: tonyday567@gmail.com +homepage: https://github.com/tonyday567/perf#readme +bug-reports: https://github.com/tonyday567/perf/issues +synopsis: Performance tools +description: + A set of tools to measure performance of Haskell programs. + See the Perf module and readme for an example and full API documentation. +build-type: Simple +tested-with: + ghc ==9.10.3 + ghc ==9.12.2 + ghc ==9.14.1 + +extra-doc-files: + ChangeLog.md + readme.md + source-repository head type: git location: https://github.com/tonyday567/perf +common ghc-options-exe-stanza + ghc-options: + -fforce-recomp + -funbox-strict-fields + -rtsopts + -threaded + -with-rtsopts=-N + +common ghc-options-stanza + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -fproc-alignment=64 + +common ghc2024-additions + default-extensions: + DataKinds + DerivingStrategies + DisambiguateRecordFields + ExplicitNamespaces + GADTs + LambdaCase + MonoLocalBinds + RoleAnnotations + +common ghc2024-stanza + if impl(ghc >=9.10) + default-language: + GHC2024 + else + import: ghc2024-additions + default-language: + GHC2021 + library + import: ghc-options-stanza + import: ghc2024-stanza + hs-source-dirs: src + build-depends: + base >=4.14 && <5, + boxes >=0.1.5 && <0.2, + chart-svg >=0.7 && <0.9, + clock >=0.8 && <0.9, + containers >=0.6 && <0.9, + deepseq >=1.4.4 && <1.6, + formatn >=0.2.1 && <0.4, + mtl >=2.2.2 && <2.4, + numhask-space >=0.10 && <0.14, + optics-core >=0.4.1 && <0.5, + optparse-applicative >=0.17 && <0.20, + prettychart >=0.3 && <0.4, + prettyprinter >=1.7.1 && <1.8, + recursion-schemes >=5.2.2 && <5.3, + text >=1.2 && <2.2, + vector >=0.12.3 && <0.14, + exposed-modules: - Perf - Perf.Measure - Perf.Cycle - hs-source-dirs: - src - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + Perf + Perf.Algos + Perf.BigO + Perf.Chart + Perf.Count + Perf.Measure + Perf.Report + Perf.Space + Perf.Stats + Perf.Time + Perf.Types + + ghc-options: -O2 + +executable perf-explore + import: ghc-options-exe-stanza + import: ghc-options-stanza + import: ghc2024-stanza + main-is: explore.hs + hs-source-dirs: app build-depends: - base >=4.7 && <5 - , containers - , deepseq - , foldl - , rdtsc - , text - , time - , transformers - default-language: Haskell2010 + base >=4.14 && <5, + containers >=0.6 && <0.9, + deepseq >=1.4.4 && <1.6, + mtl >=2.2.2 && <2.4, + optics-core >=0.4.1 && <0.5, + optparse-applicative >=0.17 && <0.20, + perf, + text >=1.2 && <2.2, -test-suite test - type: exitcode-stdio-1.0 - main-is: test.hs - hs-source-dirs: - test - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + ghc-options: -O2 + +benchmark perf-bench + import: ghc-options-exe-stanza + import: ghc-options-stanza + import: ghc2024-stanza + main-is: bench.hs + hs-source-dirs: app build-depends: - base >=4.7 && <5 - , doctest - default-language: Haskell2010 + base >=4.14 && <5, + perf, + + ghc-options: -O2 + type: exitcode-stdio-1.0 diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,526 @@ +[![img](https://img.shields.io/hackage/v/perf.svg)](https://hackage.haskell.org/package/perf) [![img](https://github.com/tonyday567/perf/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/tonyday567/perf/actions/workflows/haskell-ci.yml) + + +# Features + +`perf` is an experimental library with a focus on the low-level empirics of Haskell code performance. If you are looking for a quick and reliable performance benchmark, criterion and tasty-bench are both good choices. If your results are confounding, however, you may need to dig deeper, and this is the problem space of `perf`. + +The library: + +- provides a monad transformer, `PerfT`. The criterion API tends towards an atomistic approach - bust code up into snippets, copy-paste into a bench.hs and measure their isolated performance. In contrast, with `PerfT` performance can be measured within a code snippet’s original context. Differing code points can be labelled and measured as part of a single run, encouraging a much faster observation - experimentation - refactor cycle. + +- is polymorphic to what, exactly, is being measured, so that concepts such as counters, debug checks, time and space performance can share treatment. + +- attempts to measure big O for algorithms that can be defined in terms of input size growth. + +- includes live charting of raw performance results via chart-svg and prettychart + + +# Usage + +Probably the best introduction to `perf` is via the perf-explore executable: + + perf-explore + + label1 label2 old result new result change + + sum time 9.93e3 7.57e3 improvement + +Summing [1..1000] took 9,930 nanoseconds, an improvement versus the on file performance previously measured. + +Live charts of raw performance measurement can be obtained via the prettychart library with: + + cabal install prettychart + prettychart-watch --watch --filepath other --port 3566 + +… and pointer your browser at localhost:3566 + + perf-explore -n 1000 --nocheck --chart + +![img](other/perf.svg) + +In this particular measure, there was an improvement, dropping from about 10,000 nanos to 8,600 nanos. Increasing the number of measurements: + + perf-explore -n 20000 --nocheck --chart --chartpath other/perf20000.svg + +![img](other/perf20000.svg) + +Improvements seem to continue as n increases before stabilising (after a GC perhaps) at 3,500 nanos + + perf-explore -n 20000 --order --nocheck --tasty + + label1 label2 results + + sum time 3.51e3 + + sum:time 3.5 * O(N1) + tasty:time: 3510 + +The order of the computation (`\l -> fap sum [1 .. l]`) is O(N1) and the results are very close to the tasty-bench result. + +In comparsion, (\l -> fap (\x -> sum [1 .. x]) l): + + perf-explore --nocheck --sumFuse -n 100000 --chart --chartpath other/perffuse.svg --order + +![img](other/perffuse.svg) + + perf-explore --nocheck --sumFuse -n 100000 --order + + label1 label2 results + + sumFuse time 6.78e2 + + sumFuse:time 0.66 * O(N1) + +… is much faster. Hooray for list fusion! + + +# Issues + + +## fragility + +Results, especially for simple computations, are fragile and can show large variance in performance characteristics in identical runs, and across differing compilations. Whether this is due to library flaws or is just the nature of ghc is an open question. + + +## Statistics + +> Obligatory disclaimer: statistics is a tricky matter, there is no one-size-fits-all approach. In the absence of a good theory simplistic approaches are as (un)sound as obscure ones. Those who seek statistical soundness should rather collect raw data and process it themselves using a proper statistical toolbox. Data reported by tasty-bench is only of indicative and comparative significance. ~ [tasty-bench](https://hackage.haskell.org/package/tasty-bench-0.4/docs/Test-Tasty-Bench.html#t:Benchmarkable) + +> variance introduced by outliers: 88% (severely inflated) ~ [criterion](https://hackage.haskell.org/package/criterion) + +The library default is to report the 10th percentile as a summary statistic, and this is a matter of taste, determined mostly by the purpose of the measurement. + + +## ffap and fap + + :t ffap + + ffap + :: (Control.DeepSeq.NFData a, Control.DeepSeq.NFData b, MonadIO m, + Semigroup t) => + Text.Text -> (a -> b) -> a -> PerfT m t b + +ffap and fap are broadly similar to criterion’s nf and whnf respectively, but passes throught the results of the computation into the monad transformer, enabling in-context measurement. + +A fine-grained and detailed examination of the effect of measurement on laziness and on core details would be beneficial to the library. + + +## tasty + +The library was originally developed before tasty-bench, which does a great job of integrating into the tasty api, and a future refactor may integrate with this, rather than supply idiosyncratic methods. + + +## order + +BigOrder calculations tend to be fragile and sometimes differ from theory. + + +# Development + +This org file has been used to develop and document library innovation and testing, and may be of use to users in understanding the library. Note that running `perf` via ghci is very slow compared with an external process which accesses the compiled version of the library. + + :r + :set -Wno-type-defaults + :set -Wno-unused-do-bind + :set -Wno-name-shadowing + :set -XOverloadedStrings + :set -XOverloadedLabels + import Perf + import Perf.Report + import Data.FormatN + import qualified Data.Text as Text + import qualified Data.Text.IO as Text + import qualified Data.Map.Strict as Map + import Control.Monad + import Data.Bifunctor + import System.Clock + import Data.List qualified as List + import Control.Category ((>>>)) + import Optics.Core + import Data.Foldable + import NumHask.Space + putStrLn "ok" + import Chart hiding (tick) + import Prettychart + import Chart.Examples + import Perf.Chart + (disp,q) <- startChartServer Nothing + disp lineExample + import Prettyprinter + import Control.Monad.State.Lazy + import Text.PrettyPrint.Boxes + + Ok, 11 modules loaded. + ok + Setting phasegrhsc it>o stun... (poTrrtu e9 + 160) (cgthrcli->c to quitg)h + + l = 1000 + n = 1000 + + :{ + p = do + ffap "sum" sum [1 .. l] + ffap "sumfuse" (\x -> sum [1 .. x]) l + :} + :t p + run = runPerfT (times n) p + :t run + (res, m) <- run + :t m + median . fmap fromIntegral <$> m + + ghci| ghci| ghci| ghci| ghci> p :: (MonadIO m, Semigroup t, Control.DeepSeq.NFData b, Num b, + Enum b) => + PerfT m t b + run + :: (Control.DeepSeq.NFData a, Num a, Enum a) => + IO (a, Map.Map Text.Text [Nanos]) + m :: Map.Map Text.Text [Nanos] + fromList [("sum",21978.1),("sumfuse",26710.18)] + + +# Details + + +## System.Clock + +The default clock is MonoticRaw for linux & macOS, and ThreadCPUTime for Windows. + + +### resolution + + getRes Monotonic + getRes Realtime + getRes ProcessCPUTime + getRes ThreadCPUTime + getRes MonotonicRaw + + TimeSpec {sec = 0, nsec = 1000} + TimeSpec {sec = 0, nsec = 1000} + TimeSpec {sec = 0, nsec = 1000} + TimeSpec {sec = 0, nsec = 42} + TimeSpec {sec = 0, nsec = 42} + + +## ticks + +The various versions of tick and a variety of algorithms are artifacts of ongoing exploration. + + perf-explore -n 20000 --best --ticks + + algo stepTime tick tickForce tickForceArgs tickLazy tickWHNF times timesn + sumAux 3.11e3 3.11e3 3.11e3 3.11e3 5.13e0 3.11e3 3.11e3 3.10e3 + sumCata 3.11e3 3.11e3 3.11e3 3.11e3 5.11e0 3.11e3 3.11e3 3.14e3 + sumCo 3.11e3 3.11e3 3.11e3 3.11e3 5.06e0 3.11e3 3.11e3 3.08e3 + sumCoCase 3.11e3 3.11e3 3.11e3 3.11e3 5.11e0 3.11e3 3.11e3 3.08e3 + sumCoGo 3.11e3 3.11e3 3.11e3 3.11e3 5.06e0 3.11e3 3.11e3 3.12e3 + sumF 3.48e3 3.49e3 3.46e3 3.46e3 5.06e0 3.48e3 3.48e3 3.48e3 + sumFlip 3.48e3 3.48e3 3.45e3 3.45e3 5.03e0 3.48e3 3.48e3 3.48e3 + sumFlipLazy 3.48e3 3.48e3 3.45e3 3.45e3 4.96e0 3.48e3 3.48e3 3.45e3 + sumFoldr 3.11e3 3.11e3 3.11e3 3.11e3 5.13e0 3.11e3 3.11e3 3.11e3 + sumFuse 6.54e2 6.54e2 6.54e2 6.54e2 5.17e0 6.54e2 6.54e2 6.39e2 + sumFuseFoldl' 6.54e2 6.54e2 6.54e2 6.54e2 5.00e0 6.54e2 6.54e2 6.44e2 + sumFuseFoldr 9.93e2 9.92e2 9.92e2 9.92e2 5.13e0 9.92e2 9.93e2 9.63e2 + sumFusePoly 6.56e2 6.56e2 6.56e2 6.56e2 5.12e0 6.56e2 6.57e2 6.47e2 + sumLambda 3.48e3 3.49e3 3.48e3 3.48e3 5.12e0 3.48e3 3.48e3 3.55e3 + sumMono 3.48e3 3.48e3 3.46e3 3.46e3 5.00e0 3.48e3 3.48e3 3.50e3 + sumPoly 3.62e3 3.49e3 3.54e3 3.56e3 5.04e0 3.71e3 3.62e3 3.70e3 + sumSum 3.48e3 3.49e3 3.48e3 3.48e3 4.98e0 3.48e3 3.48e3 3.49e3 + sumTail 3.48e3 3.49e3 3.45e3 3.45e3 5.00e0 3.48e3 3.48e3 3.51e3 + sumTailLazy 3.48e3 3.48e3 3.45e3 3.45e3 5.16e0 3.48e3 3.48e3 3.49e3 + + +## Time + + +### What is a tick? + +A fundamental operation of Perf.Time is tick, which sandwiches a (strict) function application between two readings of a clock, and returns time in nanoseconds, and the computation result. In this way, the \`Perf\` monad can be inserted into the midst of a computation in an attempt to measure performance in-situ as opposed to sitting off in a separate and decontextualized process. + + :t tick + + tick :: (a -> b) -> a -> IO (Nanos, b) + +`tick` returns in the IO monad, because reading a cycle counter is an IO effect. A trivial but fundamental point is that performance measurement effects the computation being measured. + + +### tick\_ + +tick\_ measures the nanoseconds between two immediate clock reads. + + :t tick_ + + tick_ :: IO Nanos + + replicateM 10 tick_ + + [1833,500,416,416,416,375,375,416,416,416] + + +### multiple ticks + + fmap (fmap (fst)) . replicateM 10 $ tick (const ()) () + + [7000,2333,2000,2208,1958,1959,1959,2000,2000,1959] + +Here, `const () ()` was evaluated and took 7 micro-seconds for the first effect, reducing down to 2 msecs after 10 effects. + + +### tickIO + +`tickIO` measures the evaluation of an IO value. + + :t tickIO + + tickIO :: IO a -> IO (Cycles, a) + + fmap (fmap fst) . replicateM 10 $ tickIO (pure ()) + + [5541,1625,1458,1833,1375,1416,1375,1375,1375,1375] + + +### sum example + + fmap (expt (Just 2) . fromIntegral) . fst <$> ticks 10 sum ([1..10000] :: [Double]) + + ["5.0e5","2.4e5","2.4e5","2.4e5","2.4e5","2.4e5","2.4e5","2.4e5","2.5e5","2.4e5"] + + ts <- ticks 10000 sum ([1..1000] :: [Double]) + print $ average (fmap fromIntegral $ fst ts) + + 10747.1975 + + +## PerfT + +`PerfT` allows for multiple measurement points and is polymorphic in what is being measured. It returns a Map of results held in State. + +Compare a lower-level usage of ticks, measuring the average of summing to one thousand over one thousand trials: + + first (average . fmap fromIntegral) <$> ticks 1000 sum [1..1000] + + (25947.635,500500) + +… with PerfT usage + + second (fmap (average . fmap fromIntegral)) <$> runPerfT (times 1000) (sum |$| [1..1000]) + + (500500,fromList [("",26217.098)]) + +An IO example + + exampleIO' :: IO () + exampleIO' = do + txt <- Text.readFile "src/Perf.hs" + let n = Text.length txt + Text.putStrLn $ "length of file is: " <> Text.pack (show n) + + exampleIO = execPerfT time (do + txt <- fam "file_read" (Text.readFile "src/Perf.hs") + n <- fap "length" Text.length txt + fam "print_result" (Text.putStrLn $ "length of file is: " <> Text.pack (show n))) + + perf-explore --exampleIO + + length of file is: 1794 + length of file is: 1794 + + label1 label2 label3 old result new result change + + normal file-read time 2.31e5 1.28e5 improvement + normal length time 2.71e3 2.00e3 improvement + normal print-result time 3.75e4 1.32e4 improvement + outer file-read time 6.05e4 3.64e4 improvement + outer length time 9.59e2 6.25e2 improvement + outer outer-total time 7.39e4 4.02e4 improvement + outer print-result time 9.79e3 1.71e3 improvement + + +## Perf.BigO + +Perf.BigO represents functionality to determine the complexity order for a computation. + +We could do a regression and minimise the error term, but we know that the largest run contains the most information; we would need to weight the simulations according to some heuristic. + +Instead, we: + +- estimate the order factor for each possible Order, from N3 to N0, setting the highest n run constant factor to zero, +- pick the order based on lowest absolute error result summed across all the runs, + + import qualified Prelude as P + import Data.List (nub) + estOrder (\x -> sum $ nub [1..x]) 100 [10,100,1000,1000] + + BigOrder {bigOrder = N2, bigFactor = 3.187417} + + import qualified Prelude as P + import Data.List (nub) + estOrder (\x -> sum $ [1..x]) 10 [1,10,100,1000] + + BigOrder {bigOrder = N12, bigFactor = 695.0370069284081, bigConstant = 0.0} + + +## References + + + +[The Haskell performance checklist](https://github.com/haskell-perf/checklist) + +[ndmitchell/spaceleak: Notes on space leaks](https://github.com/ndmitchell/spaceleak) + + +### Core + +[5.13. Debugging the compiler](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/debugging.html#options-debugging) + + ghc app/speed.hs -ddump-simpl -ddump-to-file -fforce-recomp -dlint -O + +[haskell wiki: Looking at the Core](https://wiki.haskell.org/Performance/GHC#Looking_at_the_Core) + +[godbolt](https://godbolt.org/) + +[ghc issue 15185: Enum instance for IntX / WordX are inefficient](https://gitlab.haskell.org/ghc/ghc/-/issues/15185) + +[fixpt - All About Strictness Analysis (part 1)](https://fixpt.de/blog/2017-12-04-strictness-analysis-part-1.html) + + +### Profiling + +1. setup + + [8. Profiling](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/profiling.html#prof-heap) + + A typical configuration step for profiling: + + cabal configure --enable-library-profiling --enable-executable-profiling -fprof-auto -fprof -write-ghc-environment-files=always + + A cabal.project.local with profiling enabled: + + > write-ghc-environment-files: always + > ignore-project: False + > flags: +prof +prof-auto + > library-profiling: True + > executable-profiling: True + + Examples from markup-parse R&D: + + Executable compilation: + + ghc -prof -fprof-auto -rtsopts app/speed0.hs -threaded -fforce-recomp + + Executable run: + + app/speed0 +RTS -s -p -hc -l -RTS + +2. Space usage output (-s) + + 885,263,472 bytes allocated in the heap + 8,507,448 bytes copied during GC + 163,200 bytes maximum residency (4 sample(s)) + 27,752 bytes maximum slop + 6 MiB total memory in use (0 MiB lost due to fragmentation) + + Tot time (elapsed) Avg pause Max pause + Gen 0 207 colls, 0 par 0.009s 0.010s 0.0001s 0.0002s + Gen 1 4 colls, 0 par 0.001s 0.001s 0.0004s 0.0005s + + TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1) + + SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled) + + INIT time 0.006s ( 0.006s elapsed) + MUT time 0.367s ( 0.360s elapsed) + GC time 0.010s ( 0.011s elapsed) + RP time 0.000s ( 0.000s elapsed) + PROF time 0.000s ( 0.000s elapsed) + EXIT time 0.001s ( 0.001s elapsed) + Total time 0.384s ( 0.380s elapsed) + +3. Cost center profile (-p) + + Dumped to speed0.prof + + COST CENTRE MODULE SRC %time %alloc + + token MarkupParse src/MarkupParse.hs:(259,1)-(260,20) 50.2 50.4 + wrappedQ' MarkupParse.FlatParse src/MarkupParse/FlatParse.hs:(215,1)-(217,78) 20.8 23.1 + ws_ MarkupParse.FlatParse src/MarkupParse/FlatParse.hs:(135,1)-(146,4) 14.3 5.5 + eq MarkupParse.FlatParse src/MarkupParse/FlatParse.hs:243:1-30 10.6 11.1 + gather MarkupParse src/MarkupParse.hs:(420,1)-(428,100) 2.4 3.7 + runParser FlatParse.Basic src/FlatParse/Basic.hs:(217,1)-(225,24) 1.0 6.0 + +4. heap analysis (-hc -l) + + eventlog2html speed0.eventlog + + Produces speed0.eventlog.html which contains heap charts. + + +### Cache speed + +The average cycles per + operation can get down to about 0.7 cycles, and there are about 4 cache registers per cycle, so a sum pipeline uses 2.8 register instructions per +. + + + + +++ ++ ++ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CachensecsCycles
register0.14 per cycle
L1 Cache access13-4 cycles
L2 Cache access411-12 cycles
L3 unified access1430 - 40
DRAM hit80195 cycles
L1 miss1640 cycles
L2 miss>250>600 cycles
+ diff --git a/src/Perf.hs b/src/Perf.hs --- a/src/Perf.hs +++ b/src/Perf.hs @@ -1,133 +1,45 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -Wall #-} - -- | == Introduction --- --- 'perf' provides high-resolution measurements of the runtime of Haskell functions. It does so by reading the RDTSC register (TSC stands for "time stamp counter"), which is present on all x86 CPUs since the Pentium architecture. -- --- With 'perf' the user may measure both pure and effectful functions, as shown in the Example below. Every piece of code the user may want to profile is passed as an argument to the 'perf' function, along with a text label (that will be displayed in the final summary) and the measurement function (e.g. 'cycles', 'cputime' or 'realtime'). --- ---'PerfT' is a monad transformer designed to collect performance information. --- The transformer can be used to add performance measurent to existing code using 'Measure's. --- --- == Example : --- --- Code block to be profiled : --- --- > result <- do --- > txt <- readFile "examples/examples.hs" --- > let n = Text.length txt --- > let x = foldl' (+) 0 [1..n] --- > putStrLn $ "sum of one to number of characters is: " <> --- > (show x :: Text) --- > pure (n, x) --- --- The same code, instrumented with 'perf' : +-- @perf@ provides tools for measuring the runtime performance of Haskell functions. It includes: -- --- > (result', ms) <- runPerfT $ do --- > txt <- perf "file read" cycles $ readFile "examples/examples.hs" --- > n <- perf "length" cycles $ pure (Text.length txt) --- > x <- perf "sum" cycles $ pure (foldl' (+) 0 [1..n]) --- > perf "print to screen" cycles $ --- > putStrLn $ "sum of one to number of characters is: " <> --- > (show x :: Text) --- > pure (n, x) +-- - time measurement via the [clock](https://hackage.haskell.org/package/clock) library. -- --- Running the code produces a tuple of the original computation results, and a Map of performance measurements that were specified. Indicative results: +-- - a polymorphic approach to what a 'Measure' is so that a wide variety of measurements such as counting, space and time measurement can share the same API. -- --- > file read 4.92e5 cycles --- > length 1.60e6 cycles --- > print to screen 1.06e5 cycles --- > sum 8.12e3 cycles +-- - 'PerfT' which is a monad transformer designed to add the collection of performance information to existing code. Running the code produces a tuple of the original computation results, and a Map of performance measurements that were specified. -- --- == Note on RDTSC +-- - functionality to determine performance order, in 'Perf.BigO' -- --- Measuring program runtime with RDTSC comes with a set of caveats, such as portability issues, internal timer consistency in the case of multiprocessor architectures, and flucturations due to power throttling. For more details, see : https://en.wikipedia.org/wiki/Time_Stamp_Counter +-- - reporting functionality encapsulated in 'Perf.Report'. @perf@ can be run via 'cabal bench' and will, for example, error on performance degradation; see the project's cabal file for an example. module Perf - ( PerfT - , Perf - , perf - , perfN - , runPerfT - , evalPerfT - , execPerfT - , module Perf.Cycle - , module Perf.Measure + ( -- * re-exports + module Perf.Types, + -- | Representation of what a Performance 'Measure' is. + module Perf.Measure, + -- | Low-level time performance 'Measure' counting 'Nanos' + module Perf.Time, + -- | Low-level space performance 'Measure's based on GHC's allocation statistics. + module Perf.Space, + -- | Simple loop counter + module Perf.Count, + -- | Various (fast loop) algorithms that have been used for testing perf functionality. + module Perf.Algos, + -- | Order of complexity computations + module Perf.BigO, + -- | Reporting + module Perf.Report, + -- | Statistical support + module Perf.Stats, ) - where +where -import Control.Monad.IO.Class -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State (StateT(..), evalStateT, runStateT, execStateT, get, put ) -import Data.Functor.Identity -import Perf.Cycle +import Perf.Algos +import Perf.BigO +import Perf.Count import Perf.Measure -import qualified Data.Map as Map -import qualified Data.Text as T - --- $setup --- >>> import Perf.Cycle --- >>> import Data.Foldable (foldl') - --- | PerfT is polymorphic in the type of measurement being performed. --- The monad stores and produces a Map of labelled measurement values -newtype PerfT m b a = PerfT - { runPerf_ :: StateT (Map.Map T.Text b) m a - } deriving (Functor, Applicative, Monad) - --- | The obligatory transformer over Identity -type Perf b a = PerfT Identity b a - -instance (MonadIO m) => MonadIO (PerfT m b) where - liftIO = PerfT . liftIO - --- | Lift a monadic computation to a PerfT m, providing a label and a 'Measure'. -perf :: (MonadIO m, Additive b) => T.Text -> Measure m b -> m a -> PerfT m b a -perf label m a = - PerfT $ do - st <- get - (m', a') <- lift $ runMeasure m a - put $ Map.insertWith add label m' st - return a' - --- | Lift a monadic computation to a PerfT m, and carry out the computation multiple times. -perfN :: - (MonadIO m, Monoid b) - => Int - -> T.Text - -> Measure m b - -> m a - -> PerfT m b a -perfN n label m a = - PerfT $ do - st <- get - (m', a') <- lift $ runMeasureN n m a - put $ Map.insertWith (<>) label m' st - return a' - --- | Consume the PerfT layer and return a (result, measurement). --- --- >>> :set -XOverloadedStrings --- >>> (cs, result) <- runPerfT $ perf "sum" cycles (pure $ foldl' (+) 0 [0..10000]) --- --- > (50005000,fromList [("sum",562028)]) -runPerfT :: PerfT m b a -> m (a, Map.Map T.Text b) -runPerfT p = flip runStateT Map.empty $ runPerf_ p - --- | Consume the PerfT layer and return the original monadic result. --- Fingers crossed, PerfT structure should be completely compiled away. --- --- >>> result <- evalPerfT $ perf "sum" cycles (pure $ foldl' (+) 0 [0..10000]) --- --- > 50005000 -evalPerfT :: Monad m => PerfT m b a -> m a -evalPerfT p = flip evalStateT Map.empty $ runPerf_ p - --- | Consume a PerfT layer and return the measurement. --- --- >>> cs <- execPerfT $ perf "sum" cycles (pure $ foldl' (+) 0 [0..10000]) --- --- > fromList [("sum",562028)] -execPerfT :: Monad m => PerfT m b a -> m (Map.Map T.Text b) -execPerfT p = flip execStateT Map.empty $ runPerf_ p +import Perf.Report +import Perf.Space +import Perf.Stats +import Perf.Time +import Perf.Types +import Prelude hiding (cycle) diff --git a/src/Perf/Algos.hs b/src/Perf/Algos.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Algos.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant lambda" #-} +{-# HLINT ignore "Avoid lambda" #-} +{-# HLINT ignore "Use foldr" #-} +{-# HLINT ignore "Use sum" #-} + +-- | Algorithms and functions for testing purposes +module Perf.Algos + ( -- * command-line options + Example (..), + parseExample, + ExamplePattern (..), + examplePattern, + exampleLabel, + testExample, + + -- * sum algorithms + SumPattern (..), + allSums, + testSum, + statSums, + sumTail, + sumTailLazy, + sumFlip, + sumFlipLazy, + sumCo, + sumCoGo, + sumCoCase, + sumAux, + sumFoldr, + sumCata, + sumSum, + sumMono, + sumPoly, + sumLambda, + sumF, + sumFuse, + sumFusePoly, + sumFuseFoldl', + sumFuseFoldr, + + -- * length algorithms + LengthPattern (..), + allLengths, + testLength, + statLengths, + + -- * length + lengthTail, + lengthTailLazy, + lengthFlip, + lengthFlipLazy, + lengthCo, + lengthCoCase, + lengthAux, + lengthFoldr, + lengthFoldrConst, + lengthF, + lengthFMono, + + -- * recursion patterns + recurseTail, + recurseTailLazy, + recurseFlip, + recurseFlipLazy, + recurseCo, + recurseCoLazy, + recurseCata, + + -- * miscellaneous + mapInc, + constFuse, + splitHalf, + ) +where + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor +import Data.Functor.Foldable +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Options.Applicative +import Options.Applicative.Help.Pretty +import Perf.Types + +-- | Algorithm examples for testing +data Example = ExampleSumFuse | ExampleSum | ExampleLengthF | ExampleConstFuse | ExampleMapInc | ExampleNoOp | ExampleNub | ExampleFib deriving (Eq, Show) + +-- | Parse command-line options for algorithm examples. +parseExample :: Parser Example +parseExample = + flag' ExampleSumFuse (long "sumFuse" <> help "fused sum pipeline") + <|> flag' ExampleSum (long "sum" <> style (annotate bold) <> help "sum") + <|> flag' ExampleLengthF (long "lengthF" <> help "foldr id length") + <|> flag' ExampleConstFuse (long "constFuse" <> help "fused const pipeline") + <|> flag' ExampleMapInc (long "mapInc" <> help "fmap (+1)") + <|> flag' ExampleNoOp (long "noOp" <> help "const ()") + <|> flag' ExampleFib (long "fib" <> help "fibonacci") + <|> flag' ExampleNub (long "nub" <> help "List.nub") + <|> pure ExampleSum + +-- | Unification of example function applications +data ExamplePattern a + = PatternSumFuse Text ((Num a) => (a -> a)) a + | PatternSum Text ((Num a) => [a] -> a) [a] + | PatternLengthF Text ([a] -> Int) [a] + | PatternConstFuse Text (Int -> ()) Int + | PatternMapInc Text ([Int] -> [Int]) [Int] + | PatternNoOp Text (() -> ()) () + | PatternNub Text ([Int] -> [Int]) [Int] + | PatternFib Text (Int -> Integer) Int + +-- | Labels +exampleLabel :: ExamplePattern a -> Text +exampleLabel (PatternSumFuse l _ _) = l +exampleLabel (PatternSum l _ _) = l +exampleLabel (PatternLengthF l _ _) = l +exampleLabel (PatternConstFuse l _ _) = l +exampleLabel (PatternMapInc l _ _) = l +exampleLabel (PatternNoOp l _ _) = l +exampleLabel (PatternNub l _ _) = l +exampleLabel (PatternFib l _ _) = l + +-- | Convert an 'Example' to an 'ExamplePattern'. +examplePattern :: Example -> Int -> ExamplePattern Int +examplePattern ExampleSumFuse l = PatternSumFuse "sumFuse" sumFuse l +examplePattern ExampleSum l = PatternSum "sum" sum [1 .. l] +examplePattern ExampleLengthF l = PatternLengthF "lengthF" lengthF [1 .. l] +examplePattern ExampleConstFuse l = PatternConstFuse "constFuse" constFuse l +examplePattern ExampleMapInc l = PatternMapInc "mapInc" mapInc [1 .. l] +examplePattern ExampleNoOp _ = PatternNoOp "noop" (const ()) () +examplePattern ExampleNub l = PatternNub "nub" List.nub [1 .. l] +examplePattern ExampleFib l = PatternFib "fib" fib l + +-- | Convert an 'ExamplePattern' to a 'PerfT'. +testExample :: (Semigroup a, MonadIO m) => ExamplePattern Int -> PerfT m a () +testExample (PatternSumFuse label f a) = void $ ffap label f a +testExample (PatternSum label f a) = void $ ffap label f a +testExample (PatternLengthF label f a) = void $ ffap label f a +testExample (PatternConstFuse label f a) = void $ ffap label f a +testExample (PatternMapInc label f a) = void $ ffap label f a +testExample (PatternNoOp label f a) = void $ ffap label f a +testExample (PatternNub label f a) = void $ ffap label f a +testExample (PatternFib label f a) = void $ ffap label f a + +-- | Unification of sum function applications +data SumPattern a + = SumFuse Text (Int -> Int) Int + | SumFusePoly Text ((Enum a, Num a) => a -> a) a + | SumPoly Text ((Num a) => [a] -> a) [a] + | SumMono Text ([Int] -> Int) [Int] + +-- | All the sum algorithms. +allSums :: Int -> [SumPattern Int] +allSums l = + [ SumPoly "sumTail" sumTail [1 .. l], + SumPoly "sumTailLazy" sumTailLazy [1 .. l], + SumPoly "sumFlip" sumFlip [1 .. l], + SumPoly "sumFlipLazy" sumFlipLazy [1 .. l], + SumPoly "sumCo" sumCo [1 .. l], + SumPoly "sumCoGo" sumCoGo [1 .. l], + SumPoly "sumCoCase" sumCoCase [1 .. l], + SumPoly "sumAux" sumAux [1 .. l], + SumPoly "sumFoldr" sumFoldr [1 .. l], + SumPoly "sumCata" sumCata [1 .. l], + SumPoly "sumSum" sumSum [1 .. l], + SumMono "sumMono" sumMono [1 .. l], + SumPoly "sumPoly" sumPoly [1 .. l], + SumPoly "sumLambda" sumLambda [1 .. l], + SumPoly "sumF" sumF [1 .. l], + SumFuse "sumFuse" sumFuse l, + SumFusePoly "sumFusePoly" sumFusePoly l, + SumFuse "sumFuseFoldl'" sumFuseFoldl' l, + SumFuse "sumFuseFoldr" sumFuseFoldr l + ] + +-- | Convert an 'SumPattern' to a 'PerfT'. +testSum :: (Semigroup a, MonadIO m) => SumPattern Int -> PerfT m a Int +testSum (SumFuse label f a) = fap label f a +testSum (SumFusePoly label f a) = fap label f a +testSum (SumMono label f a) = fap label f a +testSum (SumPoly label f a) = fap label f a + +-- | Run a sum algorithm measurement. +statSums :: (MonadIO m) => Int -> Int -> (Int -> Measure m [a]) -> m (Map.Map Text [a]) +statSums n l m = execPerfT (m n) $ mapM_ testSum (allSums l) + +-- | tail resursive +sumTail :: (Num a) => [a] -> a +sumTail = go 0 + where + go acc [] = acc + go acc (x : xs) = go (x + acc) $! xs + +-- | lazy recursion. +sumTailLazy :: (Num a) => [a] -> a +sumTailLazy = go 0 + where + go acc [] = acc + go acc (x : xs) = go (x + acc) $! xs + +-- | With argument order flipped +sumFlip :: (Num a) => [a] -> a +sumFlip xs0 = go xs0 0 + where + go [] s = s + go (x : xs) s = go xs $! x + s + +-- | Lazy with argument order flipped. +sumFlipLazy :: (Num a) => [a] -> a +sumFlipLazy xs0 = go xs0 0 + where + go [] s = s + go (x : xs) s = go xs $ x + s + +-- | Co-routine style +sumCo :: (Num a) => [a] -> a +sumCo [] = 0 +sumCo (x : xs) = x + sumCo xs + +-- | Co-routine, go style +sumCoGo :: (Num a) => [a] -> a +sumCoGo = go + where + go [] = 0 + go (x : xs) = x + go xs + +-- | Co-routine, case-style +sumCoCase :: (Num a) => [a] -> a +sumCoCase = \case + [] -> 0 + (x : xs) -> x + sumCoCase xs + +-- | Auxillary style. +sumAux :: (Num a) => [a] -> a +sumAux = \case + [] -> b + (x : xs) -> f x (sumAux xs) + where + b = 0 + f x xs = x + xs + +-- | foldr style +sumFoldr :: (Num a) => [a] -> a +sumFoldr xs = foldr (+) 0 xs + +-- | cata style +sumCata :: (Num a) => [a] -> a +sumCata = cata $ \case + Nil -> 0 + Cons x acc -> x + acc + +-- | sum +sumSum :: (Num a) => [a] -> a +sumSum xs = sum xs + +-- | Monomorphic sum +sumMono :: [Int] -> Int +sumMono xs = foldl' (+) 0 xs + +-- | Polymorphic sum +sumPoly :: (Num a) => [a] -> a +sumPoly xs = foldl' (+) 0 xs + +-- | Lambda-style sum +sumLambda :: (Num a) => [a] -> a +sumLambda = \xs -> foldl' (+) 0 xs + +sumF' :: (Num a) => a -> (a -> a) -> a -> a +sumF' x r = \ !a -> r (x + a) + +-- | GHC-style foldr method. +sumF :: (Num a) => [a] -> a +sumF xs = foldr sumF' id xs 0 + +-- | Fusion check +sumFuse :: Int -> Int +sumFuse x = sum [1 .. x] + +-- | Fusion under polymorph +sumFusePoly :: (Enum a, Num a) => a -> a +sumFusePoly x = sum [1 .. x] + +-- | foldl' fusion +sumFuseFoldl' :: Int -> Int +sumFuseFoldl' x = foldl' (+) 0 [1 .. x] + +-- | foldr fusion +sumFuseFoldr :: Int -> Int +sumFuseFoldr x = foldr (+) 0 [1 .. x] + +-- | Unification of length function applications +data LengthPattern a + = LengthPoly Text ([a] -> Int) [a] + | LengthMono Text ([Int] -> Int) [Int] + +-- | All the length algorithms. +allLengths :: Int -> [LengthPattern Int] +allLengths l = + [ LengthPoly "lengthTail" lengthTail [1 .. l], + LengthPoly "lengthTailLazy" lengthTailLazy [1 .. l], + LengthPoly "lengthFlip" lengthFlip [1 .. l], + LengthPoly "lengthFlipLazy" lengthFlipLazy [1 .. l], + LengthPoly "lengthCo" lengthCo [1 .. l], + LengthPoly "lengthCoCase" lengthCoCase [1 .. l], + LengthPoly "lengthAux" lengthAux [1 .. l], + LengthPoly "lengthFoldr" lengthFoldr [1 .. l], + LengthPoly "lengthFoldrConst" lengthFoldrConst [1 .. l], + LengthPoly "lengthF" lengthF [1 .. l], + LengthMono "lengthFMono" lengthFMono [1 .. l] + ] + +-- | Convert an 'LengthPattern' to a 'PerfT'. +testLength :: (Semigroup a, MonadIO m) => LengthPattern Int -> PerfT m a Int +testLength (LengthMono label f a) = fap label f a +testLength (LengthPoly label f a) = fap label f a + +-- | Run a lengths algorithm +statLengths :: (MonadIO m) => Int -> Int -> (Int -> Measure m [a]) -> m (Map.Map Text [a]) +statLengths n l m = execPerfT (m n) $ mapM_ testLength (allLengths l) + +-- | tail resursive +lengthTail :: [a] -> Int +lengthTail xs0 = go 0 xs0 + where + go s [] = s + go s (_ : xs) = go (s + 1) $! xs + +-- | lazy recursion. +lengthTailLazy :: [a] -> Int +lengthTailLazy xs0 = go 0 xs0 + where + go s [] = s + go s (_ : xs) = go (s + 1) xs + +-- | With argument order flipped +lengthFlip :: [a] -> Int +lengthFlip xs0 = go xs0 0 + where + go [] s = s + go (_ : xs) s = go xs $! s + 1 + +-- | Lazy with argument order flipped. +lengthFlipLazy :: [a] -> Int +lengthFlipLazy xs0 = go xs0 0 + where + go [] s = s + go (_ : xs) s = go xs $ s + 1 + +-- | Co-routine style +lengthCo :: [a] -> Int +lengthCo [] = 0 +lengthCo (_ : xs) = 1 + lengthCo xs + +-- | Co-routine style as a Case statement. +lengthCoCase :: [a] -> Int +lengthCoCase = \case + [] -> 0 + (_ : xs) -> 1 + lengthCoCase xs + +-- | Auxillary version. +lengthAux :: [a] -> Int +lengthAux = \case + [] -> b + (x : xs) -> f x (lengthAux xs) + where + b = 0 + f _ xs = 1 + xs + +-- | foldr style +lengthFoldr :: [a] -> Int +lengthFoldr = foldr f b + where + b = 0 + f _ xs = 1 + xs + +-- | foldr style with explicit const usage. +lengthFoldrConst :: [a] -> Int +lengthFoldrConst = foldr (const (1 +)) 0 + +{- +-- from base: +-- https://hackage.haskell.org/package/base-4.16.0.0/docs/src/GHC.List.html#length +-- The lambda form turns out to be necessary to make this inline +-- when we need it to and give good performance. +{-# INLINE [0] lengthFB #-} +lengthFB :: x -> (Int -> Int) -> Int -> Int +lengthFB _ r !a = r (a + 1) + +-} +lengthF' :: (Num a) => x -> (a -> a) -> a -> a +lengthF' _ r = \ !a -> r (a + 1) + +-- | GHC style +lengthF :: [a] -> Int +lengthF xs0 = foldr lengthF' id xs0 0 + +-- | Monomorphic, GHC style +lengthFMono :: [Int] -> Int +lengthFMono xs0 = foldr lengthF' id xs0 0 + +-- * recursion patterns + +-- | Tail recursion +recurseTail :: (a -> b -> b) -> b -> [a] -> b +recurseTail f = go + where + go s [] = s + go s (x : xs) = go (f x s) $! xs + +-- | Lazy tail recursion +recurseTailLazy :: (a -> b -> b) -> b -> [a] -> b +recurseTailLazy f = go + where + go s [] = s + go s (x : xs) = go (f x s) xs + +-- | Tail resursion with flipped argument order. +recurseFlip :: (a -> b -> b) -> b -> [a] -> b +recurseFlip f s0 xs0 = go xs0 s0 + where + go [] s = s + go (x : xs) s = go xs $! f x s + +-- | Lazy tail resursion with flipped argument order. +recurseFlipLazy :: (a -> b -> b) -> b -> [a] -> b +recurseFlipLazy f s0 xs0 = go xs0 s0 + where + go [] s = s + go (x : xs) s = go xs $ f x s + +-- | Coroutine +recurseCo :: (a -> b -> b) -> b -> [a] -> b +recurseCo f s0 = go + where + go [] = s0 + go (x : xs) = f x $! go xs + +-- | Lazy, coroutine +recurseCoLazy :: (a -> b -> b) -> b -> [a] -> b +recurseCoLazy f s0 = go + where + go [] = s0 + go (x : xs) = f x $ go xs + +-- | Cata style +recurseCata :: (a -> b -> b) -> b -> [a] -> b +recurseCata f s0 = cata $ \case + Nil -> s0 + Cons x acc -> f x acc + +-- * miscellaneous + +-- | Test of const fusion +constFuse :: Int -> () +constFuse x = foldl' const () [1 .. x] + +-- | Increment a list. +mapInc :: [Int] -> [Int] +mapInc xs = fmap (+ 1) xs + +-- | Split a list. +splitHalf :: [a] -> ([a], [a]) +splitHalf xs = go xs xs + where + go (y : ys) (_ : _ : zs) = first (y :) (go ys zs) + go ys _ = ([], ys) + +-- | Fibonnacci +fib :: Int -> Integer +fib n = if n < 2 then toInteger n else fib (n - 1) + fib (n - 2) diff --git a/src/Perf/BigO.hs b/src/Perf/BigO.hs new file mode 100644 --- /dev/null +++ b/src/Perf/BigO.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | [Order of complexity](https://en.wikibooks.org/wiki/Optimizing_Code_for_Speed/Order_of_Complexity_Optimizations#:~:text=of%2DComplexity%20Reduction-,What%20is%20order%20of%20complexity%3F,*log(N)) calculations. +module Perf.BigO + ( O (..), + olist, + promote, + promote1, + promote_, + demote, + demote1, + spectrum, + Order (..), + bigO, + runtime, + BigOrder (..), + fromOrder, + toOrder, + order, + diffs, + bestO, + estO, + estOs, + makeNs, + OrderOptions (..), + defaultOrderOptions, + parseOrderOptions, + ) +where + +import Data.Bool +import Data.FormatN +import Data.List qualified as List +import Data.Maybe +import Data.Monoid +import Data.Vector qualified as V +import GHC.Generics +import Options.Applicative +import Prettyprinter +import Prelude + +-- $setup +-- >>> import qualified Data.List as List +-- >>> o = Order [0.0,1.0,100.0,0.0,0.0,0.0,0.0,0.0] +-- >>> ms = [2805.0,3476.0,9989.0,92590.0,1029074.6947660954] +-- >>> ns = [1,10,100,1000,10000] + +-- | order type +data O + = -- | cubic + N3 + | -- | quadratic + N2 + | -- | ^3/2 + N32 + | -- | N * log N + NLogN + | -- | linear + N1 + | -- | sqrt N + N12 + | -- | log N + LogN + | -- | constant + N0 + deriving (Eq, Ord, Show, Generic, Enum) + +-- | enumeration of O types +-- +-- >>> olist +-- [N3,N2,N32,NLogN,N1,N12,LogN,N0] +olist :: [O] +olist = [N3 .. N0] + +-- | functions to compute performance measure +-- +-- >>> fmap ($ 0) promote_ +-- [0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0] +-- +-- >>> fmap ($ 1) promote_ +-- [1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0] +-- +-- Ordering makes sense around N=10 +-- +-- >>> fmap ($ 10) promote_ +-- [1000.0,100.0,31.622776601683793,23.02585092994046,10.0,3.1622776601683795,2.302585092994046,1.0] +-- +-- Having NP may cause big num problems +-- +-- >>> fmap ($ 1000) promote_ +-- [1.0e9,1000000.0,31622.776601683792,6907.755278982137,1000.0,31.622776601683793,6.907755278982137,1.0] +promote_ :: [Double -> Double] +promote_ = + [ -- \n -> min maxBound (bool (2**n) zero (n<=zero)), + (^ (3 :: Integer)), + (^ (2 :: Integer)), + (** 1.5), + \n -> bool (bool (n * log n) 1 (n <= 1)) 0 (n <= 0), + id, + (** 0.5), + \n -> bool (bool (log n) 1 (n <= 1)) 0 (n <= 0), + \n -> bool 1 0 (n <= 0) + ] + +-- | a set of factors for each order, which represents a full Order specification. +newtype Order a = Order {factors :: [a]} deriving (Eq, Ord, Show, Generic, Functor) + +-- | create an Order +-- +-- >>> order N2 1 +-- Order {factors = [0,1,0,0,0,0,0,0]} +order :: (Num a) => O -> a -> Order a +order o a = Order $ replicate n 0 <> [a] <> replicate (7 - n) 0 + where + n = fromEnum o + +-- | Calculate the expected performance measure +-- +-- >>> promote (order N2 1) 10 +-- 100.0 +promote :: Order Double -> Double -> Double +promote (Order fs) n = sum (zipWith (*) fs (($ n) <$> promote_)) + +-- | Calculate the expected performance measure per n +-- +-- >>> promote (order N2 1) 10 +-- 100.0 +promote1 :: Order Double -> Double +promote1 o = promote o 1 + +-- | Calculate an Order from a given O, an n, and a total performance measurement +-- +-- A measurement of 1e6 for n=1000 with an order of N2 is: +-- +-- >>> demote N2 1000 1000000 +-- Order {factors = [0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0]} +-- +-- > promote (demote N2 n m) n m == m +demote :: O -> Double -> Double -> Order Double +demote o n m = order o (m / (promote_ List.!! fromEnum o) n) + +-- | Calculate an Order from a measure, and an O +-- +-- >>> demote1 N2 1000 +-- Order {factors = [0.0,1000.0,0.0,0.0,0.0,0.0,0.0,0.0]} +-- +-- > demote1 N2 m == demote o 1 m +demote1 :: O -> Double -> Order Double +demote1 o m = demote o 1 m + +-- | find the dominant order, and it's factor +-- +-- >>> bigO o +-- (N2,1.0) +bigO :: (Ord a, Num a) => Order a -> (O, a) +bigO (Order os) = (toEnum b, os List.!! b) + where + b = fromMaybe 7 $ List.findIndex (> 0) os + +-- | compute the runtime component of an Order, defined as the +-- difference between the dominant order and the total for a single run. +-- +-- >>> runtime o +-- 100.0 +runtime :: Order Double -> Double +runtime (Order os) = promote (Order r) 1 + where + b = fromMaybe 7 $ List.findIndex (> 0) os + r = take b os <> [0] <> drop (b + 1) os + +instance (Num a) => Num (Order a) where + -- 0 = Order $ replicate 9 0 + (+) (Order o) (Order o') = + Order (zipWith (+) o o') + negate (Order o) = Order $ negate <$> o + (*) (Order o) (Order o') = + Order (zipWith (*) o o') + abs = undefined + signum = undefined + fromInteger x = Order $ replicate 9 (fromInteger x) + +-- | A set of factors consisting of the dominant order, the dominant order factor and a constant factor +data BigOrder a = BigOrder {bigOrder :: O, bigFactor :: a} deriving (Eq, Ord, Show, Generic, Functor) + +instance Pretty (BigOrder Double) where + pretty (BigOrder o f) = pretty (decimal (Just 2) f) <> " * O(" <> viaShow o <> ")" + +-- | compute the BigOrder +-- +-- >>> fromOrder o +-- BigOrder {bigOrder = N2, bigFactor = 1.0} +fromOrder :: Order Double -> BigOrder Double +fromOrder o' = BigOrder o f + where + (o, f) = bigO o' + +-- | convert a BigOrder to an Order. +-- +-- toOrder . fromOrder is not a round trip iso. +-- +-- >>> toOrder (fromOrder o) +-- Order {factors = [0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0]} +toOrder :: BigOrder Double -> Order Double +toOrder (BigOrder o f) = order o f + +-- | The factor for each O given an n, and a measurement. +-- +-- >>> spectrum 100 10000 +-- Order {factors = [1.0e-2,1.0,10.0,21.71472409516259,100.0,1000.0,2171.4724095162587,10000.0]} +spectrum :: Double -> Double -> Order Double +spectrum n m = Order ((m /) . ($ n) <$> promote_) + +-- | The errors for a list of n's and measurements, based on the spectrum of the last measurement. +diffs :: [Double] -> [Double] -> [[Double]] +diffs ns ms = List.transpose $ zipWith (\n m -> zipWith (\o' f -> m - promote (order o' f) n) olist fs) ns ms + where + fs = factors (spectrum (List.last ns) (List.last ms)) + +-- | minimum error order for a list of measurements +-- +-- >>> bestO ns ms +-- N1 +bestO :: [Double] -> [Double] -> O +bestO ns ms = + toEnum $ + V.minIndex $ + V.fromList + (sum <$> fmap (fmap abs) (diffs ns ms)) + +-- | fit the best order for the last measurement and return it, and the error terms for the measurements +-- +-- >>> estO ns ms +-- (Order {factors = [0.0,0.0,0.0,0.0,102.90746947660953,0.0,0.0,0.0]},[2702.0925305233905,2446.9253052339045,-301.7469476609531,-10317.469476609534,0.0]) +estO :: [Double] -> [Double] -> (Order Double, [Double]) +estO [] _ = (0, []) +estO ns ms = (lasto, diff) + where + diff = diffs ns ms List.!! fromEnum o + o = bestO ns ms + lasto = demote o (List.last ns) (List.last ms) + +-- | fit orders from the last measurement to the first, using the residuals at each step. +-- +-- >>> estOs ns ms +-- [Order {factors = [0.0,0.0,0.0,0.0,102.90746947660953,0.0,0.0,0.0]},Order {factors = [0.0,0.0,-0.32626703235351473,0.0,0.0,0.0,0.0,0.0]},Order {factors = [0.0,0.0,0.0,0.0,0.0,0.0,0.0,24.520084692561625]},Order {factors = [0.0,0.0,0.0,0.0,0.0,0.0,0.0,2432.722690017952]},Order {factors = [0.0,0.0,0.0,0.0,0.0,0.0,0.0,245.1760228452299]}] +estOs :: [Double] -> [Double] -> [Order Double] +estOs ns ms = go [] ns ms + where + go os _ [] = os + go os _ [m] = os <> [order N0 m] + go os ns' ms' = let (o', res) = estO ns' ms' in go (os <> [o']) (List.init ns') (List.init res) + +makeNs :: Int -> Double -> Int -> [Int] +makeNs n0 d low = reverse $ go (next n0) [n0] + where + next n = floor (fromIntegral n / d) + go :: Int -> [Int] -> [Int] + go n acc = bool (go (next n) (acc <> [n])) acc (low >= n) + +data OrderOptions = OrderOptions + { doOrder :: Bool, + orderLow :: Int, + orderDivisor :: Double + } + deriving (Eq, Show, Generic) + +defaultOrderOptions :: OrderOptions +defaultOrderOptions = OrderOptions False 10 9 + +parseOrderOptions :: OrderOptions -> Parser OrderOptions +parseOrderOptions def = + OrderOptions + <$> switch (long "order" <> short 'o' <> help "calculate order") + <*> option auto (value (orderLow def) <> long "orderlowest" <> showDefaultWith show <> metavar "DOUBLE" <> help "smallest order test") + <*> option auto (value (orderDivisor def) <> long "orderdivisor" <> showDefaultWith show <> metavar "DOUBLE" <> help "divisor for order computation") diff --git a/src/Perf/Chart.hs b/src/Perf/Chart.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Chart.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Perf.Chart where + +import Chart +import Control.Category ((>>>)) +import Data.Bifunctor +import Data.Bool +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.Generics +import Optics.Core +import Options.Applicative +import Perf.Stats as Perf +import Prettychart + +-- m <- fromDump defaultPerfDumpOptions +data PerfChartOptions + = PerfChartOptions + { doChart :: Bool, + chartFilepath :: FilePath, + truncateAt :: Double, + doSmallChart :: Bool, + doBigChart :: Bool, + doHistChart :: Bool, + doAveragesLegend :: Bool, + averagesStyle :: Style, + averagesPaletteStart :: Int, + averagesLegend :: LegendOptions, + smallStyle :: Style, + smallHud :: HudOptions, + bigStyle :: Style, + bigHud :: HudOptions, + titleSize :: Double, + histGrain :: Int, + bigWidth :: Double, + excludeZeros :: Bool + } + deriving (Eq, Show, Generic) + +defaultPerfChartOptions :: PerfChartOptions +defaultPerfChartOptions = PerfChartOptions False "other/perf.svg" 10 True True True True (defaultGlyphStyle & set #size 0.05) 2 (defaultLegendOptions & set #place PlaceBottom & set #numStacks 3 & set #scaleChartsBy 0.2 & set #legendSize 0.3 & set #alignCharts AlignLeft & set #hgap (-0.2) & set #vgap (-0.1)) (defaultGlyphStyle & set #size 0.01 & over #color (rgb (palette 0)) & set (#color % opac') 0.3 & set (#borderColor % opac') 0.3 & set #glyphShape (gpalette 0)) defaultHudOptions (defaultGlyphStyle & set #size 0.06 & over #color (rgb (palette 0)) & set #glyphShape (gpalette 0) & set (#color % opac') 0.3 & set (#borderColor % opac') 1) (defaultHudOptions & set (#axes % each % #item % #ticks % #textTick %? #style % #size) 0.07 & over #axes (drop 1) & set (#axes % each % #item % #ticks % #tick % numTicks') (Just 2)) 0.08 100 0.2 True + +-- | Parse charting options. +parsePerfChartOptions :: PerfChartOptions -> Parser PerfChartOptions +parsePerfChartOptions def = + (\c fp trunAt small big hist avs -> PerfChartOptions c fp trunAt small big hist avs (view #averagesStyle def) (view #averagesPaletteStart def) (view #averagesLegend def) (view #smallStyle def) (view #smallHud def) (view #bigStyle def) (view #bigHud def) (view #titleSize def) (view #histGrain def) (view #bigWidth def) (view #excludeZeros def)) + <$> switch (long "chart" <> short 'c' <> help "chart the result") + <*> option str (value (view #chartFilepath def) <> showDefault <> long "chartpath" <> metavar "FILE" <> help "chart file name") + <*> option auto (value (view #truncateAt def) <> showDefaultWith show <> long "truncateat" <> help "truncate chart data (multiple of median)") + <*> switch (long "small") + <*> switch (long "big") + <*> switch (long "histogram") + <*> switch (long "averages") + +perfCharts :: PerfChartOptions -> Maybe [Text] -> Map.Map Text [[Double]] -> ChartOptions +perfCharts cfg labels m = case cs of + [c] -> c + _ -> stackCO stackn AlignLeft NoAlign 0.1 cs + where + stackn = length cs & fromIntegral & sqrt @Double & ceiling + cs = uncurry (perfChart cfg) <$> ps' + ps = mconcat $ fmap (uncurry zip . bimap (\t -> fmap ((t <> ": ") <>) (fromMaybe (Text.pack . show @Int <$> [0 ..]) labels)) List.transpose) (Map.toList m) + ps' = filter ((> 0) . sum . snd) ps + +perfChart :: PerfChartOptions -> Text -> [Double] -> ChartOptions +perfChart cfg t xs = finalChart + where + xsSmall = xs & xify & filter (_y >>> (< upperCutoff)) & filter (\x -> view #excludeZeros cfg && (_y x > 0)) + xsBig = xs & xify & filter (_y >>> (>= upperCutoff)) + med = median xs + best = tenth xs + av = Perf.average xs + upperCutoff = view #truncateAt cfg * med + + labels = + [ "average: " <> comma (Just 3) av, + "median: " <> comma (Just 3) med, + "best: " <> comma (Just 3) best + ] + (Rect _ _ y' w') = fromMaybe one $ space1 xsSmall + (Range x' z') = Range zero (fromIntegral $ length xs) + rectx = BlankChart defaultStyle [Rect x' z' y' w'] + averagesCT = named "averages" $ zipWith (\x i -> GlyphChart (view #averagesStyle cfg & set #color (palette i) & set #borderColor (palette i) & set #glyphShape (gpalette i)) [Point zero x]) [av, med, best] [(view #averagesPaletteStart cfg) ..] + + (smallDot, smallHist) = dotHistChart (view #histGrain cfg) (view #smallStyle cfg) (mempty @ChartOptions & set #chartTree (averagesCT <> named "xrange" [rectx]) & set #hudOptions (view #smallHud cfg)) xsSmall + + minb = minimum (_y <$> xsBig) + bigrange = Rect x' z' (bool minb zero (length xsBig == 1)) minb + (bigDot, bigHist) = dotHistChart (view #histGrain cfg) (view #bigStyle cfg) (mempty @ChartOptions & set #hudOptions (view #bigHud cfg) & set #chartTree (named "xrange" [BlankChart defaultStyle [bigrange]])) xsBig + + (Rect bdX bdW _ _) = fromMaybe one $ view styleBox' (asChartTree bigDot) + bdr = Just $ Rect bdX bdW (-(view #bigWidth cfg)) (view #bigWidth cfg) + (Rect bdhX bdhW _ _) = fromMaybe one $ view styleBox' (asChartTree bigHist) + bhr = Just $ Rect bdhX bdhW (-(view #bigWidth cfg)) (view #bigWidth cfg) + + finalChart = + mempty @ChartOptions + & set + #chartTree + ( stack + 2 + NoAlign + NoAlign + 0 + ( bool (asChartTree bigDot & set styleBox' bdr & pure) mempty (null xsBig) + <> bool (asChartTree bigHist & set styleBox' bhr & pure) mempty (null xsBig) + <> [ asChartTree smallDot, + asChartTree smallHist + ] + ) + ) + & set + (#hudOptions % #legends) + [Priority 10 (view #averagesLegend cfg & set #legendCharts (zipWith (\t' c -> (t', [c])) labels (toListOf chart' averagesCT)))] + & set + (#hudOptions % #titles) + [Priority 5 (defaultTitleOptions t & set (#style % #size) (view #titleSize cfg))] + +dotHistChart :: Int -> Style -> ChartOptions -> [Point Double] -> (ChartOptions, ChartOptions) +dotHistChart grain gstyle co xs = (dotCO, histCO) + where + dotCT = named "dot" [GlyphChart gstyle xs] + ys = fmap _y xs + (Range l u) = fromMaybe one (space1 ys) + r' = bool (Range l u) (Range 0 l) (l == u) + r = computeRangeTick r' (fromMaybe defaultTick (co & preview (#hudOptions % #axes % ix 1 % #item % #ticks % #tick))) + (y, w) = let (Range y' w') = r in bool (y', w') (y' - 0.5, y' + 0.5) (y' == w') + + histCO = hhistChart r grain ys & set (#markupOptions % #chartAspect) (CanvasAspect 0.3) & over #chartTree (<> unnamed [BlankChart defaultStyle [Rect 0 0 y w]]) + dotCO = co & over #chartTree (dotCT <>) + +compareCharts :: [(PerfChartOptions, Text, [Double])] -> ChartOptions +compareCharts xs = finalChart + where + xs' = xs & fmap (\(_, _, x) -> x) + cfg' = xs & fmap (\(x, _, _) -> x) + t' = xs & fmap (\(_, x, _) -> x) + cfg = case cfg' of + (c : _) -> c + [] -> defaultPerfChartOptions + xsSmall = xs' & fmap (xify >>> filter (_y >>> (< upperCutoff)) >>> filter (\x -> view #excludeZeros cfg && (_y x > 0))) + xsBig = xs' & fmap (xify >>> filter (_y >>> (>= upperCutoff))) + med = median <$> xs' + upperCutoff = view #truncateAt cfg * maximum med + + (Rect _ _ y' w') = fromMaybe one $ space1 $ mconcat xsSmall + (Range x' z') = Range zero (fromIntegral $ maximum (length <$> xs')) + rectx = BlankChart defaultStyle [Rect x' z' y' w'] + + (smallDot, smallHist) = dotHistCharts (view #histGrain cfg) (mempty @ChartOptions & set #hudOptions (view #smallHud cfg) & set #chartTree (unnamed [rectx])) (zip (view #smallStyle <$> cfg') xsSmall) + + minb = minimum (_y <$> mconcat xsBig) + bigrange = Rect x' z' (bool minb zero (length (mconcat xsBig) == 1)) minb + (bigDot, bigHist) = dotHistCharts (view #histGrain cfg) (mempty @ChartOptions & set #hudOptions (view #bigHud cfg) & set #chartTree (named "xrange" [BlankChart defaultStyle [bigrange]])) (zip (view #bigStyle <$> cfg') xsBig) + + (Rect bdX bdW _ _) = fromMaybe one $ view styleBox' (asChartTree bigDot) + bdr = Just $ Rect bdX bdW (-(view #bigWidth cfg)) (view #bigWidth cfg) + (Rect bdhX bdhW _ _) = fromMaybe one $ view styleBox' (asChartTree bigHist) + bhr = Just $ Rect bdhX bdhW (-(view #bigWidth cfg)) (view #bigWidth cfg) + + finalChart = + mempty @ChartOptions + & set + #chartTree + ( stack + 2 + NoAlign + NoAlign + 0 + ( bool (asChartTree bigDot & set styleBox' bdr & pure) mempty (null xsBig) + <> bool (asChartTree bigHist & set styleBox' bhr & pure) mempty (null xsBig) + <> [ asChartTree smallDot, + asChartTree smallHist + ] + ) + ) + & set + (#hudOptions % #legends) + [Priority 10 (view #averagesLegend cfg & set #legendCharts (zipWith (\t'' c -> (t'', [c])) t' (toListOf (#chartTree % chart') smallDot)))] + +dotHistCharts :: Int -> ChartOptions -> [(Style, [Point Double])] -> (ChartOptions, ChartOptions) +dotHistCharts grain co xs = (dotCO, histCO) + where + dotCTs = named "dot" (uncurry GlyphChart <$> xs) + ys = fmap _y . snd <$> xs + (Range l u) = fromMaybe one (space1 (mconcat ys)) + r' = bool (Range l u) (Range 0 l) (l == u) + r = computeRangeTick r' (fromMaybe defaultTick (co & preview (#hudOptions % #axes % ix 1 % #item % #ticks % #tick))) + (y, w) = let (Range y' w') = r in bool (y', w') (y' - 0.5, y' + 0.5) (y' == w') + + histCO = hhistCharts r grain (zip (fst <$> xs) ys) & set (#markupOptions % #chartAspect) (CanvasAspect 0.3) & over #chartTree (<> unnamed [BlankChart defaultStyle [Rect 0 0 y w]]) + dotCO = co & over #chartTree (dotCTs <>) diff --git a/src/Perf/Count.hs b/src/Perf/Count.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Count.hs @@ -0,0 +1,22 @@ +-- | Simple counter. +module Perf.Count + ( count, + countN, + ) +where + +import Perf.Types +import Prelude + +-- | Register 1 as a performance measure +count :: (Applicative m) => StepMeasure m Int +count = StepMeasure start stop + where + start = pure () + stop _ = pure 1 +{-# INLINEABLE count #-} + +-- | Count the number of times measured. +countN :: Int -> Measure IO Int +countN n = sum <$> toMeasureN n count +{-# INLINEABLE countN #-} diff --git a/src/Perf/Cycle.hs b/src/Perf/Cycle.hs deleted file mode 100644 --- a/src/Perf/Cycle.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | 'tick' uses the rdtsc chipset to measure time performance of a computation. --- --- The measurement unit - a 'Cycle' - is one oscillation of the chip crystal as measured by the instruction which inspects the TSC register. --- --- For reference, a computer with a frequency of 2 GHz means that one cycle is equivalent to 0.5 nanoseconds. --- -module Perf.Cycle - ( -- $setup - Cycle - , tick_ - , warmup - , tick - , tick' - , tickIO - , tickNoinline - , ticks - , ticksIO - , ns - , tickWHNF - , tickWHNF' - , tickWHNFIO - , ticksWHNF - , ticksWHNFIO - , average - ) - where - -import Control.DeepSeq (NFData(..), force) -import qualified Control.Foldl as L (fold, sum, premap, genericLength) -import Control.Monad (replicateM) -import GHC.Word (Word64) -import System.CPUTime.Rdtsc - --- $setup --- >>> import Perf.Cycle --- >>> import Data.Foldable (foldl') --- >>> let n = 1000 --- >>> let a = 1000 --- >>> let f x = foldl' (+) 0 [1 .. x] --- - --- | an unwrapped Word64 -type Cycle = Word64 - --- | tick_ measures the number of cycles it takes to read the rdtsc chip twice: the difference is then how long it took to read the clock the second time. --- --- Below are indicative measurements using tick_: --- --- >>> onetick <- tick_ --- >>> ticks' <- replicateM 10 tick_ --- >>> manyticks <- replicateM 1000000 tick_ --- >>> let average = L.fold ((/) <$> L.sum <*> L.genericLength) --- >>> let avticks = average (fromIntegral <$> manyticks) --- --- > one tick_: 78 cycles --- > next 10: [20,18,20,20,20,20,18,16,20,20] --- > average over 1m: 20.08 cycles --- > 99.999% perc: 7,986 --- > 99.9% perc: 50.97 --- > 99th perc: 24.99 --- > 40th perc: 18.37 --- > [min, 10th, 20th, .. 90th, max]: --- > 12.00 16.60 17.39 17.88 18.37 18.86 19.46 20.11 20.75 23.04 5.447e5 --- --- The distribution of tick_ measurements is highly skewed, with the maximum being around 50k cycles, which is of the order of a GC. The important point on the distribution is around the 30th to 50th percentile, where you get a clean measure, usually free of GC activity and cache miss-fires -tick_ :: IO Cycle -tick_ = do - t <- rdtsc - t' <- rdtsc - pure (t' - t) - --- | Warm up the register, to avoid a high first measurement. Without a warmup, one or more larger values can occur at the start of a measurement spree, and often are in the zone of an L2 miss. --- --- >>> t <- tick_ -- first measure can be very high --- >>> _ <- warmup 100 --- >>> t <- tick_ -- should be around 20 (3k for ghci) --- -warmup :: Int -> IO Double -warmup n = do - ts <- replicateM n tick_ - pure $ average ts - --- | tick where the arguments are lazy, so measurement may include evaluation of thunks that may constitute f and/or a -tick' :: (NFData b) => (a -> b) -> a -> IO (Cycle, b) -tick' f a = do - !t <- rdtsc - !a' <- pure (force $ f a) - !t' <- rdtsc - pure (t' - t, a') -{-# INLINE tick' #-} - --- | `tick f a` strictly evaluates f and a, then deeply evaluates f a, returning a (Cycle, f a) --- --- >>> _ <- warmup 100 --- >>> (cs, _) <- tick f a --- --- Note that feeding the same computation through tick twice may kick off sharing (aka memoization aka let floating). Given the importance of sharing to GHC optimisations this is the intended behaviour. If you want to turn this off then see -fno-full-laziness (and maybe -fno-cse). -tick :: (NFData b) => (a -> b) -> a -> IO (Cycle, b) -tick !f !a = tick' f a -{-# INLINE tick #-} - -tickNoinline :: (NFData b) => (a -> b) -> a -> IO (Cycle, b) -tickNoinline !f !a = tick' f a -{-# NOINLINE tickNoinline #-} - --- | measures and deeply evaluates an `IO a` --- --- >>> (cs, _) <- tickIO (pure (f a)) --- -tickIO :: (NFData a) => IO a -> IO (Cycle, a) -tickIO a = do - t <- rdtsc - !a' <- force <$> a - t' <- rdtsc - pure (t' - t, a') - -tickIONoinline :: (NFData a) => IO a -> IO (Cycle, a) -tickIONoinline = tickIO -{-# NOINLINE tickIONoinline #-} - --- | n measurements of a tick --- --- returns a list of Cycles and the last evaluated f a --- --- GHC is very good at finding ways to share computation, and anything measuring a computation multiple times is a prime candidate for aggresive ghc treatment. Internally, ticks uses a noinline pragma and a noinline version of to help reduce the chances of memoization, but this is an inexact science in the hands of he author, at least, so interpret with caution. --- The use of noinline interposes an extra function call, which can highly skew very fast computations. --- --- --- >>> let n = 1000 --- >>> (cs, fa) <- ticks n f a --- --- Baseline speed can be highly sensitive to the nature of the function trimmings. Polymorphic functions can tend to be slightly slower, and functions with lambda expressions can experience dramatic slowdowns. --- --- > fMono :: Int -> Int --- > fMono x = foldl' (+) 0 [1 .. x] --- > fPoly :: (Enum b, Num b, Additive b) => b -> b --- > fPoly x = foldl' (+) 0 [1 .. x] --- > fLambda :: Int -> Int --- > fLambda = \x -> foldl' (+) 0 [1 .. x] --- -ticks :: NFData b => Int -> (a -> b) -> a -> IO ([Cycle], b) -ticks n0 f a = go f a n0 [] - where - go f' a' n ts - | n <= 0 = pure (reverse ts, f a) - | otherwise = do - (t,_) <- tickNoinline f a - go f' a' (n - 1) (t:ts) -{-# NOINLINE ticks #-} - --- | n measuremenst of a tickIO --- --- returns an IO tuple; list of Cycles and the last evaluated f a --- --- >>> (cs, fa) <- ticksIO n (pure $ f a) --- -ticksIO :: (NFData a) => Int -> IO a -> IO ([Cycle], a) -ticksIO n0 a = go a n0 [] - where - go a' n ts - | n <= 0 = do - a'' <- a' - pure (reverse ts, a'') - | otherwise = do - (t,_) <- tickIONoinline a' - go a' (n - 1) (t:ts) -{-# NOINLINE ticksIO #-} - --- | make a series of measurements on a list of a's to be applied to f, for a tick function. --- --- Tends to be fragile to sharing issues, but very useful to determine computation Order --- --- > ns ticks n f [1,10,100,1000] --- -ns :: (a -> IO ([Cycle],b)) -> [a] -> IO ([[Cycle]], [b]) -ns t as = do - cs <- sequence $ t <$> as - pure (fst <$> cs, snd <$> cs) - --- | average of an Integral foldable --- --- > cAv <- average <$> ticks n f a --- -average :: (Integral a, Foldable f) => f a -> Double -average = L.fold (L.premap fromIntegral ((/) <$> L.sum <*> L.genericLength)) - --- | WHNF versions -tickWHNF :: (a -> b) -> a -> IO (Cycle, b) -tickWHNF !f !a = tickWHNF' f a - -tickWHNFNoinline :: (a -> b) -> a -> IO (Cycle, b) -tickWHNFNoinline !f !a = tickWHNF' f a -{-# NOINLINE tickWHNFNoinline #-} - --- | WHNF version -tickWHNF' :: (a -> b) -> a -> IO (Cycle, b) -tickWHNF' f a = do - !t <- rdtsc - !a' <- pure (f a) - !t' <- rdtsc - pure (t' - t, a') - --- | WHNF version -tickWHNFIO :: IO a -> IO (Cycle, a) -tickWHNFIO a = do - t <- rdtsc - !a' <- a - t' <- rdtsc - pure (t' - t, a') - -tickWHNFIONoinline :: IO a -> IO (Cycle, a) -tickWHNFIONoinline = tickWHNFIO -{-# NOINLINE tickWHNFIONoinline #-} - --- | WHNF version -ticksWHNF :: Int -> (a -> b) -> a -> IO ([Cycle], b) -ticksWHNF n0 f a = go f a n0 [] - where - go f' a' n ts - | n <= 0 = pure (reverse ts, f a) - | otherwise = do - (t,_) <- tickWHNFNoinline f a - go f' a' (n - 1) (t:ts) -{-# NOINLINE ticksWHNF #-} - --- | WHNF version -ticksWHNFIO :: Int -> IO a -> IO ([Cycle], a) -ticksWHNFIO n0 a = go a n0 [] - where - go a' n ts - | n <= 0 = do - a'' <- a' - pure (reverse ts, a'') - | otherwise = do - (t,_) <- tickWHNFIONoinline a' - go a' (n - 1) (t:ts) -{-# NOINLINE ticksWHNFIO #-} diff --git a/src/Perf/Measure.hs b/src/Perf/Measure.hs --- a/src/Perf/Measure.hs +++ b/src/Perf/Measure.hs @@ -1,158 +1,69 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} --- | Specification of a performance measurement type suitable for the 'PerfT' monad transformer. +-- | Unification of the various different performance measure types, mostly to unify reporting and data management. module Perf.Measure - ( Measure(..) - , runMeasure - , runMeasureN - , cost - , cputime - , realtime - , count - , cycles - , Additive(..) + ( MeasureType (..), + parseMeasure, + measureDs, + measureLabels, + measureFinalStat, ) - where - -import Data.Time.Clock -import GHC.Word (Word64) -import Control.Monad (replicateM_) -import Perf.Cycle -import System.CPUTime -import System.CPUTime.Rdtsc - - --- | Lightweight 'Additive' class. -class Num a => Additive a where - add :: a -> a -> a - zero :: a - -instance Additive Int where - add = (+) - zero = 0 - -instance Additive Integer where - add = (+) - zero = 0 - -instance Additive Word64 where - add = (+) - zero = 0 - -instance Additive NominalDiffTime where - add = (+) - zero = 0 - - --- $setup --- >>> import Data.Foldable (foldl') --- - --- | A Measure consists of a monadic effect prior to measuring, a monadic effect to finalise the measurement, and the value measured --- --- For example, the measure specified below will return 1 every time measurement is requested, thus forming the base of a simple counter for loopy code. --- --- >>> let count = Measure 0 (pure ()) (pure 1) -data Measure m b = forall a. (Additive b) => Measure - { measure :: b - , prestep :: m a - , poststep :: a -> m b - } - - --- | Measure a single effect. --- --- >>> r <- runMeasure count (pure "joy") --- >>> r --- (1,"joy") --- -runMeasure :: Monad m => Measure m b -> m a -> m (b, a) -runMeasure (Measure _ pre post) a = do - p <- pre - !a' <- a - m' <- post p - return (m', a') - --- | Measure once, but run an effect multiple times. --- --- >>> r <- runMeasureN 1000 count (pure "joys") --- >>> r --- (1,"joys") --- -runMeasureN :: Monad m => Int -> Measure m b -> m a -> m (b, a) -runMeasureN n (Measure _ pre post) a = do - p <- pre - replicateM_ (n - 1) a - !a' <- a - m' <- post p - return (m', a') +where --- | cost of a measurement in terms of the Measure's own units --- --- >>> r <- cost count --- >>> r --- 1 -cost :: Monad m => Measure m b -> m b -cost (Measure _ pre post) = pre >>= post +import Data.Text (Text) +import Options.Applicative +import Options.Applicative.Help.Pretty qualified as OA +import Perf.Count +import Perf.Space +import Perf.Stats +import Perf.Time +import Perf.Types +import System.Clock +import Prelude hiding (cycle) --- | a measure using 'getCPUTime' from System.CPUTime (unit is picoseconds) --- --- >>> r <- runMeasure cputime (pure $ foldl' (+) 0 [0..1000]) --- --- > (34000000,500500) --- -cputime :: Measure IO Integer -cputime = Measure 0 start stop - where - start = getCPUTime - stop a = do - t <- getCPUTime - return $ t - a +-- | Command-line measurement options. +data MeasureType = MeasureTime | MeasureNTime | MeasureSpace | MeasureSpaceTime | MeasureAllocation | MeasureCount deriving (Eq, Show) --- | a measure using 'getCurrentTime' (unit is 'NominalDiffTime' which prints as seconds) --- --- >>> r <- runMeasure realtime (pure $ foldl' (+) 0 [0..1000]) --- --- > (0.000046s,500500) --- -realtime :: Measure IO NominalDiffTime -realtime = Measure m0 start stop - where - m0 = zero :: NominalDiffTime - start = getCurrentTime - stop a = do - t <- getCurrentTime - return $ diffUTCTime t a +-- | Parse command-line 'MeasureType' options. +parseMeasure :: Parser MeasureType +parseMeasure = + flag' MeasureTime (long "time" <> style (OA.annotate OA.bold) <> help "measure time performance") + <|> flag' MeasureNTime (long "ntime" <> help "measure n*time performance") + <|> flag' MeasureSpace (long "space" <> help "measure space performance") + <|> flag' MeasureSpaceTime (long "spacetime" <> help "measure both space and time performance") + <|> flag' MeasureAllocation (long "allocation" <> help "measure bytes allocated") + <|> flag' MeasureCount (long "count" <> help "measure count") + <|> pure MeasureTime --- | a 'Measure' used to count iterations --- --- >>> r <- runMeasure count (pure ()) --- >>> r --- (1,()) --- -count :: Measure IO Int -count = Measure m0 start stop - where - m0 = 0 :: Int - start = return () - stop () = return 1 +-- | unification of the different measurements to being a list of doubles. +measureDs :: MeasureType -> Clock -> Int -> Measure IO [[Double]] +measureDs mt c n = + case mt of + MeasureTime -> fmap ((: []) . fromIntegral) <$> timesWith c n + MeasureNTime -> pure . pure . fromIntegral <$> timesNWith c n + MeasureSpace -> toMeasureN n (ssToList <$> space False) + MeasureSpaceTime -> toMeasureN n ((\x y -> ssToList x <> [fromIntegral y]) <$> space False <*> stepTime) + MeasureAllocation -> fmap ((: []) . fromIntegral) <$> toMeasureN n (allocation False) + MeasureCount -> (: []) . fmap fromIntegral <$> toMeasureN n count --- | a 'Measure' using the 'rdtsc' CPU register (units are in cycles) --- --- >>> r <- runMeasureN 1000 cycles (pure ()) --- --- > (120540,()) -- ghci-level --- > (18673,()) -- compiled with -O2 --- -cycles :: Measure IO Cycle -cycles = Measure m0 start stop - where - m0 = 0 - start = rdtsc - stop a = do - t <- rdtsc - return $ t - a +-- | unification of measurement labels +measureLabels :: MeasureType -> [Text] +measureLabels mt = + case mt of + MeasureTime -> ["time"] + MeasureNTime -> ["ntime"] + MeasureSpace -> spaceLabels + MeasureSpaceTime -> spaceLabels <> ["time"] + MeasureAllocation -> ["allocation"] + MeasureCount -> ["count"] +-- | How to fold the list of performance measures. +measureFinalStat :: MeasureType -> Int -> [Double] -> Double +measureFinalStat mt n = + case mt of + MeasureTime -> average + MeasureNTime -> (/ fromIntegral n) . sum + MeasureSpace -> average + MeasureSpaceTime -> average + MeasureAllocation -> average + MeasureCount -> sum diff --git a/src/Perf/Report.hs b/src/Perf/Report.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Report.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Reporting on performance, potentially checking versus a canned results. +module Perf.Report + ( Name, + Header (..), + parseHeader, + CompareLevels (..), + defaultCompareLevels, + parseCompareLevels, + ReportOptions (..), + defaultReportOptions, + parseReportOptions, + PerfDumpOptions (..), + defaultPerfDumpOptions, + parsePerfDumpOptions, + fromDump, + report, + reportMain, + writeResult, + readResult, + CompareResult (..), + compareNote, + report2D, + Golden (..), + defaultGolden, + parseGolden, + replaceDefaultFilePath, + parseClock, + reportToConsole, + ) +where + +import Chart +import Control.Exception +import Control.Monad +import Data.Bool +import Data.Foldable +import Data.List (intercalate) +import Data.List qualified as List +import Data.Map.Merge.Strict +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import GHC.Generics +import Optics.Core +import Options.Applicative as OA +import Options.Applicative.Help.Pretty +import Perf.BigO +import Perf.Chart +import Perf.Measure +import Perf.Stats +import Perf.Time (defaultClock) +import Perf.Types +import Prettyprinter.Render.Text qualified as PP +import System.Clock +import System.Exit +import System.Mem +import Text.PrettyPrint.Boxes qualified as B +import Text.Printf hiding (parseFormat) +import Text.Read + +-- | Benchmark name +type Name = String + +-- | Whether to include header information. +data Header = Header | NoHeader deriving (Eq, Show, Generic) + +-- | Command-line parser for 'Header' +parseHeader :: Parser Header +parseHeader = + flag' Header (long "header" <> help "include headers in reporting") + <|> flag' NoHeader (long "noheader" <> help "dont include headers in reporting") + <|> pure Header + +-- | Options for production of a performance report. +data ReportOptions = ReportOptions + { -- | Number of times to run a benchmark. + reportN :: Int, + reportLength :: Int, + reportClock :: Clock, + reportStatDType :: StatDType, + reportMeasureType :: MeasureType, + reportGolden :: Golden, + reportHeader :: Header, + reportCompare :: CompareLevels, + reportChart :: PerfChartOptions, + reportDump :: PerfDumpOptions, + reportGC :: Bool, + reportOrder :: OrderOptions + } + deriving (Eq, Show, Generic) + +-- | Default reporting options +defaultReportOptions :: ReportOptions +defaultReportOptions = + ReportOptions + 1000 + 1000 + defaultClock + StatAverage + MeasureTime + defaultGolden + Header + defaultCompareLevels + defaultPerfChartOptions + defaultPerfDumpOptions + False + defaultOrderOptions + +-- | Command-line parser for 'ReportOptions' +parseReportOptions :: ReportOptions -> Parser ReportOptions +parseReportOptions def = + ReportOptions + <$> option auto (value (view #reportN def) <> showDefaultWith show <> long "runs" <> short 'n' <> metavar "INT" <> help "number of runs to perform") + <*> option auto (value (view #reportLength def) <> long "length" <> showDefaultWith show <> short 'l' <> metavar "INT" <> help "length-like variable eg, used to alter list length and compute order") + <*> parseClock + <*> parseStatD + <*> parseMeasure + <*> parseGolden + <*> parseHeader + <*> parseCompareLevels defaultCompareLevels + <*> parsePerfChartOptions defaultPerfChartOptions + <*> parsePerfDumpOptions defaultPerfDumpOptions + <*> switch (long "gc" <> help "run the GC prior to measurement") + <*> parseOrderOptions defaultOrderOptions + +-- | Parse command-line 'Clock' options. +parseClock :: Parser Clock +parseClock = + flag' Monotonic (long "Monotonic" <> OA.style (annotate bold) <> help "use Monotonic clock") + <|> flag' Realtime (long "Realtime" <> help "use Realtime clock") + <|> flag' ProcessCPUTime (long "ProcessCPUTime" <> help "use ProcessCPUTime clock") + <|> flag' ThreadCPUTime (long "ThreadCPUTime" <> help "use ThreadCPUTime clock") +#ifdef mingw32_HOST_OS + <|> pure ThreadCPUTime +#else + <|> flag' MonotonicRaw (long "MonotonicRaw" <> help "use MonotonicRaw clock") + <|> pure MonotonicRaw +#endif + +data PerfDumpOptions = PerfDumpOptions {dumpFilepath :: FilePath, doDump :: Bool} deriving (Eq, Show, Generic) + +defaultPerfDumpOptions :: PerfDumpOptions +defaultPerfDumpOptions = PerfDumpOptions "other/perf.map" False + +-- | Parse charting options. +parsePerfDumpOptions :: PerfDumpOptions -> Parser PerfDumpOptions +parsePerfDumpOptions def = + PerfDumpOptions + <$> option str (value (view #dumpFilepath def) <> showDefaultWith show <> long "dumppath" <> metavar "FILE" <> help "dump file name") + <*> switch (long "dump" <> help "dump raw performance data as a Map Text [[Double]]") + +fromDump :: PerfDumpOptions -> IO (Map.Map Text [[Double]]) +fromDump cfg = read <$> readFile (view #dumpFilepath cfg) + +-- | Run and report a benchmark with the specified reporting options. +reportMain :: ReportOptions -> Name -> (Int -> PerfT IO [[Double]] a) -> IO a +reportMain o name t = do + let !n = reportN o + let l = reportLength o + let s = reportStatDType o + let c = reportClock o + let mt = reportMeasureType o + let o' = replaceDefaultFilePath (intercalate "-" [name, show n, show mt, show s]) o + when (reportGC o) performGC + (a, m) <- runPerfT (measureDs mt c n) (t l) + report o' (statify s m) + (\cfg -> when (view #doChart cfg) (writeChartOptions (view #chartFilepath cfg) (perfCharts cfg (Just (measureLabels mt)) m))) (reportChart o) + (\cfg -> when (view #doDump cfg) (writeFile (view #dumpFilepath cfg) (show m))) (reportDump o) + when (view (#reportOrder % #doOrder) o) (reportBigO o t) + pure a + +-- | Levels of geometric difference in compared performance that triggers reporting. +data CompareLevels = CompareLevels {errorLevel :: Double, warningLevel :: Double, improvedLevel :: Double} deriving (Eq, Show) + +-- | +-- >>> defaultCompareLevels +-- CompareLevels {errorLevel = 0.2, warningLevel = 5.0e-2, improvedLevel = 5.0e-2} +defaultCompareLevels :: CompareLevels +defaultCompareLevels = CompareLevels 0.2 0.05 0.05 + +-- | Command-line parser for 'CompareLevels' +parseCompareLevels :: CompareLevels -> Parser CompareLevels +parseCompareLevels c = + CompareLevels + <$> option auto (value (errorLevel c) <> showDefaultWith show <> long "error" <> metavar "DOUBLE" <> help "report an error if performance degrades by more than this") + <*> option auto (value (warningLevel c) <> showDefaultWith show <> long "warning" <> metavar "DOUBLE" <> help "report a warning if performance degrades by more than this") + <*> option auto (value (improvedLevel c) <> showDefaultWith show <> long "improved" <> metavar "DOUBLE" <> help "report if performance improves by more than this") + +-- | Write results to file +writeResult :: FilePath -> Map.Map [Text] Double -> IO () +writeResult f m = writeFile f (show m) + +-- | Read results from a file. +readResult :: FilePath -> IO (Either String (Map.Map [Text] Double)) +readResult f = do + a :: Either SomeException String <- try (readFile f) + pure $ either (Left . show) readEither a + +-- | Comparison data between two results. +data CompareResult = CompareResult {oldResult :: Maybe Double, newResult :: Maybe Double, noteResult :: Text} deriving (Show, Eq) + +hasDegraded :: Map.Map a CompareResult -> Bool +hasDegraded m = any (((== "degraded") . noteResult) . snd) (Map.toList m) + +-- | Compare two results and produce some notes given level triggers. +compareNote :: (Ord a) => CompareLevels -> Map.Map a Double -> Map.Map a Double -> Map.Map a CompareResult +compareNote cfg x y = + merge + (mapMissing (\_ x' -> CompareResult Nothing (Just x') "new result")) + (mapMissing (\_ x' -> CompareResult (Just x') Nothing "old result not found")) + ( zipWithMatched + ( \_ x' y' -> + CompareResult (Just x') (Just y') (note' x' y') + ) + ) + x + y + where + note' x' y' + | y' / x' > 1 + errorLevel cfg = "degraded" + | y' / x' > 1 + warningLevel cfg = "slightly-degraded" + | y' / x' < (1 - improvedLevel cfg) = "improvement" + | otherwise = "" + +-- | Console-style header information. +formatHeader :: Map.Map [Text] a -> [Text] -> [Text] +formatHeader m ts = + [mconcat $ Text.pack . printf "%-16s" <$> ((("label" <>) . Text.pack . show <$> [1 .. labelCols]) <> ts), mempty] + where + labelCols = maximum $ length <$> Map.keys m + +-- | Format a comparison. +formatCompare :: Header -> Map.Map [Text] CompareResult -> [Text] +formatCompare h m = + bool [] (formatHeader m ["old result", "new result", "change"]) (h == Header) + <> Map.elems (Map.mapWithKey (\k a -> Text.pack . mconcat $ printf "%-16s" <$> (k <> compareReport a)) m) + where + compareReport (CompareResult x y n) = + [ maybe mempty (expt (Just 3)) x, + maybe mempty (expt (Just 3)) y, + n + ] + +-- | Format a result as lines of text. +formatText :: Header -> Map.Map [Text] Text -> [Text] +formatText h m = + bool [] (formatHeader m ["results"]) (h == Header) + <> Map.elems (Map.mapWithKey (\k a -> Text.pack . mconcat $ printf "%-16s" <$> (k <> [a])) m) + +-- | Format a result as a table. +report2D :: Map.Map [Text] Double -> IO () +report2D m = putStrLn $ B.render $ B.hsep 1 B.left $ cs' : rs' + where + rs = List.nub ((List.!! 1) . fst <$> Map.toList m) + cs = List.nub ((List.!! 0) . fst <$> Map.toList m) + bx = B.text . Text.unpack + xs = (\c -> (\r -> m Map.! [c, r]) <$> rs) <$> cs + xs' = fmap (fmap (bx . expt (Just 3))) xs + cs' = B.vcat B.left (bx <$> ("algo" : cs)) + rs' = B.vcat B.right <$> zipWith (:) (bx <$> rs) (List.transpose xs') + +reportToConsole :: [Text] -> IO () +reportToConsole xs = traverse_ Text.putStrLn xs + +-- | Golden file options. +data Golden = Golden {golden :: FilePath, check :: CheckGolden, record :: RecordGolden} deriving (Generic, Eq, Show) + +-- | Whether to check against a golden file +data CheckGolden = CheckGolden | NoCheckGolden deriving (Eq, Show, Generic) + +-- | Whether to overwrite a golden file +data RecordGolden = RecordGolden | NoRecordGolden deriving (Eq, Show, Generic) + +-- | Default is Golden "other/bench.perf" CheckGolden NoRecordGolden +defaultGolden :: Golden +defaultGolden = Golden "other/bench.perf" CheckGolden NoRecordGolden + +-- | Replace the golden file name stem if it's the default. +replaceGoldenDefault :: FilePath -> Golden -> Golden +replaceGoldenDefault s g = bool g g {golden = s} (golden g == golden defaultGolden) + +defaultGoldenPath :: FilePath -> FilePath +defaultGoldenPath fp = "other/" <> fp <> ".perf" + +-- | Replace the Golden file path with the suggested stem, but only if the user did not specify a specific file path at the command line. +replaceDefaultFilePath :: FilePath -> ReportOptions -> ReportOptions +replaceDefaultFilePath fp o = + o {reportGolden = replaceGoldenDefault (defaultGoldenPath fp) (reportGolden o)} + +-- | Parse command-line golden file options. +parseGolden :: Parser Golden +parseGolden = + Golden + <$> option str (value (golden defaultGolden) <> showDefaultWith show <> long "golden" <> short 'g' <> metavar "FILE" <> help "golden file name") + -- True is the default for 'check'. + <*> (bool NoCheckGolden CheckGolden <$> flag True False (long "nocheck" <> help "do not check versus the golden file")) + <*> (bool NoRecordGolden RecordGolden <$> switch (long "record" <> short 'r' <> help "record the result to the golden file")) + +reportConsoleNoCompare :: Header -> Map.Map [Text] Double -> IO () +reportConsoleNoCompare h m = + reportToConsole (formatText h (expt (Just 3) <$> m)) + +reportConsoleCompare :: Header -> Map.Map [Text] CompareResult -> IO () +reportConsoleCompare h m = + reportToConsole (formatCompare h m) + +-- | Report results +-- +-- If a goldenFile is checked, and performance has degraded, the function will exit with 'ExitFailure' so that 'cabal bench' and other types of processes can signal performance issues. +report :: ReportOptions -> Map.Map [Text] [Double] -> IO () +report o m = do + when + ((== RecordGolden) $ record (reportGolden o)) + (writeResult (golden (reportGolden o)) m') + case check (reportGolden o) of + NoCheckGolden -> reportConsoleNoCompare (reportHeader o) m' + CheckGolden -> do + mOrig <- readResult (golden (reportGolden o)) + case mOrig of + Left _ -> do + reportConsoleNoCompare (reportHeader o) m' + unless + ((RecordGolden ==) $ record (reportGolden o)) + (putStrLn "No golden file found. To create one, run with '-r'") + Right orig -> do + let n = compareNote (reportCompare o) orig m' + _ <- reportConsoleCompare (reportHeader o) n + when (hasDegraded n) (exitWith $ ExitFailure 1) + where + m' = Map.fromList $ mconcat $ (\(ks, xss) -> zipWith (\x l -> (ks <> [l], x)) xss (measureLabels (reportMeasureType o))) <$> Map.toList m + +reportBigO :: ReportOptions -> (Int -> PerfT IO [[Double]] a) -> IO () +reportBigO o p = do + m <- mapM (execPerfT (measureDs (view #reportMeasureType o) (view #reportClock o) (view #reportN o)) . p) ns + putStrLn mempty + reportToConsole $ PP.renderStrict . layoutPretty defaultLayoutOptions <$> os'' m + pure () + where + l = view #reportLength o + ns = makeNs l (view (#reportOrder % #orderDivisor) o) (view (#reportOrder % #orderLow) o) + ms m' = fmap (fmap (statD (view #reportStatDType o)) . List.transpose) <$> m' + os m' = fmap (fmap (pretty . fromOrder . fst . estO (fromIntegral <$> ns)) . List.transpose) (Map.unionsWith (<>) (fmap (fmap (: [])) (ms m'))) + os' m' = mconcat $ (\(ks, xss) -> zipWith (\x l' -> ([ks] <> [l'], x)) xss (measureLabels (reportMeasureType o))) <$> Map.toList (os m') + os'' m' = (\(k, v) -> (pretty . Text.intercalate ":") k <> " " <> v) <$> os' m' diff --git a/src/Perf/Space.hs b/src/Perf/Space.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Space.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Space performance measurement. +module Perf.Space + ( SpaceStats (..), + ssToList, + spaceLabels, + space, + allocation, + Bytes (..), + ) +where + +import Control.Monad +import Data.Text (Text) +import Data.Word +import GHC.Stats +import Perf.Types +import System.Mem +import Prelude hiding (cycle) + +-- | GHC allocation statistics. +data SpaceStats = SpaceStats {allocated :: Word64, copied :: Word64, maxmem :: Word64, minorgcs :: Word32, majorgcs :: Word32} deriving (Read, Show, Eq) + +-- | Convert 'SpaceStats' to a list of numbers. +ssToList :: (Num a) => SpaceStats -> [a] +ssToList (SpaceStats x1 x2 x3 x4 x5) = [fromIntegral x1, fromIntegral x2, fromIntegral x3, fromIntegral x4, fromIntegral x5] + +instance Semigroup SpaceStats where + (<>) = addSpace + +instance Monoid SpaceStats where + mempty = SpaceStats 0 0 0 0 0 + +instance Num SpaceStats where + (+) = addSpace + (-) = diffSpace + (*) = error "SpaceStats times" + abs = error "SpaceStats abs" + signum = error "SpaceStats signum" + fromInteger n = SpaceStats (fromIntegral n) (fromIntegral n) (fromIntegral n) (fromIntegral n) (fromIntegral n) + +diffSpace :: SpaceStats -> SpaceStats -> SpaceStats +diffSpace (SpaceStats x1 x2 x3 x4 x5) (SpaceStats x1' x2' x3' x4' x5') = SpaceStats (x1' - x1) (x2' - x2) (x3' - x3) (x4' - x4) (x5' - x5) + +addSpace :: SpaceStats -> SpaceStats -> SpaceStats +addSpace (SpaceStats x1 x2 x3 x4 x5) (SpaceStats x1' x2' x3' x4' x5') = SpaceStats (x1' + x1) (x2' + x2) (x3' + x3) (x4' + x4) (x5' + x5) + +getSpace :: RTSStats -> SpaceStats +getSpace s = SpaceStats (allocated_bytes s) (copied_bytes s) (max_mem_in_use_bytes s) (gcs s) (major_gcs s) + +-- | Labels for 'SpaceStats'. +spaceLabels :: [Text] +spaceLabels = ["allocated", "copied", "maxmem", "minorgcs", "majorgcs"] + +-- | A allocation 'StepMeasure' with a flag to determine if 'performGC' should run prior to the measurement. +space :: Bool -> StepMeasure IO SpaceStats +space p = StepMeasure (start p) stop + where + start p' = do + when p' performGC + getSpace <$> getRTSStats + stop s = do + s' <- getSpace <$> getRTSStats + pure $ diffSpace s s' +{-# INLINEABLE space #-} + +-- | Number of bytes +newtype Bytes = Bytes {unbytes :: Word64} + deriving (Show, Read, Eq, Ord, Num, Real, Enum, Integral) + +instance Semigroup Bytes where + (<>) = (+) + +instance Monoid Bytes where + mempty = 0 + +-- | Measure memory allocation, with a flag to run 'performGC' prior to the measurement. +allocation :: Bool -> StepMeasure IO Bytes +allocation p = StepMeasure (start p) stop + where + start p' = do + when p' performGC + Bytes . allocated_bytes <$> getRTSStats + stop s = do + s' <- Bytes . allocated_bytes <$> getRTSStats + pure $ s' - s +{-# INLINEABLE allocation #-} diff --git a/src/Perf/Stats.hs b/src/Perf/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Stats.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Statistical choices for multiple performance measurements. +module Perf.Stats + ( average, + median, + tenth, + averageI, + StatDType (..), + statD, + statDs, + parseStatD, + -- stat reporting + addStat, + ordy, + allStats, + statify, + ) +where + +import Control.Monad.State.Lazy +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Text (Text, pack) +import NumHask.Space (quantile) +import Options.Applicative +import Options.Applicative.Help.Pretty + +-- | Compute the median +median :: [Double] -> Double +median = quantile 0.5 + +-- | Compute the average +average :: [Double] -> Double +average xs = sum xs / (fromIntegral . length $ xs) + +-- | Compute the tenth percentile +tenth :: [Double] -> Double +tenth = quantile 0.1 + +-- | Compute the average of an Integral +averageI :: (Integral a) => [a] -> Double +averageI xs = sum (fromIntegral <$> xs) / (fromIntegral . length $ xs) + +-- | Command-line options for type of statistic. +data StatDType = StatAverage | StatMedian | StatBest deriving (Eq, Show) + +-- | Compute a statistic. +statD :: StatDType -> [Double] -> Double +statD StatBest = tenth +statD StatMedian = median +statD StatAverage = average + +-- | Compute a list of statistics. +statDs :: StatDType -> [[Double]] -> [Double] +statDs StatBest = fmap tenth . List.transpose +statDs StatMedian = fmap median . List.transpose +statDs StatAverage = fmap average . List.transpose + +-- | Parse command-line 'StatDType' options. +parseStatD :: Parser StatDType +parseStatD = + flag' StatBest (long "best" <> style (annotate bold) <> help "report upper decile") + <|> flag' StatMedian (long "median" <> help "report median") + <|> flag' StatAverage (long "average" <> help "report average") + <|> pure StatBest + +-- | Add a statistic to a State Map +addStat :: (Ord k, Monad m) => k -> s -> StateT (Map.Map k s) m () +addStat label s = do + modify (Map.insert label s) + +-- | Linguistic conversion of an ordinal +ordy :: Int -> [Text] +ordy f = zipWith (\x s -> (pack . show) x <> s) [1 .. f] (["st", "nd", "rd"] <> repeat "th") + +-- | Compute all stats. +allStats :: Int -> Map.Map [Text] [[Double]] -> Map.Map [Text] [Double] +allStats f m = + Map.fromList $ + mconcat + [ mconcat ((\(ks, xss) -> zipWith (\l xs -> (ks <> [l], xs)) (ordy f) xss) <$> mlist), + (\(ks, xss) -> (ks <> ["best"], quantile 0.1 <$> List.transpose xss)) <$> mlist, + (\(ks, xss) -> (ks <> ["median"], quantile 0.5 <$> List.transpose xss)) <$> mlist, + (\(ks, xss) -> (ks <> ["average"], av <$> List.transpose xss)) <$> mlist + ] + where + mlist = Map.toList m + av xs = sum xs / (fromIntegral . length $ xs) + +-- | Convert a Map of performance result to a statistic. +statify :: (Ord a) => StatDType -> Map.Map a [[Double]] -> Map.Map [a] [Double] +statify s m = fmap (statD s) . List.transpose <$> Map.mapKeys (: []) m diff --git a/src/Perf/Time.hs b/src/Perf/Time.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Time.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Use of 'System.Clock' from the [clock](https://hackage.haskell.org/package/clock) library to measure time performance of a computation. +module Perf.Time + ( Nanos, + defaultClock, + toSecs, + nanosWith, + nanos, + tick_, + warmup, + tickWith, + tick, + tickWHNF, + tickLazy, + tickForce, + tickForceArgs, + tickIO, + tickIOWith, + ticks, + ticksIO, + time, + times, + timesWith, + timesN, + timesNWith, + stepTime, + ) +where + +import Control.DeepSeq +import Control.Monad (replicateM_) +import Perf.Types +import System.Clock +import Prelude + +-- | A performance measure of number of nanoseconds. +type Nanos = Integer + +-- | Convert 'Nanos' to seconds. +toSecs :: Nanos -> Double +toSecs ns = fromIntegral ns / 1e9 + +-- | 'MonotonicRaw' is the default for macOS & linux, at around 42 nano time resolution, and a 'tick_' measurement of around 170 nanos. For Windows, 'ThreadCPUTime' has a similar time resolution at 42 nanos and a 'tick_' of around 500 nanos. +defaultClock :: Clock + +#ifdef mingw32_HOST_OS +defaultClock = ThreadCPUTime +#else +defaultClock = MonotonicRaw +#endif + +-- | A single 'defaultClock' reading (note that the absolute value is not meaningful). +nanos :: IO Nanos +nanos = nanosWith defaultClock + +-- | A single reading of a specific 'Clock'. +nanosWith :: Clock -> IO Nanos +nanosWith c = toNanoSecs <$> getTime c + +-- | tick_ measures the number of nanos it takes to read the clock. +tick_ :: IO Nanos +tick_ = do + t <- nanos + t' <- nanos + pure (t' - t) + +-- | Warm up the clock, to avoid a high first measurement. Without a warmup, one or more larger values can occur at the start of a measurement spree, and often are in the zone of an L2 miss. +warmup :: Int -> IO () +warmup n = replicateM_ n tick_ + +-- | tick from a specific 'Clock' +tickWith :: Clock -> (a -> b) -> a -> IO (Nanos, b) +tickWith c !f !a = do + !t <- nanosWith c + !a' <- pure $! f a + !t' <- nanosWith c + pure (t' - t, a') +{-# INLINEABLE tickWith #-} + +-- | /tick f a/ +-- +-- - strictly evaluates f and a to WHNF +-- - reads the clock +-- - strictly evaluates f a to WHNF +-- - reads the clock +-- - returns (nanos, f a) +tick :: (a -> b) -> a -> IO (Nanos, b) +tick !f !a = do + !t <- nanos + !a' <- pure $! f a + !t' <- nanos + pure (t' - t, a') +{-# INLINEABLE tick #-} + +-- | /tickWHNF f a/ +-- +-- - reads the clock +-- - strictly evaluates f a to WHNF (this may also kick off thunk evaluation in f or a which will also be captured in the cycle count) +-- - reads the clock +-- - returns (nanos, f a) +tickWHNF :: (a -> b) -> a -> IO (Nanos, b) +tickWHNF f a = do + !t <- nanos + !a' <- pure $! f a + !t' <- nanos + pure (t' - t, a') +{-# INLINEABLE tickWHNF #-} + +-- | /tickLazy f a/ +-- +-- - reads the clock +-- - lazily evaluates f a +-- - reads the clock +-- - returns (nanos, f a) +tickLazy :: (a -> b) -> a -> IO (Nanos, b) +tickLazy f a = do + t <- nanos + let a' = f a + t' <- nanos + pure (t' - t, a') +{-# INLINEABLE tickLazy #-} + +-- | /tickForce f a/ +-- +-- - deeply evaluates f and a, +-- - reads the clock +-- - deeply evaluates f a +-- - reads the clock +-- - returns (nanos, f a) +tickForce :: (NFData a, NFData b) => (a -> b) -> a -> IO (Nanos, b) +tickForce (force -> !f) (force -> !a) = do + !t <- nanos + !a' <- pure (force (f a)) + !t' <- nanos + pure (t' - t, a') +{-# INLINEABLE tickForce #-} + +-- | /tickForceArgs f a/ +-- +-- - deeply evaluates f and a, +-- - reads the clock +-- - strictly evaluates f a to WHNF +-- - reads the clock +-- - returns (nanos, f a) +tickForceArgs :: (NFData a) => (a -> b) -> a -> IO (Nanos, b) +tickForceArgs (force -> !f) (force -> !a) = do + !t <- nanos + !a' <- pure $! f a + !t' <- nanos + pure (t' - t, a') +{-# INLINEABLE tickForceArgs #-} + +-- | measures an /IO a/ +tickIO :: IO a -> IO (Nanos, a) +tickIO a = do + !t <- nanos + !a' <- a + !t' <- nanos + pure (t' - t, a') +{-# INLINEABLE tickIO #-} + +-- | measures an /IO a/ +tickIOWith :: Clock -> IO a -> IO (Nanos, a) +tickIOWith c a = do + !t <- nanosWith c + !a' <- a + !t' <- nanosWith c + pure (t' - t, a') +{-# INLINEABLE tickIOWith #-} + +-- | n measurements of a tick +-- +-- returns a list of Nanos and the last evaluated f a +ticks :: Int -> (a -> b) -> a -> IO ([Nanos], b) +ticks = multi tick +{-# INLINEABLE ticks #-} + +-- | n measurements of a tickIO +-- +-- returns an IO tuple; list of Nanos and the last evaluated f a +ticksIO :: Int -> IO a -> IO ([Nanos], a) +ticksIO = multiM tickIO +{-# INLINEABLE ticksIO #-} + +-- | tick as a 'StepMeasure' +stepTime :: StepMeasure IO Nanos +stepTime = StepMeasure start stop + where + start = nanos + stop r = fmap (\x -> x - r) nanos +{-# INLINEABLE stepTime #-} + +-- | tick as a 'Measure' +time :: Measure IO Nanos +time = Measure tick +{-# INLINEABLE time #-} + +-- | tick as a multi-Measure +times :: Int -> Measure IO [Nanos] +times n = Measure (ticks n) +{-# INLINEABLE times #-} + +-- | tickWith as a multi-Measure +timesWith :: Clock -> Int -> Measure IO [Nanos] +timesWith c n = repeated n (Measure (tickWith c)) +{-# INLINEABLE timesWith #-} + +-- | tickWith for n repeated applications +timesN :: Int -> Measure IO Nanos +timesN n = Measure (tickNWith defaultClock n) +{-# INLINEABLE timesN #-} + +-- | tickWith for n repeated applications +timesNWith :: Clock -> Int -> Measure IO Nanos +timesNWith c n = Measure (tickNWith c n) +{-# INLINEABLE timesNWith #-} + +tickNWith :: Clock -> Int -> (a -> b) -> a -> IO (Nanos, b) +tickNWith c n !f !a = do + !t <- nanosWith c + !a' <- multiN id f a n + !t' <- nanosWith c + pure (floor @Double (fromIntegral (t' - t) / fromIntegral n), a') +{-# INLINEABLE tickNWith #-} diff --git a/src/Perf/Types.hs b/src/Perf/Types.hs new file mode 100644 --- /dev/null +++ b/src/Perf/Types.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-x-partial #-} + +-- | Abstract types of performance measurement. +module Perf.Types + ( -- * Measure + Measure (..), + repeated, + StepMeasure (..), + toMeasure, + toMeasureN, + step, + stepM, + multi, + multiM, + multiN, + + -- * function application + fap, + afap, + ffap, + fan, + fam, + (|$|), + ($|), + (|+|), + + -- * PerfT monad + PerfT (..), + Perf, + runPerfT, + evalPerfT, + execPerfT, + outer, + slop, + slops, + ) +where + +import Control.DeepSeq +import Control.Monad +import Control.Monad.State.Lazy +import Data.Bifunctor +import Data.Functor.Identity +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import GHC.Exts +import GHC.IO hiding (liftIO) +import Prelude + +-- | Abstraction of a performance measurement within a monadic context. +-- +-- - measure applies a function to a value, returning a tuple of the performance measure, and the computation result. +-- - measureM evaluates a monadic value and returns a performance-result tuple. +newtype Measure m t = Measure + { measure :: forall a b. (a -> b) -> a -> m (t, b) + } + +instance (Functor m) => Functor (Measure m) where + fmap f (Measure m) = + Measure + (\f' a' -> fmap (first f) (m f' a')) + +-- | An inefficient application that runs the inner action twice. +instance (Applicative m) => Applicative (Measure m) where + pure t = Measure (\f a -> pure (t, f a)) + (Measure mf) <*> (Measure mt) = + Measure + (\f a -> (\(nf', fa') (t', _) -> (nf' t', fa')) <$> mf f a <*> mt f a) + +-- | Convert a Measure into a multi measure. +repeated :: (Applicative m) => Int -> Measure m t -> Measure m [t] +repeated n (Measure p) = + Measure + (\f a -> fmap (\xs -> (fmap fst xs, snd (head xs))) (replicateM n (p f a))) +{-# INLINEABLE repeated #-} + +-- | Abstraction of a performance measurement with a pre and a post step wrapping the computation. +data StepMeasure m t = forall i. StepMeasure {pre :: m i, post :: i -> m t} + +instance (Functor m) => Functor (StepMeasure m) where + fmap f (StepMeasure start stop) = StepMeasure start (fmap f . stop) + +instance (Applicative m) => Applicative (StepMeasure m) where + pure t = StepMeasure (pure ()) (const (pure t)) + (<*>) (StepMeasure fstart fstop) (StepMeasure start stop) = + StepMeasure ((,) <$> fstart <*> start) (\(fi, i) -> fstop fi <*> stop i) + +-- | Convert a StepMeasure into a Measure +toMeasure :: (Monad m) => StepMeasure m t -> Measure m t +toMeasure (StepMeasure pre' post') = Measure (step pre' post') +{-# INLINEABLE toMeasure #-} + +-- | Convert a StepMeasure into a Measure running the computation multiple times. +toMeasureN :: (Monad m) => Int -> StepMeasure m t -> Measure m [t] +toMeasureN n (StepMeasure pre' post') = Measure (multi (step pre' post') n) +{-# INLINEABLE toMeasureN #-} + +-- | A single step measurement. +step :: (Monad m) => m i -> (i -> m t) -> (a -> b) -> a -> m (t, b) +step pre' post' !f !a = do + !p <- pre' + !b <- pure $! f a + !t <- post' p + pure (t, b) +{-# INLINEABLE step #-} + +-- | A single step measurement. +stepM :: (Monad m) => m i -> (i -> m t) -> m a -> m (t, a) +stepM pre' post' a = do + !p <- pre' + !ma <- a + !t <- post' p + pure (t, ma) +{-# INLINEABLE stepM #-} + +multi1 :: (Monad m) => ((a -> b) -> a -> m (t, b)) -> Int -> (a -> b) -> a -> m [(t, b)] +multi1 action n !f !a = sequence $ replicate n $! action f a +{-# INLINEABLE multi1 #-} + +-- | Return one result but multiple measurements. +multi :: (Monad m) => ((a -> b) -> a -> m (t, b)) -> Int -> (a -> b) -> a -> m ([t], b) +multi action n !f !a = do + xs <- multi1 action n f a + pure (fmap fst xs, snd (head xs)) +{-# INLINEABLE multi #-} + +-- | Multiple measurements +multiM :: (Monad m) => (m a -> m (t, a)) -> Int -> m a -> m ([t], a) +multiM action n a = + fmap (\xs -> (fmap fst xs, head $! fmap snd xs)) (replicateM n (action a)) +{-# INLINEABLE multiM #-} + +multiN :: (b -> t) -> (a -> b) -> a -> Int -> IO t +multiN frc = multiNLoop SPEC + where + multiNLoop !_ f x n + | n == 1 = evaluate (frc (f x)) + | otherwise = do + _ <- evaluate (frc (f x)) + multiNLoop SPEC f x (n - 1) +{-# INLINE multiN #-} + +-- | Performance measurement transformer storing a 'Measure' and a map of named results. +newtype PerfT m t a = PerfT + { measurePerf :: StateT (Measure m t, Map.Map Text t) m a + } + deriving (Functor, Applicative, Monad) + +-- | The transformer over Identity +type Perf t a = PerfT Identity t a + +instance (MonadIO m) => MonadIO (PerfT m t) where + liftIO = PerfT . liftIO + +-- | Lift an application to a PerfT m, providing a label and a 'Measure'. +-- +-- Measurements with the same label will be mappended +fap :: (MonadIO m, Semigroup t) => Text -> (a -> b) -> a -> PerfT m t b +fap label f a = + PerfT $ do + m <- fst <$> get + (t, fa) <- lift $ measure m f a + modify $ second (Map.insertWith (<>) label t) + return fa +{-# INLINEABLE fap #-} + +-- | Lift an application to a PerfT m, forcing the argument. +afap :: (NFData a, MonadIO m, Semigroup t) => Text -> (a -> b) -> a -> PerfT m t b +afap label f a = fap label f (force a) +{-# INLINEABLE afap #-} + +-- | Lift an application to a PerfT m, forcing argument and result. +ffap :: (NFData a, NFData b, MonadIO m, Semigroup t) => Text -> (a -> b) -> a -> PerfT m t b +ffap label f a = fap label (force . f) (force a) +{-# INLINEABLE ffap #-} + +-- | Lift a number to a PerfT m, providing a label, function, and input. +-- +-- Measurements with the same label will be added +fan :: (MonadIO m, Num t) => Text -> (a -> b) -> a -> PerfT m t b +fan label f a = + PerfT $ do + m <- fst <$> get + (t, fa) <- lift $ measure m f a + modify $ second (Map.insertWith (+) label t) + return fa +{-# INLINEABLE fan #-} + +-- | Lift a monadic value to a PerfT m, providing a label and a 'Measure'. +-- +-- Measurements with the same label will be added +fam :: (MonadIO m, Semigroup t) => Text -> m a -> PerfT m t a +fam label a = + PerfT $ do + m <- fst <$> get + (t, !ma) <- lift $ measure m (const a) () + modify $ second (Map.insertWith (<>) label t) + lift ma +{-# INLINEABLE fam #-} + +-- | lift a pure, unnamed function application to PerfT +(|$|) :: (Semigroup t) => (a -> b) -> a -> PerfT IO t b +(|$|) f a = fap "" f a +{-# INLINEABLE (|$|) #-} + +-- | lift a monadic, unnamed function application to PerfT +($|) :: (Semigroup t) => IO a -> PerfT IO t a +($|) a = fam "" a +{-# INLINEABLE ($|) #-} + +-- | lift an unnamed numeric measure to PerfT +(|+|) :: (Num t) => (a -> b) -> a -> PerfT IO t b +(|+|) f a = fan "" f a +{-# INLINEABLE (|+|) #-} + +-- | Run the performance measure, returning (computational result, measurement). +runPerfT :: (Functor m) => Measure m t -> PerfT m t a -> m (a, Map.Map Text t) +runPerfT m p = fmap (second snd) <$> flip runStateT (m, Map.empty) $ measurePerf p +{-# INLINEABLE runPerfT #-} + +-- | Consume the PerfT layer and return the original monadic result. +-- Fingers crossed, PerfT structure should be completely compiled away. +evalPerfT :: (Monad m) => Measure m t -> PerfT m t a -> m a +evalPerfT m p = fmap fst <$> flip runStateT (m, Map.empty) $ measurePerf p +{-# INLINEABLE evalPerfT #-} + +-- | Consume a PerfT layer and return the measurement. +execPerfT :: (Monad m) => Measure m t -> PerfT m t a -> m (Map.Map Text t) +execPerfT m p = fmap snd <$> flip execStateT (m, Map.empty) $ measurePerf p +{-# INLINEABLE execPerfT #-} + +-- | run a PerfT and also calculate performance over the entire computation +outer :: (MonadIO m, Semigroup s) => Text -> Measure m s -> Measure m t -> PerfT m t a -> m (a, (Map.Map Text s, Map.Map Text t)) +outer label outerm meas p = + (\((a, m), m') -> (a, (m', m))) + <$> runPerfT + outerm + (fam label (runPerfT meas p)) + +-- | run a PerfT and calculate excess performance over the entire computation +slop :: (MonadIO m, Num t, Semigroup t) => Text -> Measure m t -> PerfT m t a -> m (a, Map.Map Text t) +slop l meas p = + (\((a, m), m') -> (a, m <> Map.insert "slop" (m' Map.! l - Map.foldl' (+) 0 m) m')) + <$> runPerfT + meas + (fam l (runPerfT meas p)) + +-- | run a multi PerfT and calculate excess performance over the entire computation +slops :: (MonadIO m, Num t, Semigroup t) => Int -> Measure m t -> PerfT m [t] a -> m (a, (Map.Map Text t, Map.Map Text [t])) +slops n meas p = + (\((a, ms), m') -> (a, (Map.insert "slop" (m' Map.! "outer" - Map.foldl' (+) 0 (fmap sum ms)) m', ms))) + <$> runPerfT + meas + (fam "outer" (runPerfT (repeated n meas) p)) diff --git a/test/test.hs b/test/test.hs deleted file mode 100644 --- a/test/test.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} - -module Main where - -import Test.DocTest - -main :: IO () -main = do - putStrLn "Perf.Cycle DocTest" - doctest ["src/Perf/Cycle.hs"] - putStrLn "Perf.Measure DocTest" - doctest ["src/Perf/Measure.hs"] - putStrLn "Perf DocTest" - doctest ["src/Perf.hs"]