perf 0.13.0.0 → 0.14.0.0
raw patch · 14 files changed
+536/−251 lines, 14 filesdep +boxesdep +chart-svgdep +optics-coredep ~basedep ~numhask-spacedep ~optparse-applicative
Dependencies added: boxes, chart-svg, optics-core, prettychart, prettyprinter, tasty, tasty-bench
Dependency ranges changed: base, numhask-space, optparse-applicative
Files
- ChangeLog.md +19/−0
- app/bench.hs +1/−1
- app/explore.hs +38/−44
- perf.cabal +18/−11
- readme.md +2/−32
- src/Perf/Algos.hs +36/−24
- src/Perf/BigO.hs +35/−34
- src/Perf/Chart.hs +193/−0
- src/Perf/Measure.hs +10/−5
- src/Perf/Report.hs +122/−74
- src/Perf/Space.hs +3/−3
- src/Perf/Stats.hs +3/−2
- src/Perf/Time.hs +24/−3
- src/Perf/Types.hs +32/−18
ChangeLog.md view
@@ -1,3 +1,22 @@+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.
app/bench.hs view
@@ -9,4 +9,4 @@ main = do let l = 1000 let a = ExampleSum- reportMain (List.intercalate "-" [show a, show l]) $ testExample (examplePattern a l)+ reportMain a defaultReportOptions (List.intercalate "-" [show a, show @Int l]) (testExample . examplePattern a)
app/explore.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- | basic measurement and callibration@@ -6,58 +7,59 @@ import Control.DeepSeq import Control.Monad import Control.Monad.State.Lazy-import Data.FormatN-import Data.List (intercalate, nub)+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 RunType = RunExample | RunExamples | RunClocks | RunNub | RunExampleIO | RunSums | RunLengths | RunNoOps | RunTicks deriving (Eq, Show)+data Run = RunExample | RunExampleIO | RunSums | RunLengths | RunNoOps | RunTicks deriving (Eq, Show) -data ExploreOptions = ExploreOptions- { exploreReportOptions :: ReportOptions,- exploreRun :: RunType,- exploreLength :: Int,- exploreExample :: Example+data AppConfig = AppConfig+ { appRun :: Run,+ appExample :: Example,+ appReportOptions :: ReportOptions }- deriving (Eq, Show)+ deriving (Eq, Show, Generic) -parseRun :: Parser RunType+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' RunNub (long "nub" <> help "nub test")- <|> flag' RunClocks (long "clocks" <> help "clock test")- <|> flag' RunExamples (long "examples" <> help "run on example algorithms")- <|> flag' RunExample (long "example" <> help "run on the example algorithm")+ <|> 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 -exploreOptions :: Parser ExploreOptions-exploreOptions =- ExploreOptions- <$> parseReportOptions- <*> parseRun- <*> option auto (value 1000 <> long "length" <> short 'l' <> help "length of list")+appParser :: AppConfig -> Parser AppConfig+appParser def =+ AppConfig+ <$> parseRun <*> parseExample+ <*> parseReportOptions (view #appReportOptions def) -exploreOpts :: ParserInfo ExploreOptions-exploreOpts =+appConfig :: AppConfig -> ParserInfo AppConfig+appConfig def = info- (exploreOptions <**> helper)- (fullDesc <> progDesc "perf exploration" <> header "examples of perf usage")+ (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 <- fap "length" Text.length txt+ n <- ffap "length" Text.length txt fam "print-result" (Text.putStrLn $ "length of file is: " <> Text.pack (show n)) -- | * sums@@ -71,6 +73,7 @@ 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@@ -92,32 +95,23 @@ main :: IO () main = do- o <- execParser exploreOpts- let repOptions = exploreReportOptions o+ 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 = exploreLength o- let a = exploreExample o- let r = exploreRun o+ let !l = reportLength repOptions+ let a = appExample o+ let r = appRun o case r of- RunNub -> do- reportMainWith repOptions (show r) (ffap "nub" nub [1 .. l]) RunExample -> do- reportMainWith repOptions (intercalate "-" [show r, show a, show l]) $- testExample (examplePattern a l)- RunExamples -> do- reportMainWith- repOptions- (intercalate "-" [show r, show l])- (statExamples l)- RunClocks -> do- reportMainWith+ reportMain+ a repOptions- (intercalate "-" [show r, show a, show l, show c])- (testExample (examplePattern a l))+ (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@@ -139,4 +133,4 @@ report o' (allStats 4 (Map.mapKeys (: []) m)) RunTicks -> do m <- statTicksSums n l s- reportOrg2D (fmap (expt (Just 3)) m)+ report2D m
perf.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: perf-version: 0.13.0.0+version: 0.14.0.0 license: BSD-3-Clause license-file: LICENSE copyright: Tony Day (c) 2018@@ -17,9 +17,8 @@ build-type: Simple tested-with: , GHC == 9.10.1- , GHC == 9.8.2 , GHC == 9.6.5-+ , GHC == 9.8.2 extra-doc-files: ChangeLog.md readme.md@@ -45,6 +44,7 @@ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ -fproc-alignment=64 common ghc2021-stanza default-language: GHC2021@@ -54,21 +54,29 @@ import: ghc2021-stanza hs-source-dirs: src build-depends:- , base >=4.7 && <5+ , 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.8 , deepseq >=1.4.4 && <1.6 , formatn >=0.2.1 && <0.4 , mtl >=2.2.2 && <2.4- , numhask-space >=0.10 && <0.12- , optparse-applicative >=0.17 && <0.19+ , numhask-space >=0.10 && <0.13+ , 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+ , tasty >=1.5.2 && <1.6+ , tasty-bench >=0.4 && <0.5 , text >=1.2 && <2.2 , vector >=0.12.3 && <0.14 exposed-modules: Perf Perf.Algos Perf.BigO+ Perf.Chart Perf.Count Perf.Measure Perf.Report@@ -85,13 +93,12 @@ main-is: explore.hs hs-source-dirs: app build-depends:- , base >=4.7 && <5- , clock >=0.8 && <0.9+ , base >=4.14 && <5 , containers >=0.6 && <0.8 , deepseq >=1.4.4 && <1.6- , formatn >=0.2.1 && <0.4 , mtl >=2.2.2 && <2.4- , optparse-applicative >=0.17 && <0.19+ , optics-core >=0.4.1 && <0.5+ , optparse-applicative >=0.17 && <0.20 , perf , text >=1.2 && <2.2 ghc-options: -O2@@ -103,7 +110,7 @@ main-is: bench.hs hs-source-dirs: app build-depends:- , base >=4.7 && <5+ , base >=4.14 && <5 , perf ghc-options: -O2 type: exitcode-stdio-1.0
readme.md view
@@ -1,37 +1,7 @@ -# Table of Contents--1. [Introduction](#orga196864)-2. [Setup](#orgfd30244)-3. [System.Clock](#orgb51effe)- 1. [resolution](#org7dcd69d)-4. [Time](#org6c19f0f)- 1. [What is a tick?](#org49fb855)- 2. [tick\_](#org1de7ebb)- 3. [multiple ticks](#org27958a7)- 4. [tickIO](#orga206cb6)- 5. [sum example](#orgd6c8625)-5. [PerfT](#org0974e4d)-6. [perf-explore](#org216f105)- 1. [noops](#org2d42223)- 2. [measurement context](#org95a9062)- 1. [short list](#orgdb37d7c)- 2. [long list](#org56b0098)- 3. [sums](#orgff01033)- 4. [lengths](#org5abd0c1)- 5. [Space](#org01bde6f)-7. [Perf.BigO](#org753786d)-8. [References](#org47311bd)- 1. [Core](#orgadd7f60)- 2. [Profiling](#org31e588b)- 1. [setup](#orgf72792c)- 2. [Space usage output (-s)](#org1d9ca37)- 3. [Cost center profile (-p)](#orgeb93acc)- 4. [heap analysis (-hc -l)](#org76c2a10)- 3. [Cache speed](#org3a53ed0)--[](https://hackage.haskell.org/package/perf) [](https://github.com/tonyday567/perf/actions?query=workflow%3Ahaskell-ci)+# perf +[](https://hackage.haskell.org/package/perf) [](https://github.com/tonyday567/perf/actions) <a id="orga196864"></a>
src/Perf/Algos.hs view
@@ -12,13 +12,12 @@ module Perf.Algos ( -- * command-line options Example (..),- allExamples, parseExample, ExamplePattern (..), examplePattern, exampleLabel, testExample,- statExamples,+ tastyExample, -- * sum algorithms SumPattern (..),@@ -85,34 +84,28 @@ import Data.Bifunctor import Data.Foldable 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+import Test.Tasty.Bench -- | Algorithm examples for testing-data Example = ExampleSumFuse | ExampleSum | ExampleLengthF | ExampleConstFuse | ExampleMapInc | ExampleNoOp deriving (Eq, Show)---- | All the example algorithms.-allExamples :: [Example]-allExamples =- [ ExampleSumFuse,- ExampleSum,- ExampleLengthF,- ExampleConstFuse,- ExampleMapInc,- ExampleNoOp- ]+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" <> help "sum")+ <|> 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@@ -123,6 +116,8 @@ | 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@@ -132,6 +127,8 @@ 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@@ -141,19 +138,30 @@ 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 $ fap label f a-testExample (PatternSum label f a) = void $ fap label f a-testExample (PatternLengthF label f a) = void $ fap label f a-testExample (PatternConstFuse label f a) = void $ fap label f a-testExample (PatternMapInc label f a) = void $ fap label f a-testExample (PatternNoOp label f a) = void $ fap label f 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 --- | run an example measurement.-statExamples :: (Semigroup a, MonadIO m) => Int -> PerfT m a ()-statExamples l = mapM_ testExample ((`examplePattern` l) <$> allExamples)+-- | Convert an 'ExamplePattern' to a tasty-bench run.+tastyExample :: ExamplePattern Int -> Benchmarkable+tastyExample (PatternSumFuse _ f a) = nf f a+tastyExample (PatternSum _ f a) = nf f a+tastyExample (PatternLengthF _ f a) = nf f a+tastyExample (PatternConstFuse _ f a) = nf f a+tastyExample (PatternMapInc _ f a) = nf f a+tastyExample (PatternNoOp _ f a) = nf f a+tastyExample (PatternNub _ f a) = nf f a+tastyExample (PatternFib _ f a) = nf f a -- | Unification of sum function applications data SumPattern a@@ -477,3 +485,7 @@ 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)
src/Perf/BigO.hs view
@@ -17,27 +17,26 @@ fromOrder, toOrder, order,- mcurve,- dcurve,- tcurve, diffs, bestO, estO, estOs,- estOrder,+ makeNs,+ OrderOptions (..),+ defaultOrderOptions,+ parseOrderOptions, ) where import Data.Bool+import Data.FormatN import Data.List qualified as List-import Data.Map.Strict qualified as Map import Data.Maybe import Data.Monoid import Data.Vector qualified as V import GHC.Generics-import Perf.Stats-import Perf.Time-import Perf.Types+import Options.Applicative+import Prettyprinter import Prelude -- $setup@@ -181,26 +180,28 @@ 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, bigConstant :: a} deriving (Eq, Ord, Show, Generic, Functor)+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, bigConstant = 100.0}+-- BigOrder {bigOrder = N2, bigFactor = 1.0} fromOrder :: Order Double -> BigOrder Double-fromOrder o' = BigOrder o f r+fromOrder o' = BigOrder o f where (o, f) = bigO o'- r = runtime 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,100.0]}+-- 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 r) = order o f + order N0 r+toOrder (BigOrder o f) = order o f -- | The factor for each O given an n, and a measurement. --@@ -249,26 +250,26 @@ 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) --- | performance curve for a Measure.-mcurve :: (Semigroup a) => Measure IO a -> (Int -> b) -> [Int] -> IO [a]-mcurve m f ns = mapM (\n -> (Map.! "") <$> execPerfT m (f |$| n)) ns+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) --- | repetitive Double Meaure performance curve.-dcurve :: (Int -> Measure IO [Double]) -> StatDType -> Int -> (Int -> a) -> [Int] -> IO [Double]-dcurve m s sims f ns = fmap getSum <$> mcurve (Sum . statD s <$> m sims) f ns+data OrderOptions = OrderOptions+ { doOrder :: Bool,+ orderLow :: Int,+ orderDivisor :: Double+ }+ deriving (Eq, Show, Generic) --- | time performance curve.-tcurve :: StatDType -> Int -> (Int -> a) -> [Int] -> IO [Double]-tcurve = dcurve (fmap (fmap fromIntegral) . times)+defaultOrderOptions :: OrderOptions+defaultOrderOptions = OrderOptions False 10 9 --- | BigOrder estimate------ > estOrder (\x -> sum [1..x]) 100 [1,10,100,1000,10000]--- > BigOrder {bigOrder = N1, bigFactor = 76.27652961460446, bigConstant = 0.0}------ > estOrder (\x -> sum $ nub [1..x]) 100 [1,10,100,1000]--- > BigOrder {bigOrder = N2, bigFactor = 13.485763594353541, bigConstant = 0.0}-estOrder :: (Int -> b) -> Int -> [Int] -> IO (BigOrder Double)-estOrder f sims ns = do- xs <- tcurve StatBest sims f ns- pure $ fromOrder $ fst $ estO (fromIntegral <$> ns) xs+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")
+ src/Perf/Chart.hs view
@@ -0,0 +1,193 @@+{-# 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 = bool (stackCO stackn AlignLeft NoAlign 0.1 cs) (head cs) (length cs == 1)+ 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 = head cfg'+ 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 <>)
src/Perf/Measure.hs view
@@ -12,6 +12,7 @@ import Data.Text (Text) import Options.Applicative+import Options.Applicative.Help.Pretty qualified as OA import Perf.Count import Perf.Space import Perf.Stats@@ -21,12 +22,13 @@ import Prelude hiding (cycle) -- | Command-line measurement options.-data MeasureType = MeasureTime | MeasureSpace | MeasureSpaceTime | MeasureAllocation | MeasureCount deriving (Eq, Show)+data MeasureType = MeasureTime | MeasureNTime | MeasureSpace | MeasureSpaceTime | MeasureAllocation | MeasureCount deriving (Eq, Show) -- | Parse command-line 'MeasureType' options. parseMeasure :: Parser MeasureType parseMeasure =- flag' MeasureTime (long "time" <> help "measure time performance")+ 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")@@ -38,26 +40,29 @@ 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 --- | unification of the different measurements to being a list of doubles.+-- | 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 -> [Double] -> Double-measureFinalStat mt =+measureFinalStat :: MeasureType -> Int -> [Double] -> Double+measureFinalStat mt n = case mt of MeasureTime -> average+ MeasureNTime -> (/ fromIntegral n) . sum MeasureSpace -> average MeasureSpaceTime -> average MeasureAllocation -> average
src/Perf/Report.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -- | Reporting on performance, potentially checking versus a canned results.@@ -12,27 +13,31 @@ ReportOptions (..), defaultReportOptions, parseReportOptions,- infoReportOptions,+ PerfDumpOptions (..),+ defaultPerfDumpOptions,+ parsePerfDumpOptions,+ fromDump, report, reportMain,- reportMainWith, writeResult, readResult, CompareResult (..), compareNote,- reportOrg2D,+ report2D, Golden (..), defaultGolden, parseGolden, replaceDefaultFilePath,+ parseClock,+ reportToConsole, ) where +import Chart import Control.Exception import Control.Monad import Data.Bool import Data.Foldable-import Data.FormatN hiding (format) import Data.List (intercalate) import Data.List qualified as List import Data.Map.Merge.Strict@@ -41,13 +46,23 @@ import Data.Text qualified as Text import Data.Text.IO qualified as Text import GHC.Generics-import Options.Applicative+import Optics.Core+import Options.Applicative as OA+import Options.Applicative.Help.Pretty+import Perf.Algos+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 Test.Tasty+import Test.Tasty.Bench+import Text.PrettyPrint.Boxes qualified as B import Text.Printf hiding (parseFormat) import Text.Read @@ -60,97 +75,111 @@ -- | Command-line parser for 'Header' parseHeader :: Parser Header parseHeader =- flag' Header (long "header" <> help "include headers")- <|> flag' NoHeader (long "noheader" <> help "dont include headers")+ 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+ reportCompare :: CompareLevels,+ reportChart :: PerfChartOptions,+ reportDump :: PerfDumpOptions,+ reportGC :: Bool,+ reportOrder :: OrderOptions,+ reportTasty :: Bool } deriving (Eq, Show, Generic) --- | Default options------ >>> defaultReportOptions--- ReportOptions {reportN = 1000, reportClock = MonotonicRaw, reportStatDType = StatAverage, reportMeasureType = MeasureTime, reportGolden = Golden {golden = "other/bench.perf", check = True, record = False}, reportHeader = Header, reportCompare = CompareLevels {errorLevel = 0.2, warningLevel = 5.0e-2, improvedLevel = 5.0e-2}}+-- | Default reporting options defaultReportOptions :: ReportOptions defaultReportOptions = ReportOptions 1000+ 1000 defaultClock StatAverage MeasureTime defaultGolden Header defaultCompareLevels+ defaultPerfChartOptions+ defaultPerfDumpOptions+ False+ defaultOrderOptions+ False -- | Command-line parser for 'ReportOptions'-parseReportOptions :: Parser ReportOptions-parseReportOptions =+parseReportOptions :: ReportOptions -> Parser ReportOptions+parseReportOptions def = ReportOptions- <$> option auto (value 1000 <> long "runs" <> short 'n' <> help "number of runs to perform")+ <$> 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+ <*> switch (long "tasty" <> help "run tasty-bench") -- | Parse command-line 'Clock' options. parseClock :: Parser Clock parseClock =- flag' Monotonic (long "Monotonic")- <|> flag' Realtime (long "Realtime")- <|> flag' ProcessCPUTime (long "ProcessCPUTime")- <|> flag' ThreadCPUTime (long "ThreadCPUTime")+ 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")+ <|> flag' MonotonicRaw (long "MonotonicRaw" <> help "use MonotonicRaw clock") <|> pure MonotonicRaw #endif --- | Default command-line parser.-infoReportOptions :: ParserInfo ReportOptions-infoReportOptions =- info- (parseReportOptions <**> helper)- (fullDesc <> progDesc "perf benchmarking" <> header "reporting options")+data PerfDumpOptions = PerfDumpOptions {dumpFilepath :: FilePath, doDump :: Bool} deriving (Eq, Show, Generic) --- | Run and report a benchmark to the console. For example,------ @reportMain "foo" (fap "sum" sum [1..1000])@ would:------ - run a benchmark for summing the numbers 1 to a thousand.------ - look for saved performance data in other/foo-1000-MeasureTime-StatAverage.perf------ - report on performance in isolation or versus the canned data file if it exists.------ - exit with failure if the performace had degraded.-reportMain :: Name -> PerfT IO [[Double]] a -> IO ()-reportMain name t = do- o <- execParser infoReportOptions- reportMainWith o name t+defaultPerfDumpOptions :: PerfDumpOptions+defaultPerfDumpOptions = PerfDumpOptions "other/perf.map" False --- | Run and report a benchmark to the console with the supplied options.-reportMainWith :: ReportOptions -> Name -> PerfT IO [[Double]] a -> IO ()-reportMainWith o name t = do+-- | 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 :: Example -> ReportOptions -> Name -> (Int -> PerfT IO [[Double]] a) -> IO a+reportMain ex 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- m <- execPerfT (measureDs mt c n) t+ 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)+ when (view #reportTasty o) (reportTasty' ex o)+ pure a -- | Levels of geometric difference in compared performance that triggers reporting. data CompareLevels = CompareLevels {errorLevel :: Double, warningLevel :: Double, improvedLevel :: Double} deriving (Eq, Show)@@ -165,9 +194,9 @@ parseCompareLevels :: CompareLevels -> Parser CompareLevels parseCompareLevels c = CompareLevels- <$> option auto (value (errorLevel c) <> long "error" <> help "error level")- <*> option auto (value (warningLevel c) <> long "warning" <> help "warning level")- <*> option auto (value (improvedLevel c) <> long "improved" <> help "improved level")+ <$> 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 ()@@ -231,32 +260,32 @@ <> Map.elems (Map.mapWithKey (\k a -> Text.pack . mconcat $ printf "%-16s" <$> (k <> [a])) m) -- | Format a result as a table.-reportOrg2D :: Map.Map [Text] Text -> IO ()-reportOrg2D m = do- let rs = List.nub ((List.!! 1) . fst <$> Map.toList m)- let cs = List.nub ((List.!! 0) . fst <$> Map.toList m)- Text.putStrLn ("||" <> Text.intercalate "|" rs <> "|")- mapM_- ( \c ->- Text.putStrLn- ( "|"- <> c- <> "|"- <> Text.intercalate "|" ((\r -> m Map.! [c, r]) <$> rs)- <> "|"- )- )- cs+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 :: Bool, record :: Bool} deriving (Generic, Eq, Show)+data Golden = Golden {golden :: FilePath, check :: CheckGolden, record :: RecordGolden} deriving (Generic, Eq, Show) --- | Default filepath is "other/bench.perf"+-- | 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" True False+defaultGolden = Golden "other/bench.perf" CheckGolden NoRecordGolden -- | Replace the golden file name stem if it's the default. replaceGoldenDefault :: FilePath -> Golden -> Golden@@ -274,10 +303,10 @@ parseGolden :: Parser Golden parseGolden = Golden- <$> option str (Options.Applicative.value (golden defaultGolden) <> long "golden" <> short 'g' <> help "golden file name")+ <$> option str (value (golden defaultGolden) <> showDefaultWith show <> long "golden" <> short 'g' <> metavar "FILE" <> help "golden file name") -- True is the default for 'check'.- <*> flag True False (long "nocheck" <> help "do not check versus the golden file")- <*> switch (long "record" <> short 'r' <> help "record the result to the golden file")+ <*> (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 =@@ -293,17 +322,17 @@ report :: ReportOptions -> Map.Map [Text] [Double] -> IO () report o m = do when- (record (reportGolden o))+ ((== RecordGolden) $ record (reportGolden o)) (writeResult (golden (reportGolden o)) m') case check (reportGolden o) of- False -> reportConsoleNoCompare (reportHeader o) m'- True -> do+ NoCheckGolden -> reportConsoleNoCompare (reportHeader o) m'+ CheckGolden -> do mOrig <- readResult (golden (reportGolden o)) case mOrig of Left _ -> do reportConsoleNoCompare (reportHeader o) m' unless- (record (reportGolden o))+ ((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'@@ -311,3 +340,22 @@ 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'++reportTasty' :: Example -> ReportOptions -> IO ()+reportTasty' ex o = do+ t <- measureCpuTime (mkTimeout 1000000) (RelStDev 0.05) (tastyExample (examplePattern ex (view #reportLength o)))+ Text.putStrLn $ "tasty:time: " <> decimal (Just 3) (t * 1e9)
src/Perf/Space.hs view
@@ -20,7 +20,7 @@ import Prelude hiding (cycle) -- | GHC allocation statistics.-data SpaceStats = SpaceStats {allocatedBytes :: Word64, gcollects :: Word32, maxLiveBytes :: Word64, gcLiveBytes :: Word64, maxMem :: Word64} deriving (Read, Show, Eq)+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]@@ -47,11 +47,11 @@ 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) (gcs s) (max_live_bytes s) (gcdetails_live_bytes (gc s)) (max_mem_in_use_bytes s)+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", "gcollects", "maxLiveBytes", "gcLiveBytes", "MaxMem"]+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
src/Perf/Stats.hs view
@@ -24,6 +24,7 @@ import Data.Text (Text, pack) import NumHask.Space (quantile) import Options.Applicative+import Options.Applicative.Help.Pretty -- | Compute the median median :: [Double] -> Double@@ -59,10 +60,10 @@ -- | Parse command-line 'StatDType' options. parseStatD :: Parser StatDType parseStatD =- flag' StatBest (long "best" <> help "report upper decile")+ 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 StatAverage+ <|> pure StatBest -- | Add a statistic to a State Map addStat :: (Ord k, Monad m) => k -> s -> StateT (Map.Map k s) m ()
src/Perf/Time.hs view
@@ -17,11 +17,14 @@ tickForce, tickForceArgs, tickIO,+ tickIOWith, ticks, ticksIO, time, times, timesWith,+ timesN,+ timesNWith, stepTime, ) where@@ -191,15 +194,33 @@ -- | tick as a 'Measure' time :: Measure IO Nanos-time = Measure tick tickIO+time = Measure tick {-# INLINEABLE time #-} -- | tick as a multi-Measure times :: Int -> Measure IO [Nanos]-times n = Measure (ticks n) (ticksIO n)+times n = Measure (ticks n) {-# INLINEABLE times #-} -- | tickWith as a multi-Measure timesWith :: Clock -> Int -> Measure IO [Nanos]-timesWith c n = Measure (multi (tickWith c) n) (multiM (tickIOWith c) n)+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 #-}
src/Perf/Types.hs view
@@ -13,6 +13,7 @@ stepM, multi, multiM,+ multiN, -- * function application fap,@@ -43,37 +44,35 @@ 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.-data Measure m t = Measure- { measure :: forall a b. (a -> b) -> a -> m (t, b),- measureM :: forall a. m a -> m (t, a)+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 n) =+ fmap f (Measure m) = Measure (\f' a' -> fmap (first f) (m f' a'))- (fmap (first f) . n) -- | 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)) (\a -> (t,) <$> a)- (Measure mf nf) <*> (Measure mt nt) =+ 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)- (\a -> (\(nf', a') (t', _) -> (nf' t', a')) <$> nf a <*> nt a) -- | Convert a Measure into a multi measure. repeated :: (Applicative m) => Int -> Measure m t -> Measure m [t]-repeated n (Measure p m) =+repeated n (Measure p) = Measure (\f a -> fmap (\xs -> (fmap fst xs, snd (head xs))) (replicateM n (p f a)))- (fmap (\xs -> (fmap fst xs, snd (head xs))) . replicateM n . m) {-# INLINEABLE repeated #-} -- | Abstraction of a performance measurement with a pre and a post step wrapping the computation.@@ -89,12 +88,12 @@ -- | Convert a StepMeasure into a Measure toMeasure :: (Monad m) => StepMeasure m t -> Measure m t-toMeasure (StepMeasure pre' post') = Measure (step pre' post') (stepM pre' post')+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) (multiM (stepM pre' post') n)+toMeasureN n (StepMeasure pre' post') = Measure (multi (step pre' post') n) {-# INLINEABLE toMeasureN #-} -- | A single step measurement.@@ -115,18 +114,33 @@ pure (t, ma) {-# INLINEABLE stepM #-} --- | Multiple measurement+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 =- fmap (\xs -> (fmap fst xs, snd (head xs))) (replicateM n (action f a))+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, snd (head xs))) (replicateM n (action 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@@ -180,9 +194,9 @@ fam label a = PerfT $ do m <- fst <$> get- (t, ma) <- lift $ measureM m a+ (t, !ma) <- lift $ measure m (const a) () modify $ second (Map.insertWith (<>) label t)- return ma+ lift ma {-# INLINEABLE fam #-} -- | lift a pure, unnamed function application to PerfT