perf 0.1.2 → 0.2.0
raw patch · 8 files changed
+683/−618 lines, 8 filesdep +doctestdep +numhaskdep −chart-unitdep −mwc-probabilitydep ~base
Dependencies added: doctest, numhask
Dependencies removed: chart-unit, mwc-probability
Dependency ranges changed: base
Files
- examples/examples.hs +197/−0
- examples/examples.lhs +0/−327
- perf.cabal +39/−76
- src/Perf.hs +95/−43
- src/Perf/Cycle.hs +241/−0
- src/Perf/Cycles.hs +0/−129
- src/Perf/Measure.hs +96/−43
- test/test.hs +15/−0
+ examples/examples.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++import qualified Data.List as List+import qualified Data.Text as Text+import Data.Text.IO (writeFile, readFile)+import qualified Data.Map as Map+import qualified Data.Vector as V+import qualified Data.Vector.Storable as S+import qualified Data.Vector.Unboxed as U+import Formatting+import Options.Generic+import NumHask.Prelude hiding ((%))+import Perf++data Opts = Opts+ { runs :: Maybe Int -- <?> "number of runs"+ , sumTo :: Maybe Double -- <?> "sum to this number"+ } deriving (Generic, Show)++instance ParseRecord Opts++ticks :: Int -> (a -> b) -> a -> IO ([Cycle], b)+ticks n f a = do+ ts <- replicateM' n (tick f a)+ pure (fst <$> ts, snd $ List.last ts)++qtick :: Int -> (a -> b) -> a -> IO (Double, b)+qtick n f a = do+ ts <- replicateM' n (tick f a)+ pure (percentile 0.4 $ fst <$> ts, snd $ List.last ts)++main :: IO ()+main = do+ o :: Opts <- getRecord "a random bit of text"+ let n = fromMaybe 1000 (runs o)+ let a = fromMaybe 10000 (sumTo o)++ -- perf+ -- prior to Perfification+ 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)++ -- post-Perfification+ (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)++ when (result == result') $ print "PerfT preserves computations"++ let fmt = sformat ((right 40 ' ' %. stext) %prec 3 % " " % stext)+ writeFile "other/perf.md" $+ "\nperf cycle measurements\n---\n" <>+ code ((\(t,c) -> fmt t c "cycles") <$> Map.toList ms)++ -- | tick_+ onetick <- tick_+ ticks' <- replicateM 10 tick_+ manyticks <- replicateM 1000000 tick_+ let avticks = average manyticks+ let qticks = deciles 10 manyticks+ let tick999 = percentile 0.999 manyticks+ let tick99999 = percentile 0.99999 manyticks+ let tick99 = percentile 0.99 manyticks+ let tick40 = percentile 0.4 manyticks+ writeFile "other/tick_.md" $+ code+ [ "one tick_: " <> show onetick <> " cycles"+ , "next 10: " <> show ticks'+ , "average over 1m: " <> sformat (fixed 2) avticks <> " cycles"+ , "99.999% perc: " <> sformat commas (floor tick99999 :: Integer)+ , "99.9% perc: " <> sformat (fixed 2) tick999+ , "99th perc: " <> sformat (fixed 2) tick99+ , "40th perc: " <> sformat (fixed 2) tick40+ , "[min, 10th, 20th, .. 90th, max]:"+ , mconcat (sformat (" " % prec 4) <$> qticks)+ ]+++ -- tick+ _ <- warmup 100+ let f x = foldl' (+) 0 [1 .. x]+ (t, _) <- tick f a+ (ts, _) <- Main.ticks n f a+ let qt x = (`percentile` x) <$> [0, 0.3, 0.5, 0.9, 0.99, 1]+ writeFile "other/tick.md" $+ code+ [ "sum to " <> show a+ , "first measure: " <> show t <> " cycles"+ , "average over next " <> show n <> ": " <> sformat (fixed 2) (average ts) <>+ " cycles"+ , "[min, 30th, median, 90th, 99th, max]:"+ , mconcat (sformat (" " % prec 4) <$> qt ts)+ ]++ -- | ticks & friends+ (cs, _) <- Perf.ticks n f a+ let ft cs t =+ sformat+ ((right 40 ' ' %. stext) % prec 3 % " cycles")+ t+ (percentile 0.4 cs)+ let r1 = ft cs "Perf.ticks n f a"+ (cs, _) <- Main.ticks n f a+ let r2 = ft cs "Main.ticks n f a"+ (cs, _) <- Perf.ticksIO n (pure $ f a)+ let r3 = ft cs "Perf.ticksIO n (pure $ f a)"+ (c, _) <- Perf.qtick n f a+ let fq c t = sformat ((right 40 ' ' %. stext) %prec 3 % " cycles") t c+ let r4 = fq c "Perf.qtick n f a"+ (c, _) <- Main.qtick n f a+ let r5 = fq c "Main.qtick n f a"+ cs <- fmap fst <$> replicateM n (tick f a)+ let r6 = ft cs "replicateM n (tick f a)"+ cs <- fmap fst <$> replicateM' n (tick f a)+ let r7 = ft cs "replicateM' n (tick f a)"+ cs <- fmap fst <$> replicateM n (tickIO (pure (f a)))+ let r8 = ft cs "replicateM n (tickIO (pure (f a)))"+ cs <- fmap fst <$> replicateM n (tick (app (f a)) ())+ let r9 = ft cs "replicateM n (tick (app (f a)) ())"+ cs <- fmap fst <$> replicateM n (tick identity (f a))+ let r10 = ft cs "replicateM n (tick identity (f a))"+ cs <- fmap fst <$> replicateM n (tick (const (f a)) ())+ let r11 = ft cs "replicateM n (tick (const (f a)) ())"+ css <-+ fmap (fmap fst) <$>+ sequence ((replicateM n . tick f) <$> [1, 10, 100, 1000, 10000 :: Int])+ let r12 =+ "(replicateM n . tick f) <$> [1,10,100,1000,10000]: " <>+ mconcat (sformat (" " %prec 3) <$> (percentile 0.4 <$> css))+ (ts, _) <- Perf.tickns n f [1, 10, 100, 1000, 10000 :: Int]+ let r13 =+ "Perf.tickns n f [1,10,100,1000,10000]: " <>+ mconcat (sformat (" " %prec 3) <$> (percentile 0.4 <$> ts))+ writeFile "other/ticks.md" $+ code ["sum to " <> show a, r1, r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12, r13]++ -- vectors++ let sumv :: V.Vector Double -> Double+ sumv = V.foldl (+) 0++ let asv :: V.Vector Double =+ (\x -> V.generate (fromIntegral $ floor x) fromIntegral) a++ (t, _) <- Perf.ticks n sumv asv+ let rboxed = sformat ("boxed: " %prec 3) (percentile 0.4 t)++ let sums :: S.Vector Double -> Double+ sums = S.foldl (+) 0++ let ass :: S.Vector Double =+ (\x -> S.generate (fromIntegral $ floor x) fromIntegral) a++ (t, _) <- Perf.ticks n sums ass+ let rstorable = sformat ("storable: " %prec 3) (percentile 0.4 t)++ let sumu :: U.Vector Double -> Double+ sumu = U.foldl (+) 0++ let asu :: U.Vector Double =+ (\x -> U.generate (fromIntegral $ floor x) fromIntegral) a++ (t, _) <- Perf.ticks n sumu asu+ let runboxed = sformat ("unboxed: " %prec 3) (percentile 0.4 t)++ writeFile "other/vector.md" $+ code ["sum to " <> show a, rboxed, rstorable, runboxed]++ (t, _) <- Perf.ticks n f a+ putStrLn $ sformat ("Perf.Cycle.ticks n f a: " %prec 3) (percentile 0.4 t)++ -- perf basics+ (result, cs) <- runPerfT $+ perf "sum" cycles (pure $ foldl' (+) 0 [0..10000 :: Integer])+ putStrLn (show (result, cs) :: Text)+++code :: [Text] -> Text+code cs = "\n```\n" <> Text.intercalate "\n" cs <> "\n```\n"
− examples/examples.lhs
@@ -1,327 +0,0 @@-<meta charset="utf-8">-<link rel="stylesheet" href="https://tonyday567.github.io/other/lhs.css">-<script type="text/javascript" async- src="https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-MML-AM_CHTML">-</script>--[perf](https://tonyday567.github.io/perf/index.html)-===--[](https://travis-ci.org/tonyday567/perf) [](https://hackage.haskell.org/package/perf) [](http://stackage.org/lts/package/perf) [](http://stackage.org/nightly/package/perf)--[repo](https://github.com/tonyday567/perf)--If you want to make stuff very fast in haskell, you need to dig down below the criterion abstraction-level and start counting cycles using the [rdtsc](https://en.wikipedia.org/wiki/Time_Stamp_Counter) register on x86.--These examples are experiments in measuring cycles (or ticks), a development of intuition about what is going on at the very fast level.--The interface is subject to change as intuition develops and rabbit holes explored.--> {-# OPTIONS_GHC -Wall #-}-> {-# OPTIONS_GHC -fno-warn-type-defaults #-}-> {-# LANGUAGE OverloadedStrings #-}-> {-# LANGUAGE DataKinds #-}-> import Data.Text (pack, intercalate)-> import Data.Text.IO (writeFile)-> import Formatting-> import Protolude hiding ((%), intercalate)-> import Data.List ((!!))-> import Data.TDigest-> import System.Random.MWC.Probability-> import Options.Generic-> import qualified Control.Foldl as L-> import qualified Data.Vector as V-> import qualified Data.Vector.Unboxed as U-> import qualified Data.Vector.Storable as S-> import Chart-> --The examples below mostly use `Perf.Cycles`. There is also a monad layer in `Perf` which has been used in `other/summing.lhs`.--> import Perf--All the imports that are needed for charts--command line------> data Opts = Opts-> { runs :: Maybe Int -- <?> "number of runs"-> , sumTo :: [Double] -- <?> "sum to this number"-> , chartNum :: Maybe Int-> , truncAt :: Maybe Double-> }-> deriving (Generic, Show)-> -> instance ParseRecord Opts--main------> main :: IO ()-> main = do-> o :: Opts <- getRecord "a random bit of text"-> let n = fromMaybe 10000 (runs o)-> let as = case sumTo o of-> [] -> [1,10,100,1000,10000]-> x -> x-> let trunc = fromMaybe 5 (truncAt o)-> let numChart = min (length as) $ fromMaybe 3 (chartNum o)--For reference, based on a 2.6G machine one cycle is = 0.38 𝛈s--`tick_` taps the register twice to get a sense of the cost.--> onetick <- tick_-> ticks' <- replicateM 10 tick_-> avtick <- replicateM 1000000 tick_-> let average cs = L.fold ((/) <$> L.sum <*> L.genericLength) cs-> writeFile "other/onetick.md" $ code-> [ "one tick_: " <> pack (show onetick) <> " cycles"-> , "next 10: " <> pack (show ticks')-> , "average over 1m: " <>-> pack (show $ average (fromIntegral <$> avtick)) <> " cycles"-> ]--```include-other/onetick.md-```--Before we actually measure something, lets take a closer look at tick_.--A pattern I see on my machine are shifts by multiples of 4, which correspond to roughly the L1 [cache latency](http://stackoverflow.com/questions/1126529/what-is-the-cost-of-an-l1-cache-miss).--It pays to look at the whole distribution, and a compact way of doing that is to calculate quantiles:--> -- warmup 100-> xs <- replicateM 10000 tick_-> writeFile "other/tick_.md" $ code $-> (["[min, 10th, 20th, .. 90th, max]:"] :: [Text]) <>-> [mconcat (sformat (" " % prec 3) <$> deciles 5 (fromIntegral <$> xs))]--```include-other/tick_.md-```--The important cycle count for most work is around the 30th to 50th percentile, where you get a clean measure, hopefully free of GC activity and cache miss-fires.--The quantile print of tick_ sometimes shows a 12 to 14 point jump around the 90th percential, and this is in the zone of an L2 access. Without a warmup, one or more larger values occur at the start, and often are in the zone of an L2 miss. Sometimes there's also a few large hiccoughs at around 2k cycles.--summing-===--Let's measure something. The simplest something I could think of was summing.--The helper function `reportQuantiles` utilises `spins` which takes n measurements of a function application over a range of values to apply.--> let f :: Double -> Double-> f x = foldl' (+) 0 [1..x]-> _ <- warmup 100-> (cs,_) <- spins n tick f as-> reportQuantiles cs as "other/spin.md"-> --```include-other/spin.md-```--Each row represents summing to a certain point: 1 up to 10000, and each column is a decile: min, 10th .. 90th, max. The values in each cell are the number of cycles divided by the number of runs and the number of sumTo.--The first row (summing to 1) represents the cost of setting up the sum, so we're looking at about (692 - 128) = 560 cycles every run.--Overall, the computation looks like it's running in O(n) where n is the number of runs * nuber of sumTo. Specifically, I would write down the order at about:-- 123 * o(n) + 560 * o(1)--The exception is the 70th to 90th zone, where the number of cycles creeps up to 194 for 1k sumTo at the 90th percentile.--Charting the 1k sumTo:--> let xs_0 = fromIntegral <$> take 10000 (cs!!numChart) -- summing to 1000-> let xs1 = (\x -> min x (trunc*deciles 5 xs_0 !! 5)) <$> xs_0-> fileSvg "other/spin1k.svg" (750,250) $ pad 1.1 $ histLine xs1----Switching to a solo experiment gives:--~~~-stack exec "ghc" -- -O2 -rtsopts examples/summing.lhs-./examples/summing +RTS -s -RTS --runs 10000 --sumTo 1000 --chart --chartName other/sum1e3.svg --truncAt 4-~~~----Executable complexity has changed the profile of the overall computation. Both measurements have the same value, however, up to around the 30th percentile.---generic vector------Using vector to sum:--> let asv :: [V.Vector Double] = (\x -> V.generate (floor x) fromIntegral) <$> as-> let sumv :: V.Vector Double -> Double-> sumv x = V.foldl (+) 0 x-> (csv,_) <- spins n tick sumv asv-> reportQuantiles csv as "other/vectorGen.md"-> --```include-other/vectorGen.md-```--randomizing data------To avoid ghc (and fusion) trickiness, it's often a good idea to use random numbers instead of simple progressions. One day, a compiler will discover `x(x+1)/2` and then we'll be in real trouble.--> mwc <- create-> !asr <- (fmap V.fromList <$>) <$> sequence $ (\x -> samples x uniform mwc) . floor <$> as-> void $ warmup 100-> (csr,_) <- spins n tick sumv asr-> reportQuantiles csr as "other/vectorr.md"-> --```include-other/vectorr.md-```--Charting the 1k sumTo:--> let csr0 = fromIntegral <$> take 10000 (csr!!numChart) -- summing to 1000-> let csr1 = (\x -> min x (trunc*deciles 5 csr0 !! 5)) <$> csr0-> fileSvg "other/vector1k.svg" (750,250) $ pad 1.1 $ histLine csr1----unboxed------> !asu <- (fmap U.fromList <$>) <$> sequence $ (\x -> samples x uniform mwc) . floor <$> as-> let sumu :: U.Vector Double -> Double-> sumu x = U.foldl (+) 0 x-> void $ warmup 100-> (csu,_) <- spins n tick sumu asu-> reportQuantiles csu as "other/vectoru.md"-> --```include-other/vectoru.md-```--Charting the 1k sumTo:--> let csu0 = fromIntegral <$> take 10000 (csu!!numChart) -- summing to 1000-> let csu1 = (\x -> min x (trunc*deciles 5 csu0 !! 5)) <$> csu0-> fileSvg "other/vectoru1k.svg" (750,250) $ pad 1.1 $ histLine csu1----storable------> !ass <- (fmap S.fromList <$>) <$> sequence $ (\x -> samples x uniform mwc) . floor <$> as-> let sums :: S.Vector Double -> Double-> sums x = S.foldl (+) 0 x-> void $ warmup 100-> (css,_) <- spins n tick sums ass-> reportQuantiles css as "other/vectors.md"-> --```include-other/vectors.md-```--Charting the 1k sumTo:--> let css0 = fromIntegral <$> take 10000 (css!!numChart) -- summing to 1000-> let css1 = (\x -> min x (trunc*deciles 5 css0 !! 5)) <$> css0-> fileSvg "other/vectors1k.svg" (750,250) $ pad 1.1 $ histLine css1----tickf, ticka, tickfa------These functions attempt to discriminate between cycles used to compute `f a` (ie to apply the function f), and cycles used to force `a`. In experiments so far, this act of observation tends to change the number of cycles.--Separation of the `f` and `a` effects in `f a`--> void $ warmup 100-> (csr2,_) <- spins n tick sumv asr-> (csvf,_) <- spins n tickf sumv asr-> (csva,_) <- spins n ticka sumv asr-> (csvfa,_) <- spins n tickfa sumv asr-> reportQuantiles csr2 as "other/vectorr2.md"-> reportQuantiles csvf as "other/vectorf.md"-> reportQuantiles csva as "other/vectora.md"-> reportQuantiles (fmap fst <$> csvfa) as "other/vectorfaf.md"-> reportQuantiles (fmap snd <$> csvfa) as "other/vectorfaa.md"-> --a full tick--```include-other/vectorr2.md-```--just function application--```include-other/vectorf.md-```--just forcing `a`:--```include-other/vectora.md-```--the f splice of f a--```include-other/vectorfaf.md-```--the a slice of fa--```include-other/vectorfaa.md-```--> pure ()-> --helpers------> showxs :: [Double] -> Double -> Text-> showxs qs m =-> sformat (" " % Formatting.expt 2) m <> ": " <>-> mconcat (sformat (" " % prec 3) <$> ((/m) <$> qs))-> -> deciles :: (Foldable f) => Int -> f Double -> [Double]-> deciles n xs =-> (\x -> fromMaybe 0 $-> quantile x (tdigest xs :: TDigest 25)) <$>-> ((/fromIntegral n) . fromIntegral <$> [0..n]) :: [Double]-> -> reportQuantiles :: [[Cycles]] -> [Double] -> FilePath -> IO ()-> reportQuantiles css as name =-> writeFile name $ code $ zipWith showxs (deciles 5 . fmap fromIntegral <$> css) as-> -> code :: [Text] -> Text-> code cs = "\n~~~\n" <> intercalate "\n" cs <> "\n~~~\n"-> -> histLine :: [Double] -> Chart' a-> histLine xs =-> lineChart (repeat (LineConfig 0.002 (Color 0 0 1 0.1))) widescreen-> (zipWith (\x y -> [V2 x 0,V2 x y]) [0..] xs) <>-> axes-> ( chartAspect .~ widescreen-> $ chartRange .~ Just-> (Rect $ V2-> (Range (0.0,fromIntegral $ length xs))-> (Range (0,L.fold (L.Fold max 0 identity) xs)))-> $ def)
perf.cabal view
@@ -1,10 +1,10 @@ name: perf-version: 0.1.2+version: 0.2.0 synopsis: low-level performance statistics description: .- See <https://tonyday567.github.io/perf perf> for example results and write-up.+ A set of tools to measure time performance. . category: project@@ -34,108 +34,71 @@ exposed-modules: Perf, Perf.Measure,- Perf.Cycles+ Perf.Cycle build-depends:- base >= 4.7 && < 5,- rdtsc,+ base >= 4.7 && < 4.11,+ containers, foldl,+ numhask >= 0.1.2 && < 0.2, protolude,+ rdtsc, tdigest,- containers, time default-extensions:+ NegativeLiterals, NoImplicitPrelude,+ OverloadedStrings, UnicodeSyntax, BangPatterns,- BinaryLiterals,- DeriveFoldable,- DeriveFunctor,- DeriveGeneric,- DeriveTraversable,- DisambiguateRecordFields,- EmptyCase,- FlexibleContexts,- FlexibleInstances,- FunctionalDependencies,- GADTSyntax,- InstanceSigs,- KindSignatures,- LambdaCase,- MonadComprehensions,- MultiParamTypeClasses,- MultiWayIf,- NegativeLiterals,- OverloadedStrings,- ParallelListComp,- PartialTypeSignatures,- PatternSynonyms,- RankNTypes,- RecordWildCards,- RecursiveDo,- ScopedTypeVariables,- TupleSections,- TypeFamilies,- TypeOperators+ TypeSynonymInstances executable perf-examples default-language: Haskell2010 ghc-options:- -- -funbox-strict-fields -fforce-recomp- -- -threaded -rtsopts- -- -with-rtsopts=-N -O2 hs-source-dirs: examples main-is:- examples.lhs+ examples.hs build-depends:- base >= 4.7 && < 5,- protolude,- perf,- optparse-generic,+ base >= 4.7 && < 4.11,+ containers, formatting,- foldl,+ numhask,+ optparse-generic,+ perf,+ protolude, text,- vector,- tdigest,- chart-unit,- mwc-probability+ vector default-extensions:+ NegativeLiterals, NoImplicitPrelude,+ OverloadedStrings, UnicodeSyntax,- BangPatterns,- BinaryLiterals,- DeriveFoldable,- DeriveFunctor,- DeriveGeneric,- DeriveTraversable,- DisambiguateRecordFields,- EmptyCase,- FlexibleContexts,- FlexibleInstances,- FunctionalDependencies,- GADTSyntax,- InstanceSigs,- KindSignatures,- LambdaCase,- MonadComprehensions,- MultiParamTypeClasses,- MultiWayIf,+ ScopedTypeVariables++test-suite test+ default-language:+ Haskell2010+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test+ main-is:+ test.hs+ build-depends:+ base >= 4.7 && < 5,+ doctest,+ protolude,+ perf+ default-extensions: NegativeLiterals,+ NoImplicitPrelude, OverloadedStrings,- ParallelListComp,- PartialTypeSignatures,- PatternSynonyms,- RankNTypes,- RecordWildCards,- RecursiveDo,- ScopedTypeVariables,- TupleSections,- TypeFamilies,- TypeOperators+ UnicodeSyntax source-repository head type:
src/Perf.hs view
@@ -1,62 +1,114 @@-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-} +-- | 'PerfT' is a monad transformer designed to collect performance information.+-- The transformer can be used to add performance measurent to an existing code base using 'Measure's.+--+-- For example, here's some code doing some cheesey stuff:+--+-- > -- prior to Perfification+-- > 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)+--+-- And here's the code after 'Perf'ification, measuring performance of the components.+--+-- > (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+-- module Perf- (- -- * The Perf Monad- PerfT- , Perf- , perf- , perfN- , runPerfT- , evalPerfT- , execPerfT- , module Perf.Cycles- , module Perf.Measure- )- where+ ( PerfT+ , Perf+ , perf+ , perfN+ , runPerfT+ , evalPerfT+ , execPerfT+ , module Perf.Cycle+ , module Perf.Measure+ ) where -import Protolude-import Perf.Measure-import Perf.Cycles import qualified Data.Map as Map+import NumHask.Prelude+import Perf.Cycle+import Perf.Measure -newtype PerfT m b a =- PerfT { runPerf_ :: StateT (Map.Map Text b) m a }- deriving- ( Functor- , Applicative- , Monad- )+-- | 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 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 -perf :: (MonadIO m, Monoid b, Semigroup b) => 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, providing a label and a 'Measure'.+perf :: (MonadIO m, Additive b) => 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' -perfN :: (MonadIO m, Semigroup b, Monoid b) => Int -> 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'+-- | Lift a monadic computation to a PerfT m, and carry out the computation multiple times.+perfN ::+ (MonadIO m, Semigroup b, Monoid b)+ => Int+ -> 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 Text b)-runPerfT p =- flip runStateT Map.empty $ runPerf_ p+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+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 Text b)-execPerfT p =- flip execStateT Map.empty $ runPerf_ p+execPerfT p = flip execStateT Map.empty $ runPerf_ p
+ src/Perf/Cycle.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# 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+ ( -- $setup+ Cycle+ , tick_+ , warmup+ , tick+ , app+ , tickIO+ , ticks+ , qtick+ , ticksIO+ , tickns+ , force+ , replicateM'+ , average+ , deciles+ , percentile+ ) where++import qualified Control.Foldl as L+import Data.List+import Data.TDigest+import NumHask.Prelude hiding (force)+import System.CPUTime.Rdtsc+import qualified Protolude++-- $setup+-- >>> :set -XNoImplicitPrelude+-- >>> import Perf.Cycle+-- >>> let n = 1000+-- >>> let a = 1000+-- >>> let f x = foldl' (+) 0 [1 .. x]+--+++-- | an unwrapped Word64+type Cycle = Word64++instance AdditiveMagma Cycle where+ plus = (Protolude.+)++instance AdditiveUnital Cycle where+ zero = 0++instance AdditiveAssociative Cycle++instance AdditiveCommutative Cycle++instance Additive Cycle++instance AdditiveInvertible Cycle where+ negate = Protolude.negate++instance AdditiveGroup Cycle++instance ToInteger Cycle where+ toInteger = Protolude.toInteger++-- | 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)+-- >>> let qticks = deciles 10 manyticks+-- >>> let tick999 = percentile 0.999 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 f a` strictly applies a to f, and returns a (Cycle, f a)+--+-- >>> _ <- warmup 100+-- >>> (cs, _) <- tick f a+--+-- > one tick: 197012 cycles+-- > average over 1000: 10222.79 cycles -- 10 cycles per operation+-- > [min, 30th, median, 90th, 99th, max]:+-- > 1.002e4 1.011e4 1.013e4 1.044e4 1.051e4 2.623e4+tick :: (a -> b) -> a -> IO (Cycle, b)+tick f a = do+ !t <- rdtsc+ !a' <- pure (f a)+ !t' <- rdtsc+ pure (t' - t, a')++-- | evaluates and measures 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')++-- | needs more testing+app :: t -> () -> t+app e () = e+{-# NOINLINE app #-}++-- | n measurements of a tick+--+-- returns a list of Cycles and the last evaluated f a+--+-- GHC is very good as memoization, and any of the functions that measuring a computation multiple times are fraught. When a computation actually gets memoized is an inexact science. Current readings are:+--+-- > sum to 1000.0+-- > Perf.ticks n f a 8.37e3 cycles+-- > Main.ticks n f a 8.38e3 cycles+-- > Perf.ticksIO n (pure $ f a) 8.38e3 cycles+-- > Perf.qtick n f a 8.38e3 cycles+-- > Main.qtick n f a 8.38e3 cycles+-- > replicateM n (tick f a) 8.37e3 cycles+-- > replicateM' n (tick f a) 9.74e3 cycles+-- > replicateM n (tickIO (pure (f a))) 1.21e4 cycles+-- > replicateM n (tick (app (f a)) ()) 9.72e3 cycles+-- > replicateM n (tick identity (f n)) 18.2 cycles+-- > replicateM n (tick (const (f a)) ()) 9.71e3 cycles+-- > (replicateM n . tick f) <$> [1,10,100,1000,10000]: 16.3 16.2 16.3 16.2 16.2+-- > Perf.tickns n f [1,10,100,1000,10000]: 16.2 16.2 16.2 16.2 16.2+--+-- >>> let n = 1000+-- >>> (cs, fa) <- ticks n f a+--+ticks :: Int -> (a -> b) -> a -> IO ([Cycle], b)+ticks n f a = do+ ts <- replicateM' n (tick f a)+ pure (fst <$> ts, snd $ last ts)+{-# INLINE ticks #-}++-- | returns the 40th percentile measurement and the last evaluated f a+--+-- >>> (c, fa) <- qtick n f a+--+qtick :: Int -> (a -> b) -> a -> IO (Double, b)+qtick n f a = do+ ts <- replicateM' n (tick f a)+ pure (percentile 0.4 $ fst <$> ts, snd $ last ts)+{-# INLINE qtick #-}++-- | 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 n a = do+ cs <- replicateM n (tickIO a)+ pure (fst <$> cs, last $ snd <$> cs)++-- | n measurements on each of a list of a's to be applied to f.+--+-- Currently memoizing it's ass off+--+-- > tickns n f [1,10,100,1000]+--+tickns :: Int -> (a -> b) -> [a] -> IO ([[Cycle]], [b])+tickns n f as = do+ cs <- sequence $ ticks n f <$> as+ pure (fst <$> cs, snd <$> cs)++-- | extra oomph for those hard to reach evaluations+force :: (NFData a) => a -> a+force x = x `deepseq` x++-- | a replicateM with good attributes+replicateM' :: Monad m => Int -> m a -> m [a]+replicateM' n op' = go n []+ where+ go 0 acc = return $ reverse acc+ go n' acc = do+ x <- op'+ go (n' - 1) (x : acc)++-- | average of a Cycle foldable+--+-- > cAv <- average <$> ticks n f a+--+average :: (Foldable f) => f Cycle -> Double+average = L.fold (L.premap fromIntegral ((/) <$> L.sum <*> L.genericLength))++-- | compute deciles+--+-- > c5 <- decile 5 <$> ticks n f a+--+deciles :: (Functor f, Foldable f) => Int -> f Cycle -> [Double]+deciles n xs =+ (\x -> fromMaybe 0 $ quantile x (tdigest (fromIntegral <$> xs) :: TDigest 25)) <$>+ ((/ fromIntegral n) . fromIntegral <$> [0 .. n]) :: [Double]++-- | compute a percentile+--+-- > c <- percentoile 0.4 <$> ticks n f a+--+percentile :: (Functor f, Foldable f) => Double -> f Cycle -> Double+percentile p xs = fromMaybe 0 $ quantile p (tdigest (fromIntegral <$> xs) :: TDigest 25)+
− src/Perf/Cycles.hs
@@ -1,129 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Perf.Cycles where--import Protolude-import System.CPUTime.Rdtsc-import Data.List-import qualified Control.Foldl as L-import Data.TDigest---- | Cycles-type Cycles = Word64--instance Semigroup Cycles where- (<>) = (+)--instance Monoid Cycles where- mempty = 0- mappend = (+)----- | `tick f a` applies a to f, and strictly returns a (number of cycles, application result) tuple-tick :: (a -> b) -> a -> IO (Cycles, b)-tick f a = do- t <- rdtsc- !a' <- return (f a)- t' <- rdtsc- return (t' - t, a')---- | variation that just acts on an `a`-tick' :: a -> IO (Cycles, a)-tick' a = do- t <- rdtsc- !a' <- return a- t' <- rdtsc- return (t' - t, a')---- | variation that takes an `IO a`-tickM :: IO a -> IO (Cycles, a)-tickM a = do- t <- rdtsc- !a' <- a- t' <- rdtsc- return (t' - t, a')---- | variation that just measures the number of cycles to take a tick measurement-tick_ :: IO Cycles-tick_ = do- t <- rdtsc- t' <- rdtsc- return (t' - t)---- | `tickf f a` applies a to f, and strictly returns a (number of cycles, application result) tuple, measuring just the f effect-tickf :: (a -> b) -> a -> IO (Cycles, b)-tickf f a = do- !a' <- pure a- t <- rdtsc- !a'' <- return (f a')- t' <- rdtsc- return (t' - t, a'')---- | monadic version-tickfM :: (a -> IO b) -> a -> IO (Cycles, b)-tickfM f a = do- !a' <- pure a- t <- rdtsc- !a'' <- f a'- t' <- rdtsc- return (t' - t, a'')---- | `ticka f a` applies a to f, and strictly returns a (number of cycles, application result) tuple, measuring just the a effect-ticka :: (a -> b) -> a -> IO (Cycles, b)-ticka f a = do- t <- rdtsc- !a' <- pure a- t' <- rdtsc- !a'' <- return (f a')- return (t' - t, a'')---- | `tickfa f a` applies a to f, and strictly returns a (number of cycles, application result) tuple, measuring both the f and the a effects separately.-tickfa :: (a -> b) -> a -> IO ((Cycles, Cycles), b)-tickfa f a = do- t_a <- rdtsc- !a' <- pure a- t_a' <- rdtsc- !a'' <- return (f a')- t_f <- rdtsc- return ((t_f - t_a', t_a' - t_a), a'')---- | n measurements of whatever tick engine-spin :: Int -> ((a -> b) -> a -> IO (c, b)) ->- (a -> b) -> a -> IO ([c], b)-spin n tick f a = do- ticks <- replicateM n (tick f a)- pure (fst <$> ticks, snd $ last ticks)--spins :: Int -> ((a -> b) -> a -> IO (c, b)) ->- (a -> b) -> [a] -> IO ([[c]], [b])-spins n t f as = do- cs <- sequence $ spin n t f <$> as- pure (fst <$> cs, snd <$> cs)---- | n measurements of whatever tick engine-spinM :: Int -> ((a -> IO b) -> a -> IO (c, b)) ->- (a -> IO b) -> a -> IO ([c], b)-spinM n tick f a = do- ticks <- replicateM n (tick f a)- pure (fst <$> ticks, snd $ last ticks)---- | warm up the register, and the setup-warmup :: Int -> IO Double-warmup n = do- ts <- replicateM n tick_- pure $ average (fromIntegral <$> ts)- where- average cs = L.fold ((/) <$> L.sum <*> L.genericLength) cs---- | helpers-force :: (NFData a) => a -> a-force x = x `deepseq` x--replicateM' :: Monad m- => Int -> m a -> m [a]-replicateM' n op' = go n []- where- go 0 acc = return $ reverse acc- go n' acc = do- x <- op'- go (n' - 1) (x : acc)
src/Perf/Measure.hs view
@@ -1,55 +1,82 @@-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Specification of a performance measurement type suitable for the 'PerfT' monad transformer. module Perf.Measure- where--import Protolude+ ( Measure(..)+ , runMeasure+ , runMeasureN+ , cost+ , cputime+ , realtime+ , count+ , cycles+ ) where import Data.Time.Clock+import NumHask.Prelude+import Perf.Cycle as C+import qualified Protolude as P import System.CPUTime-import Perf.Cycles as C import System.CPUTime.Rdtsc -data Measure m b = forall a. (Monoid b) => Measure- { measure :: b- , prestep :: m a- , poststep :: a -> m b- }+-- | A Measure consists of a monadic effect prior to measuring, a monadic effect to finalise the measurement, and the value measured+--+-- For example, the measure specified below will return 1 every time measurement is requested, thus forming the base of a simple counter for loopy code.+--+-- >>> let count = Measure 0 (pure ()) (pure 1)+data Measure m b = forall a. (Additive b) => Measure+ { measure :: b+ , prestep :: m a+ , poststep :: a -> m b+ } +-- | Measure a single effect.+--+-- >>> r <- runMeasure count (pure "joy")+-- >>> r+-- (1,"joy")+-- runMeasure :: (MonadIO 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')+ 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 :: (MonadIO 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')+ 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 :: (MonadIO m) => Measure m b -> m b cost (Measure _ pre post) = do p <- pre post p --- instances-instance Monoid Integer where- mempty = 0- mappend = (+)-+-- | 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@@ -58,31 +85,59 @@ t <- getCPUTime return $ t - a -instance Monoid NominalDiffTime where- mempty = 0- mappend = (+)+instance AdditiveMagma NominalDiffTime where+ plus = (P.+) +instance AdditiveUnital NominalDiffTime where+ zero = 0++instance AdditiveAssociative NominalDiffTime++instance AdditiveCommutative NominalDiffTime++instance Additive NominalDiffTime++instance AdditiveInvertible NominalDiffTime where+ negate = P.negate++instance AdditiveGroup NominalDiffTime++-- | a measure using 'getCurrentTime' (unit is 'NominalDiffTime' which prints as seconds)+--+-- >>> r <- runMeasure realtime (pure $ foldl' (+) 0 [0..1000])+--+-- > (0.000046s,500500)+-- realtime :: Measure IO NominalDiffTime realtime = Measure m0 start stop where- m0 = fromInteger (0::Integer) :: NominalDiffTime+ m0 = zero :: NominalDiffTime start = getCurrentTime stop a = do t <- getCurrentTime return $ diffUTCTime t a -instance Monoid Int where- mempty = 0- mappend = (+)-+-- | 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+ m0 = 0 :: Int start = return () stop () = return 1 -cycles :: Measure IO Cycles+-- | a Measure using the 'rdtsc' chip set (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@@ -90,5 +145,3 @@ stop a = do t <- rdtsc return $ t - a--
+ test/test.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wall #-}++module Main where++import Protolude+import Test.DocTest++main :: IO ()+main = do+ putStrLn ("Perf.Cycle DocTest" :: Text)+ doctest ["src/Perf/Cycle.hs"]+ putStrLn ("Perf.Measure DocTest" :: Text)+ doctest ["src/Perf/Measure.hs"]+ putStrLn ("Perf DocTest" :: Text)+ doctest ["src/Perf.hs"]