diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Tony Day (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Tony Day nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/examples.lhs b/examples/examples.lhs
new file mode 100644
--- /dev/null
+++ b/examples/examples.lhs
@@ -0,0 +1,327 @@
+
+
+
+
+[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)
diff --git a/perf.cabal b/perf.cabal
new file mode 100644
--- /dev/null
+++ b/perf.cabal
@@ -0,0 +1,144 @@
+name: perf
+version: 0.1.1
+synopsis:
+ low-level performance statistics
+description:
+ .
+ See <> for example results and write-up.
+ .
+category:
+ project
+homepage:
+ https://github.com/tonyday567/perf
+license:
+ BSD3
+license-file:
+ LICENSE
+author:
+ Tony Day
+maintainer:
+ tonyday567@gmail.com
+copyright:
+ Tony Day
+build-type:
+ Simple
+cabal-version:
+ >=1.14
+
+library
+ default-language:
+ Haskell2010
+ ghc-options:
+ hs-source-dirs:
+ src
+ exposed-modules:
+ Perf,
+ Perf.Measure,
+ Perf.Cycles
+ build-depends:
+ base >= 4.7 && < 5,
+ rdtsc,
+ foldl,
+ protolude,
+ tdigest,
+ containers,
+ time
+ default-extensions:
+ NoImplicitPrelude,
+ 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
+
+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
+ build-depends:
+ base >= 4.7 && < 5,
+ protolude,
+ perf,
+ optparse-generic,
+ formatting,
+ foldl,
+ text,
+ vector,
+ tdigest,
+ chart-unit,
+ mwc-probability
+ default-extensions:
+ NoImplicitPrelude,
+ 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
+
+source-repository head
+ type:
+ git
+ location:
+ https://github.com/tonyday567/perf
diff --git a/src/Perf.hs b/src/Perf.hs
new file mode 100644
--- /dev/null
+++ b/src/Perf.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Perf
+ (
+ -- * The Perf Monad
+ PerfT
+ , Perf
+ , perf
+ , perfN
+ , runPerfT
+ , evalPerfT
+ , execPerfT
+ , module Perf.Cycles
+ , module Perf.Measure
+ )
+ where
+
+import Protolude
+import Perf.Measure
+import Perf.Cycles
+import qualified Data.Map as Map
+
+newtype PerfT m b a =
+ PerfT { runPerf_ :: StateT (Map.Map Text b) m a }
+ deriving
+ ( Functor
+ , Applicative
+ , Monad
+ )
+
+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'
+
+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'
+
+runPerfT :: PerfT m b a -> m (a, Map.Map Text b)
+runPerfT p =
+ flip runStateT Map.empty $ runPerf_ p
+
+evalPerfT :: (Monad m) => PerfT m b a -> m a
+evalPerfT p =
+ flip evalStateT Map.empty $ runPerf_ p
+
+execPerfT :: (Monad m) => PerfT m b a -> m (Map.Map Text b)
+execPerfT p =
+ flip execStateT Map.empty $ runPerf_ p
diff --git a/src/Perf/Cycles.hs b/src/Perf/Cycles.hs
new file mode 100644
--- /dev/null
+++ b/src/Perf/Cycles.hs
@@ -0,0 +1,129 @@
+{-# 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)
diff --git a/src/Perf/Measure.hs b/src/Perf/Measure.hs
new file mode 100644
--- /dev/null
+++ b/src/Perf/Measure.hs
@@ -0,0 +1,94 @@
+{-# 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 #-}
+
+module Perf.Measure
+ where
+
+import Protolude
+
+import Data.Time.Clock
+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
+ }
+
+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')
+
+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')
+
+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 = (+)
+
+cputime :: Measure IO Integer
+cputime = Measure 0 start stop
+ where
+ start = getCPUTime
+ stop a = do
+ t <- getCPUTime
+ return $ t - a
+
+instance Monoid NominalDiffTime where
+ mempty = 0
+ mappend = (+)
+
+realtime :: Measure IO NominalDiffTime
+realtime = Measure m0 start stop
+ where
+ m0 = fromInteger (0::Integer) :: NominalDiffTime
+ start = getCurrentTime
+ stop a = do
+ t <- getCurrentTime
+ return $ diffUTCTime t a
+
+instance Monoid Int where
+ mempty = 0
+ mappend = (+)
+
+count :: Measure IO Int
+count = Measure m0 start stop
+ where
+ m0 = 0::Int
+ start = return ()
+ stop () = return 1
+
+cycles :: Measure IO Cycles
+cycles = Measure m0 start stop
+ where
+ m0 = 0
+ start = rdtsc
+ stop a = do
+ t <- rdtsc
+ return $ t - a
+
+