packages feed

perf 0.9.0 → 0.10.0

raw patch · 13 files changed

+1964/−500 lines, 13 filesdep +attoparsecdep +boxdep +box-csvdep −foldldep −transformersnew-component:exe:perf-explore

Dependencies added: attoparsec, box, box-csv, chart-svg, deepseq, formatn, gauge, numhask-space, optics-core, optparse-applicative, perf, recursion-schemes, vector

Dependencies removed: foldl, transformers

Files

ChangeLog.md view
@@ -1,7 +1,11 @@+0.10.0+===+* GHC 9.2.1 support+* inclusion of BigO+ 0.9.0 === * Removed deepseq dependency-  0.8.0 ===
+ app/explore.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- | basic measurement and callibration+module Main where++import Control.DeepSeq+import Control.Monad.State.Lazy+import Data.FormatN+import Data.List (intercalate)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Gauge+import Options.Applicative+import Perf+import Prelude++data RunType = RunExample | RunExamples | RunExampleIO | RunSums | RunLengths | RunGauge | RunNoOps | RunTicks deriving (Eq, Show)++data Options = Options+  { optionN :: Int,+    optionLength :: Int,+    optionStatDType :: StatDType,+    optionRunType :: RunType,+    optionMeasureType :: MeasureType,+    optionExample :: Example,+    optionGolden :: Golden,+    optionReportConfig :: ReportConfig,+    optionRawStats :: Bool+  }+  deriving (Eq, Show)++parseRun :: Parser RunType+parseRun =+  flag' RunSums (long "sums" <> help "run on sum algorithms")+    <|> flag' RunLengths (long "lengths" <> help "run on length algorithms")+    <|> flag' RunExamples (long "examples" <> help "run on example algorithms")+    <|> flag' RunExample (long "example" <> help "run on the example algorithm")+    <|> flag' RunExampleIO (long "exampleIO" <> help "exampleIO test")+    <|> flag' RunNoOps (long "noops" <> help "noops test")+    <|> flag' RunTicks (long "ticks" <> help "tick test")+    <|> flag' RunGauge (long "gauge" <> help "gauge runs on exmaple for comparison")+    <|> pure RunExample++options :: Parser Options+options =+  Options+    <$> option auto (value 1000 <> long "runs" <> short 'n' <> help "number of runs to perform")+    <*> option auto (value 1000 <> long "length" <> short 'l' <> help "length of list")+    <*> parseStatD+    <*> parseRun+    <*> parseMeasure+    <*> parseExample+    <*> parseGolden "golden"+    <*> parseReportConfig defaultReportConfig+    <*> switch (long "raw" <> short 'w' <> help "write raw statistics to file")++opts :: ParserInfo Options+opts =+  info+    (options <**> helper)+    (fullDesc <> progDesc "perf benchmarking" <> header "basic perf callibration")++-- | * exampleIO+exampleIO :: (Semigroup t) => PerfT IO t ()+exampleIO = 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))++-- | * 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 (snd . head . Map.toList <$> execPerfT (toMeasureN n stepTime) (f |$| a))+  addStat [l, "times"] . statD s . fmap fromIntegral =<< lift (snd . head . Map.toList <$> execPerfT (times 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 ())++-- | * gauge experiment+testGauge ::+  (NFData b) =>+  Text ->+  (a -> b) ->+  a ->+  IO ()+testGauge label f a = do+  Text.putStrLn label+  benchmarkWith defaultConfig (whnf f a)+  benchmarkWith defaultConfig (nf f a)++testGaugeExample :: ExamplePattern Int -> IO ()+testGaugeExample (PatternSumFuse label f a) = testGauge label f a+testGaugeExample (PatternSum label f a) = testGauge label f a+testGaugeExample (PatternLengthF label f a) = testGauge label f a+testGaugeExample (PatternConstFuse label f a) = testGauge label f a+testGaugeExample (PatternMapInc label f a) = testGauge label f a+testGaugeExample (PatternNoOp label f a) = testGauge label f a++main :: IO ()+main = do+  o <- execParser opts+  let !n = optionN o+  let !l = optionLength o+  let s = optionStatDType o+  let a = optionExample o+  let r = optionRunType o+  let mt = optionMeasureType o+  let gold' = optionGolden o+  let gold =+        case golden gold' of+          "other/golden.csv" ->+            gold'+              { golden =+                  "other/"+                    <> intercalate "-" [show r, show n, show l, show mt]+                    <> ".csv"+              }+          _ -> gold'+  let w = optionRawStats o+  let raw =+        "other/"+          <> intercalate "-" [show r, show n, show l, show mt]+          <> ".map"+  let cfg = optionReportConfig o++  case r of+    RunExample -> do+      m <- execPerfT (measureDs mt n) $ testExample (examplePattern a l)+      when w (writeFile raw (show m))+      report cfg gold (measureLabels mt) (statify s m)+    RunExamples -> do+      m <- statExamples n l (measureDs mt)+      when w (writeFile raw (show m))+      report cfg gold (measureLabels mt) (statify s m)+    RunExampleIO -> do+      m1 <- execPerfT (measureDs mt 1) exampleIO+      (_, (m', m2)) <- outer "outer-total" (measureDs mt 1) (measureDs mt 1) exampleIO+      let ms = mconcat [Map.mapKeys (\x -> ["normal", x]) m1, Map.mapKeys (\x -> ["outer", x]) (m2 <> m')]+      putStrLn ""+      when w (writeFile raw (show ms))+      report cfg gold (measureLabels mt) (fmap (statD s) <$> ms)+    RunSums -> do+      m <- statSums n l (measureDs mt)+      when w (writeFile raw (show m))+      report cfg gold (measureLabels mt) (statify s m)+    RunLengths -> do+      m <- statLengths n l (measureDs mt)+      when w (writeFile raw (show m))+      report cfg gold (measureLabels mt) (statify s m)+    RunNoOps -> do+      m <- perfNoOps (measureDs mt n)+      when w (writeFile raw (show m))+      report cfg gold (measureLabels mt) (allStats 4 (Map.mapKeys (: []) m))+    RunTicks -> do+      m <- statTicksSums n l s+      when w (writeFile raw (show m))+      reportOrg2D (fmap (expt (Just 3)) m)+    RunGauge -> do+      mapM_ testGaugeExample ((`examplePattern` l) <$> allExamples)
perf.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               perf-version:            0.9.0+version:            0.10.0 synopsis:           Low-level run time measurement. description:   A set of tools to accurately measure time performance of Haskell programs.@@ -16,34 +16,70 @@ license:            BSD-3-Clause license-file:       LICENSE build-type:         Simple-tested-with:        GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210821+tested-with:        GHC ==8.10.7 || ==9.2.2 extra-source-files: ChangeLog.md  source-repository head   type:     git   location: https://github.com/tonyday567/perf +common ghc-options-stanza+  ghc-options:+    -Wall -Wcompat -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info+    -hiedir=.hie+ library+  import:             ghc-options-stanza   exposed-modules:     Perf-    Perf.Cycle+    Perf.Algos+    Perf.BigO     Perf.Measure+    Perf.Report+    Perf.Space+    Perf.Stats+    Perf.Time+    Perf.Types    hs-source-dirs:     src-  ghc-options:-    -Wall -Wcompat -Wincomplete-record-updates-    -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info-    -hiedir=.hie -Wunused-packages-   build-depends:-    , base          >=4.7   && <5-    , containers    ^>=0.6-    , foldl         ^>=1.4-    , mtl           ^>=2.2.2-    , rdtsc         ^>=1.3-    , text          ^>=1.2-    , time          ^>=1.9-    , transformers  ^>=0.5+    , attoparsec            ^>=0.14+    , base                  >=4.7    && <5+    , box                   ^>=0.8.1+    , box-csv               ^>=0.2+    , chart-svg             ^>=0.3+    , containers            ^>=0.6+    , deepseq               >=1.4.4  && <1.4.8+    , formatn               ^>=0.2.1+    , mtl                   ^>=2.2.2+    , numhask-space         ^>=0.10+    , optics-core           ^>=0.4+    , optparse-applicative  ^>=0.17+    , rdtsc                 ^>=1.3+    , recursion-schemes     ^>=5.2.2+    , text                  ^>=1.2+    , time                  ^>=1.9+    , vector                ^>=0.12.3    default-language:   Haskell2010   default-extensions:+  ghc-options:        -O2++executable perf-explore+  import:           ghc-options-stanza+  main-is:          explore.hs+  hs-source-dirs:   app+  build-depends:+    , base                  >=4.7   && <5+    , containers            ^>=0.6+    , deepseq               >=1.4.4 && <1.4.8+    , formatn               ^>=0.2+    , gauge                 ^>=0.2.5+    , mtl                   ^>=2.2.2+    , optparse-applicative  ^>=0.17+    , perf+    , text                  ^>=1.2++  default-language: Haskell2010+  ghc-options:      -O2
src/Perf.hs view
@@ -1,135 +1,43 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RebindableSyntax #-} {-# 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.+-- /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').+-- 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 function, along with a text label (that will be displayed in the final summary) and the measurement function. -- -- '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' :------ >   (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)--- -- Running the code produces a tuple of the original computation results, and a Map of performance measurements that were specified.  Indicative results: ----- > file read                               4.92e5 cycles--- > length                                  1.60e6 cycles--- > print to screen                         1.06e5 cycles--- > sum                                     8.12e3 cycles--- -- == Note on RDTSC ----- 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+-- 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 fluctuations due to power throttling. For more details, see : https://en.wikipedia.org/wiki/Time_Stamp_Counter module Perf-  ( PerfT,-    Perf,-    perf,-    perfN,-    runPerfT,-    evalPerfT,-    execPerfT,-    module Perf.Cycle,+  ( -- * re-exports+    module Perf.Algos,+    module Perf.Time,+    module Perf.BigO,+    module Perf.Space,+    module Perf.Report,+    module Perf.Stats,+    module Perf.Types,     module Perf.Measure,   ) where -import Control.Monad.IO.Class-import Control.Monad.State.Lazy-import Data.Functor.Identity-import qualified Data.Map as Map-import qualified Data.Text as T-import Perf.Cycle+import Perf.Algos+import Perf.BigO import Perf.Measure-import Prelude---- $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, Num 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 (+) 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)
+ src/Perf/Algos.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# 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 (..),+    allExamples,+    parseExample,+    ExamplePattern (..),+    examplePattern,+    exampleLabel,+    testExample,+    statExamples,++    -- * 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.Foldable+import Data.Functor.Foldable+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Options.Applicative+import Perf.Types++-- | 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+  ]++-- | 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' 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 ()")+    <|> 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 (() -> ()) ()++-- | 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++-- | 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 ()) ()++-- | 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++-- | run an example measurement.+statExamples :: (MonadIO m) => Int -> Int -> (Int -> Measure m [a]) -> m (Map.Map Text [a])+statExamples n l m = execPerfT (m n) $ mapM_ testExample ((`examplePattern` l) <$> allExamples)++-- | 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)
+ src/Perf/BigO.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++-- | Order of complexity calculations.+--+-- <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))%20etc What is Order of Complexity> .+--+-- <https://donsbot.wordpress.com/2008/06/04/haskell-as-fast-as-c-working-at-a-high-altitude-for-low-level-performance/ donsbot blog>+--+-- <https://www.fpcomplete.com/haskell/tutorial/profiling/ profiling>+--+-- <https://www.reddit.com/r/haskell/comments/nl0rkl/looking_for_good_rules_of_thumbs_on_what_haskell/ rules of thumb>+module Perf.BigO+  ( O (..),+    olist,+    promote,+    promote1,+    promote_,+    demote,+    demote1,+    spectrum,+    Order (..),+    bigO,+    runtime,+    BigOrder (..),+    fromOrder,+    toOrder,+    order,+    mcurve,+    dcurve,+    tcurve,+    diffs,+    bestO,+    estO,+    estOs,+    estOrder,+  )+where++import Data.Bool+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Monoid+import qualified Data.Vector as V+import GHC.Generics+import Perf.Stats+import Perf.Time+import Perf.Types+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, bigConstant :: a} deriving (Eq, Ord, Show, Generic, Functor)++-- | compute the BigOrder+--+-- >>> fromOrder o+-- BigOrder {bigOrder = N2, bigFactor = 1.0, bigConstant = 100.0}+fromOrder :: Order Double -> BigOrder Double+fromOrder o' = BigOrder o f r+  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]}+toOrder :: BigOrder Double -> Order Double+toOrder (BigOrder o f r) = order o f + order N0 r++-- | 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)++-- | 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++-- | 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++-- | time performance curve.+tcurve :: StatDType -> Int -> (Int -> a) -> [Int] -> IO [Double]+tcurve = dcurve (fmap (fmap fromIntegral) . times)++-- | BigOrder estimate+--+-- > estOrder (\x -> sum [1..x]) 100 [1,10,100,1000,10000]+-- BigOrder {bigOrder = N1, bigFactor = 76.27652961460446, 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
− src/Perf/Cycle.hs 
@@ -1,245 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RebindableSyntax #-}-{-# 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 <https://en.wikipedia.org/wiki/Time_Stamp_Counter rdtsc> 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-  ( -- $usage-    Cycle,-    tick_,-    warmup,-    tick,-    tick',-    tickIO,-    tickNoinline,-    ticks,-    ticksIO,-    ns,-    tickWHNF,-    tickWHNF',-    tickWHNFIO,-    ticksWHNF,-    ticksWHNFIO,-  )-where--import qualified Control.Foldl as L (fold, genericLength, premap, sum)-import Control.Monad (replicateM)-import Data.Foldable (toList)-import Data.Sequence (Seq (..))-import GHC.Word (Word64)-import System.CPUTime.Rdtsc-import Prelude---- $setup--- >>> import Perf.Cycle--- >>> import Control.Monad--- >>> import Data.Foldable (foldl')--- >>> import qualified Control.Foldl as L--- >>> let n = 1000--- >>> let a = 1000--- >>> let f x = foldl' (+) 0 [1 .. x]---- $usage--- >>> import Perf.Cycle--- >>> import Control.Monad--- >>> 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' :: (a -> b) -> a -> IO (Cycle, b)-tick' f a = do-  !t <- rdtsc-  !a' <- pure (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 :: (a -> b) -> a -> IO (Cycle, b)-tick !f !a = tick' f a-{-# INLINE tick #-}--tickNoinline :: (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 :: IO a -> IO (Cycle, a)-tickIO a = do-  t <- rdtsc-  !a' <- a-  t' <- rdtsc-  pure (t' - t, a')--tickIONoinline :: 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 :: Int -> (a -> b) -> a -> IO ([Cycle], b)-ticks n0 f a = go f a n0 Empty-  where-    go f' a' n ts-      | n <= 0 = pure (toList ts, f a)-      | otherwise = do-        (t, _) <- tickNoinline f a-        go f' a' (n - 1) (ts :|> t)-{-# 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 :: Int -> IO a -> IO ([Cycle], a)-ticksIO n0 a = go a n0 Empty-  where-    go a' n ts-      | n <= 0 = do-        a'' <- a'-        pure (toList ts, a'')-      | otherwise = do-        (t, _) <- tickIONoinline a'-        go a' (n - 1) (ts :|> t)-{-# 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 Empty-  where-    go f' a' n ts-      | n <= 0 = pure (toList ts, f a)-      | otherwise = do-        (t, _) <- tickWHNFNoinline f a-        go f' a' (n - 1) (ts :|> t)-{-# NOINLINE ticksWHNF #-}---- | WHNF version-ticksWHNFIO :: Int -> IO a -> IO ([Cycle], a)-ticksWHNFIO n0 a = go a n0 Empty-  where-    go a' n ts-      | n <= 0 = do-        a'' <- a'-        pure (toList ts, a'')-      | otherwise = do-        (t, _) <- tickWHNFIONoinline a'-        go a' (n - 1) (ts :|> t)-{-# NOINLINE ticksWHNFIO #-}
src/Perf/Measure.hs view
@@ -1,134 +1,47 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE StrictData #-}-{-# OPTIONS_GHC -Wall #-}+{-# 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,+  ( MeasureType (..),+    parseMeasure,+    measureDs,+    measureLabels,   ) where -import Control.Monad-import Data.Fixed (Fixed (MkFixed))-import Data.Time.Clock-import Perf.Cycle-import System.CPUTime-import System.CPUTime.Rdtsc-import Prelude---- $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.-  (Num 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')---- | 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---- | 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+import Data.Text (Text)+import Options.Applicative+import Perf.Space+import Perf.Time+import Perf.Types+import Prelude hiding (cycle) --- | a measure using 'getCurrentTime' (unit is seconds)------ >>> r <- runMeasure realtime (pure $ foldl' (+) 0 [0..1000])------ > (0.000046,500500)-realtime :: Measure IO Double-realtime = Measure m0 start stop-  where-    m0 = 0-    start = getCurrentTime-    stop a = do-      t <- getCurrentTime-      return $ fromNominalDiffTime $ diffUTCTime t a+-- | Command-line measurement options.+data MeasureType = MeasureTime | MeasureSpace | MeasureSpaceTime | MeasureAllocation deriving (Eq, Show) -fromNominalDiffTime :: NominalDiffTime -> Double-fromNominalDiffTime t = fromInteger i * 1e-12-  where-    (MkFixed i) = nominalDiffTimeToSeconds t+-- | Parse command-line 'MeasureType' options.+parseMeasure :: Parser MeasureType+parseMeasure =+  flag' MeasureTime (long "time" <> help "measure 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")+    <|> 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 -> Int -> Measure IO [[Double]]+measureDs mt n =+  case mt of+    MeasureTime -> fmap ((: []) . fromIntegral) <$> times 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) --- | 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 the different measurements to being a list of doubles.+measureLabels :: MeasureType -> [Text]+measureLabels mt =+  case mt of+    MeasureTime -> ["time"]+    MeasureSpace -> spaceLabels+    MeasureSpaceTime -> spaceLabels <> ["time"]+    MeasureAllocation -> ["allocation"]
+ src/Perf/Report.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Reporting on performance, potentially checking versus a canned results.+module Perf.Report+  ( Format (..),+    parseFormat,+    Header (..),+    parseHeader,+    CompareLevels (..),+    defaultCompareLevels,+    parseCompareLevels,+    ReportConfig (..),+    defaultReportConfig,+    parseReportConfig,+    writeResult,+    readResult,+    compareNote,+    outercalate,+    reportGolden,+    reportOrg2D,+    Golden (..),+    parseGolden,+    report,+  )+where++import Box hiding (value)+import qualified Box.Csv as Csv+import Control.Monad+import qualified Data.Attoparsec.Text as A+import Data.Bool+import Data.Either (fromRight)+import Data.Foldable+import Data.FormatN hiding (format)+import qualified Data.List as List+import Data.Map.Merge.Strict+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Generics+import Options.Applicative+import Text.Printf hiding (parseFormat)++-- | Type of format for report+data Format = OrgMode | ConsoleMode deriving (Eq, Show, Generic)++-- | Command-line parser for 'Format'+parseFormat :: Format -> Parser Format+parseFormat f =+  flag' OrgMode (long "orgmode" <> help "report using orgmode table format")+    <|> flag' ConsoleMode (long "console" <> help "report using plain table format")+    <|> pure f++-- | Whether to include header information.+data Header = Header | NoHeader deriving (Eq, Show, Generic)++-- | Command-line parser for 'Header'+parseHeader :: Header -> Parser Header+parseHeader h =+  flag' Header (long "header" <> help "include headers")+    <|> flag' NoHeader (long "noheader" <> help "dont include headers")+    <|> pure h++-- | 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) <> 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")++-- | Report configuration options+data ReportConfig = ReportConfig+  { format :: Format,+    includeHeader :: Header,+    levels :: CompareLevels+  }+  deriving (Eq, Show, Generic)++-- |+-- >>> defaultReportConfig+-- ReportConfig {format = ConsoleMode, includeHeader = Header, levels = CompareLevels {errorLevel = 0.2, warningLevel = 5.0e-2, improvedLevel = 5.0e-2}}+defaultReportConfig :: ReportConfig+defaultReportConfig = ReportConfig ConsoleMode Header defaultCompareLevels++-- | Parse 'ReportConfig' command line options.+parseReportConfig :: ReportConfig -> Parser ReportConfig+parseReportConfig c =+  ReportConfig+    <$> parseFormat (format c)+    <*> parseHeader (includeHeader c)+    <*> parseCompareLevels (levels c)++-- | Write results to file, in CSV format.+writeResult :: FilePath -> Map.Map [Text] Double -> IO ()+writeResult f m = glue <$> Csv.rowCommitter (Csv.CsvConfig f ',' Csv.NoHeader) (\(ls, v) -> ls <> [expt (Just 3) v]) <*|> qList (Map.toList m)++-- | Read results from file that are in CSV format.+readResult :: FilePath -> IO (Map.Map [Text] Double)+readResult f = do+  r <- Csv.runCsv (Csv.CsvConfig f ',' Csv.NoHeader) Csv.fields+  let r' = [x | (Right x) <- r]+  let l = (\x -> (List.init x, fromRight 0 (A.parseOnly Csv.double (List.last x)))) <$> r'+  pure $ Map.fromList l++-- | Comparison data between two results.+data CompareResult = CompareResult {oldResult :: Maybe Double, newResult :: Maybe Double, noteResult :: Text} deriving (Show, Eq)++-- | 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 = ""++-- | Like intercalate, but on the outside as well.+outercalate :: Text -> [Text] -> Text+outercalate c ts = c <> Text.intercalate c ts <> c++-- | Report to a console, comparing the measurement versus a canned file.+reportGolden :: ReportConfig -> FilePath -> Map.Map [Text] Double -> IO ()+reportGolden cfg f m = do+  mOrig <- readResult f+  let n = compareNote (levels cfg) mOrig m+  reportToConsole $ formatCompare (format cfg) (includeHeader cfg) n++-- | Org-mode style header.+formatOrgHeader :: Map.Map [Text] a -> [Text] -> [Text]+formatOrgHeader m ts =+  [ outercalate "|" ((("label" <>) . Text.pack . show <$> [1 .. labelCols]) <> ts),+    outercalate "|" (replicate (labelCols + 1) "---")+  ]+  where+    labelCols = maximum $ length <$> Map.keys m++-- | Console-style header information.+formatConsoleHeader :: Map.Map [Text] a -> [Text] -> [Text]+formatConsoleHeader m ts =+  [mconcat $ Text.pack . printf "%-20s" <$> ((("label" <>) . Text.pack . show <$> [1 .. labelCols]) <> ts), mempty]+  where+    labelCols = maximum $ length <$> Map.keys m++-- | Format a comparison.+formatCompare :: Format -> Header -> Map.Map [Text] CompareResult -> [Text]+formatCompare f h m =+  case f of+    OrgMode ->+      bool [] (formatOrgHeader m ["old_result", "new_result", "status"]) (h == Header)+        <> Map.elems (Map.mapWithKey (\k a -> outercalate "|" (k <> compareReport a)) m)+    ConsoleMode ->+      bool [] (formatConsoleHeader m ["old_result", "new_result", "status"]) (h == Header)+        <> Map.elems (Map.mapWithKey (\k a -> Text.pack . mconcat $ printf "%-20s" <$> (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 in org-mode style+formatOrg :: Header -> Map.Map [Text] Text -> [Text]+formatOrg h m =+  bool [] (formatOrgHeader m ["results"]) (h == Header)+    <> Map.elems (Map.mapWithKey (\k a -> outercalate "|" (k <> [a])) m)++-- | Format a result in console-style+formatConsole :: Header -> Map.Map [Text] Text -> [Text]+formatConsole h m =+  bool [] (formatConsoleHeader m ["results"]) (h == Header)+    <> Map.elems (Map.mapWithKey (\k a -> Text.pack . mconcat $ printf "%-20s" <$> (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++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)++-- | Parse command-line golden file options.+parseGolden :: String -> Parser Golden+parseGolden def =+  Golden+    <$> option str (Options.Applicative.value ("other/" <> def <> ".csv") <> long "golden" <> short 'g' <> help "golden file name")+    <*> switch (long "check" <> short 'c' <> help "check versus a golden file")+    <*> switch (long "record" <> short 'r' <> help "record the result to a golden file")++-- | Report results+report :: ReportConfig -> Golden -> [Text] -> Map.Map [Text] [Double] -> IO ()+report cfg g labels m = do+  bool+    (reportToConsole (formatIn (format cfg) (includeHeader cfg) (expt (Just 3) <$> m')))+    (reportGolden cfg (golden g) m')+    (check g)+  when+    (record g)+    (writeResult (golden g) m')+  where+    m' = Map.fromList $ mconcat $ (\(ks, xss) -> zipWith (\x l -> (ks <> [l], x)) xss labels) <$> Map.toList m++-- | Format a result given 'Format' and 'Header' preferences.+formatIn :: Format -> Header -> Map.Map [Text] Text -> [Text]+formatIn f h = case f of+  OrgMode -> formatOrg h+  ConsoleMode -> formatConsole h
+ src/Perf/Space.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# OPTIONS_GHC -Wall #-}++-- | Space performance measurement.+module Perf.Space+  ( SpaceStats (..),+    ssToList,+    spaceLabels,+    space,+    allocation,+  )+where++import Control.Monad.State.Lazy+import Data.String+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 {allocatedBytes :: Word64, gcollects :: Word32, maxLiveBytes :: Word64, gcLiveBytes :: Word64, maxMem :: Word64} 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) (gcs s) (max_live_bytes s) (gcdetails_live_bytes (gc s)) (max_mem_in_use_bytes s)++-- | Labels for 'SpaceStats'.+spaceLabels :: [Text]+spaceLabels = ["allocated", "gcollects", "maxLiveBytes", "gcLiveBytes", "MaxMem"]++-- | 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 #-}++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 #-}
+ src/Perf/Stats.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -Wall #-}++-- | Statistical choices for multiple performance measurements.+module Perf.Stats+  ( average,+    median,+    tenth,+    averageI,+    averageSecs,+    StatDType (..),+    statD,+    statDs,+    parseStatD,+    -- stat reporting+    addStat,+    ordy,+    allStats,+    statify,+  )+where++import Control.Monad.State.Lazy+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Text (Text, pack)+import NumHask.Space (quantile)+import Options.Applicative++-- | 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)++-- | Compute the average time in seconds.+averageSecs :: [Double] -> Double+averageSecs xs = sum xs / (fromIntegral . length $ xs) / 2.5e9++-- | Command-line options for type of statistic.+data StatDType = StatAverage | StatMedian | StatBest | StatSecs deriving (Eq, Show)++-- | Compute a statistic.+statD :: StatDType -> [Double] -> Double+statD StatBest = tenth+statD StatMedian = median+statD StatAverage = average+statD StatSecs = averageSecs++-- | 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+statDs StatSecs = fmap averageSecs . List.transpose++-- | Parse command-line 'StatDType' options.+parseStatD :: Parser StatDType+parseStatD =+  flag' StatBest (long "best" <> help "report upper decile")+    <|> flag' StatMedian (long "median" <> help "report median")+    <|> flag' StatAverage (long "average" <> help "report average")+    <|> flag' StatSecs (long "averagesecs" <> help "report average in seconds")+    <|> pure StatAverage++-- | 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
+ src/Perf/Time.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | 'tick' uses the rdtsc chipset to measure time performance of a computation.+--+-- The measurement unit is one oscillation of the chip crystal as measured by the <https://en.wikipedia.org/wiki/Time_Stamp_Counter rdtsc> 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.Time+  (+    tick_,+    warmup,+    tick,+    tickWHNF,+    tickLazy,+    tickForce,+    tickForceArgs,+    tickIO,+    ticks,+    ticksIO,+    Cycles (..),+    cputime,+    clocktime,+    time,+    times,+    stepTime,+  )+where++import Control.DeepSeq+import Control.Monad (replicateM_)+import Data.Fixed+import Data.Time+import GHC.Word (Word64)+import Perf.Types+import System.CPUTime+import System.CPUTime.Rdtsc+import Prelude++-- | Clock count.+newtype Cycles = Cycles {word :: Word64}+  deriving (Show, Read, Eq, Ord, Num, Real, Enum, Integral)++instance Semigroup Cycles where+  (<>) = (+)++instance Monoid Cycles where+  mempty = 0++-- | 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.+tick_ :: IO Cycles+tick_ = do+  t <- rdtsc+  t' <- rdtsc+  pure (Cycles (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.+warmup :: Int -> IO ()+warmup n = replicateM_ n tick_++-- | /tick f a/+--+-- - strictly evaluates f and a to WHNF+-- - starts the cycle counter+-- - strictly evaluates f a to WHNF+-- - stops the cycle counter+-- - returns (number of cycles, f a)+tick :: (a -> b) -> a -> IO (Cycles, b)+tick !f !a = do+  !t <- rdtsc+  !a' <- pure $! f a+  !t' <- rdtsc+  pure (Cycles (t' - t), a')+{-# INLINEABLE tick #-}++-- | /tickWHNF f a/+--+-- - starts the cycle counter+-- - 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)+-- - stops the cycle counter+-- - returns (number of cycles, f a)+tickWHNF :: (a -> b) -> a -> IO (Cycles, b)+tickWHNF f a = do+  !t <- rdtsc+  !a' <- pure $! f a+  !t' <- rdtsc+  pure (Cycles (t' - t), a')+{-# INLINEABLE tickWHNF #-}++-- | /tickLazy f a/+--+-- - starts the cycle counter+-- - lazily evaluates f a+-- - stops the cycle counter+-- - returns (number of cycles, f a)+tickLazy :: (a -> b) -> a -> IO (Cycles, b)+tickLazy f a = do+  t <- rdtsc+  let a' = f a+  t' <- rdtsc+  pure (Cycles (t' - t), a')+{-# INLINEABLE tickLazy #-}++-- | /tickForce f a/+--+-- - deeply evaluates f and a,+-- - starts the cycle counter+-- - deeply evaluates f a+-- - stops the cycle counter+-- - returns (number of cycles, f a)+tickForce :: (NFData a, NFData b) => (a -> b) -> a -> IO (Cycles, b)+tickForce (force -> !f) (force -> !a) = do+  !t <- rdtsc+  !a' <- pure (force (f a))+  !t' <- rdtsc+  pure (Cycles (t' - t), a')+{-# INLINEABLE tickForce #-}++-- | /tickForceArgs f a/+--+-- - deeply evaluates f and a,+-- - starts the cycle counter+-- - strictly evaluates f a to WHNF+-- - stops the cycle counter+-- - returns (number of cycles, f a)+tickForceArgs :: (NFData a) => (a -> b) -> a -> IO (Cycles, b)+tickForceArgs (force -> !f) (force -> !a) = do+  !t <- rdtsc+  !a' <- pure $! f a+  !t' <- rdtsc+  pure (Cycles (t' - t), a')+{-# INLINEABLE tickForceArgs #-}++-- | measures an /IO a/+tickIO :: IO a -> IO (Cycles, a)+tickIO a = do+  !t <- rdtsc+  !a' <- a+  !t' <- rdtsc+  pure (Cycles (t' - t), a')+{-# INLINEABLE tickIO #-}++-- | n measurements of a tick+--+-- returns a list of Cycles and the last evaluated f a+ticks :: Int -> (a -> b) -> a -> IO ([Cycles], b)+ticks = multi tick+{-# INLINEABLE ticks #-}++-- | n measurements of a tickIO+--+-- returns an IO tuple; list of Cycles and the last evaluated f a+ticksIO :: Int -> IO a -> IO ([Cycles], a)+ticksIO = multiM tickIO+{-# INLINEABLE ticksIO #-}++-- | tick as a 'StepMeasure'+--+stepTime :: StepMeasure IO Cycles+stepTime = StepMeasure start stop+  where+    start = Cycles <$> rdtsc+    stop r = fmap (\x -> x - r) (Cycles <$> rdtsc)+{-# INLINEABLE stepTime #-}++-- | a measure using 'getCPUTime' from System.CPUTime (unit is picoseconds)+cputime :: StepMeasure IO Integer+cputime = StepMeasure start stop+  where+    start = getCPUTime+    stop a = do+      t <- getCPUTime+      return $ t - a++-- | a measure using 'getCurrentTime' (unit is seconds)+clocktime :: StepMeasure IO Double+clocktime = StepMeasure start stop+  where+    start = getCurrentTime+    stop a = do+      t <- getCurrentTime+      return $ fromNominalDiffTime $ diffUTCTime t a++fromNominalDiffTime :: NominalDiffTime -> Double+fromNominalDiffTime t = fromInteger i * 1e-12+  where+    (MkFixed i) = nominalDiffTimeToSeconds t++-- | tick as a 'Measure'+time :: Measure IO Cycles+time = Measure tick tickIO+{-# INLINEABLE time #-}++-- | tick as a multi-Measure+times :: Int -> Measure IO [Cycles]+times n = Measure (ticks n) (ticksIO n)+{-# INLINEABLE times #-}
+ src/Perf/Types.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++-- | Abstract types of performance measurement.+module Perf.Types+  ( Measure (..),+    repeated,+    StepMeasure (..),+    toMeasure,+    toMeasureN,+    step,+    stepM,+    multi,+    multiM,++    -- * function application+    fap,+    afap,+    ffap,+    fan,+    fam,+    (|$|),+    ($|),+    (|+|),++    -- * PerfT monad+    PerfT (..),+    Perf,+    runPerfT,+    evalPerfT,+    execPerfT,+    outer,+    slop,+    slops,+  )+where++import Control.DeepSeq+import Control.Monad.State.Lazy+import Data.Bifunctor+import Data.Functor.Identity+import qualified Data.Map.Strict as Map+import Data.String+import Data.Text (Text)+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)+  }++instance (Functor m) => Functor (Measure m) where+  fmap f (Measure m n) =+    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) =+    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) =+  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.+--+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') (stepM 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)+{-# 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 #-}++-- | Multiple measurement+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))+{-# 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))+{-# INLINEABLE multiM #-}++-- | 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 $ measureM m a+    modify $ second (Map.insertWith (<>) label t)+    return 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)+      )