diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011, Google, Inc. +Copyright (c) 2011-2012, Google, Inc. All rights reserved. diff --git a/benchmark/LICENSE b/benchmark/LICENSE new file mode 100644 --- /dev/null +++ b/benchmark/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2011-2012, Google, Inc. + +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 Google, Inc. 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/benchmark/hashtable-benchmark.cabal b/benchmark/hashtable-benchmark.cabal new file mode 100644 --- /dev/null +++ b/benchmark/hashtable-benchmark.cabal @@ -0,0 +1,46 @@ +Name: hashtable-benchmark +Version: 0.1 +Synopsis: Benchmarks for hashtables +License: BSD3 +License-file: LICENSE +Author: Gregory Collins +Maintainer: greg@gregorycollins.net +Category: Data +Build-type: Simple +Cabal-version: >=1.2 + +Flag chart + Default: False + +Executable hashtable-benchmark + main-is: Main.hs + hs-source-dirs: src ../src + + build-depends: base == 4.*, + base16-bytestring == 0.1.*, + bytestring == 0.9.*, + containers == 0.4.*, + criterion >= 0.5 && <0.7, + csv == 0.1.*, + deepseq >= 1.1 && <1.4, + filepath == 1.*, + hashable >= 1.1 && <2, + hashtables >= 1.0.1.3 && <1.1, + mtl == 2.*, + mwc-random >= 0.8 && <0.13, + primitive, + statistics >= 0.8 && <0.11, + threads >= 0.4 && <0.6, + unordered-containers >= 0.2 && <0.3, + vector >= 0.7 && <0.10, + vector-algorithms >= 0.5 && <0.6 + + if flag(chart) + Build-depends: Chart == 0.14.*, + colour == 2.3.*, + data-accessor == 0.2.* + Cpp-options: -DCHART + + ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind -rtsopts + -with-rtsopts="-A4M -H2G" diff --git a/benchmark/src/Criterion/Collection/Chart.hs b/benchmark/src/Criterion/Collection/Chart.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Criterion/Collection/Chart.hs @@ -0,0 +1,101 @@ +module Criterion.Collection.Chart + ( errBarChart + , defaultColors + ) where + + +import Criterion.Measurement +import Data.Accessor +import Data.Colour +import Data.Colour.Names +import Graphics.Rendering.Chart hiding (Vector) + +import Criterion.Collection.Sample + + +defaultColors :: [AlphaColour Double] +defaultColors = cycle $ map opaque [ + blue, + red, + brown, + black, + darkgoldenrod, + coral, + cyan, + darkcyan, + darkkhaki, + darkmagenta, + darkslategrey + ] + + +plotErrBars :: String + -> CairoLineStyle + -> [SampleData] + -> Plot Double Double +plotErrBars name lineStyle samples = toPlot plot + where + value sd = symErrPoint size m 0 s + where + size = fromIntegral $ sdInputSize sd + (m,s) = computeMeanAndStddev sd + + plot = plot_errbars_values ^= map value samples + $ plot_errbars_line_style ^= lineStyle + $ plot_errbars_title ^= name + $ defaultPlotErrBars + + +plotPoints :: String + -> CairoPointStyle + -> [SampleData] + -> Plot Double Double +plotPoints name pointStyle samples = toPlot plot + where + value sd = (fromIntegral size, m) + where + size = sdInputSize sd + (m,_) = computeMeanAndStddev sd + + plot = plot_points_values ^= map value samples + $ plot_points_style ^= pointStyle + $ plot_points_title ^= name + $ defaultPlotPoints + + +errBarChart :: Bool + -> Double + -> String + -> [(AlphaColour Double, String, [SampleData])] + -> Renderable () +errBarChart logPlot lineWidth plotTitle plotData = toRenderable layout + where + mkPlot (colour, plotName, samples) = joinPlot eb pts + where + lStyle = line_width ^= lineWidth + $ line_color ^= colour + $ defaultPlotErrBars ^. plot_errbars_line_style + + pStyle = filledCircles (1.5 * lineWidth) colour + + eb = plotErrBars plotName lStyle samples + pts = plotPoints plotName pStyle samples + + remapLabels = axis_labels ^: f + where + f labels = map (map g) labels + g (x,_) = (x, secs x) + + axisfn = if logPlot + then autoScaledLogAxis defaultLogAxis + else autoScaledAxis defaultLinearAxis + + layout = layout1_title ^= plotTitle + $ layout1_background ^= solidFillStyle (opaque white) + $ layout1_left_axis ^: laxis_generate ^= axisfn + $ layout1_left_axis ^: laxis_override ^= remapLabels + $ layout1_left_axis ^: laxis_title ^= "Time (seconds)" + $ layout1_bottom_axis ^: laxis_generate ^= axisfn + $ layout1_bottom_axis ^: laxis_title ^= "# of items in collection" + $ layout1_plots ^= (map (Left . mkPlot) plotData) + $ defaultLayout1 diff --git a/benchmark/src/Criterion/Collection/Internal/Types.hs b/benchmark/src/Criterion/Collection/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Criterion/Collection/Internal/Types.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Criterion.Collection.Internal.Types + ( Workload(..) + , WorkloadGenerator + , WorkloadMonad(..) + , runWorkloadMonad + , getRNG + , DataStructure(..) + , setupData + , setupDataIO + ) where + +------------------------------------------------------------------------------ +import Control.DeepSeq +import Control.Monad.Reader +import Data.Vector (Vector) +import System.Random.MWC + +------------------------------------------------------------------------------ +-- Some thoughts on benchmarking modes +-- +-- * pre-fill data structure, test an operation workload without modifying the +-- data structure, measure time for each operation +-- +-- ---> allows you to get fine-grained per-operation times with distributions +-- +-- * pre-fill data structure, get a bunch of work to do (cumulatively modifying +-- the data structure), measure time per-operation OR for the whole batch and +-- divide out +-- +-- +-- Maybe it will look like this? +-- > data MeasurementMode = PerBatch | PerOperation +-- > data WorkloadMode = Pure | Mutating + +------------------------------------------------------------------------------ +newtype WorkloadMonad a = WM (ReaderT GenIO IO a) + deriving (Monad, MonadIO) + + +------------------------------------------------------------------------------ +runWorkloadMonad :: WorkloadMonad a -> GenIO -> IO a +runWorkloadMonad (WM m) gen = runReaderT m gen + + +------------------------------------------------------------------------------ +getRNG :: WorkloadMonad GenIO +getRNG = WM ask + + +------------------------------------------------------------------------------ +-- | Given an 'Int' representing \"input size\", a 'WorkloadGenerator' makes a +-- 'Workload'. @Workload@s generate operations to prepopulate data structures +-- with /O(n)/ data items, then generate operations on-demand to benchmark your +-- data structure according to some interesting distribution. +type WorkloadGenerator op = Int -> WorkloadMonad (Workload op) + + +------------------------------------------------------------------------------ +data (NFData op) => Workload op = Workload { + -- | \"Setup work\" is work that you do to prepopulate a data structure + -- to a certain size before testing begins. + setupWork :: !(Vector op) + + -- | Given the number of operations to produce, 'genWorkload' spits out a + -- randomly-distributed workload simulation to be used in the benchmark. + -- + -- | Some kinds of skewed workload distributions (the canonical example + -- being \"frequent lookups for a small set of keys and infrequent + -- lookups for the others\") need a certain minimum number of operations + -- to be generated to be statistically valid, which only the + -- 'WorkloadGenerator' would know how to decide. In these cases, you are + -- free to return more than @N@ samples from 'genWorkload', and + -- @criterion-collection@ will run them all for you. + -- + -- Otherwise, @criterion-collection@ is free to bootstrap your benchmark + -- using as many sample points as it would take to make the results + -- statistically relevant. + , genWorkload :: !(Int -> WorkloadMonad (Vector op)) +} + + +------------------------------------------------------------------------------ +data DataStructure op = forall m . DataStructure { + emptyData :: !(Int -> IO m) + , runOperation :: !(m -> op -> IO m) +} + + +------------------------------------------------------------------------------ +setupData :: m -> (m -> op -> m) -> DataStructure op +setupData e r = DataStructure (const $ return e) (\m o -> return $ r m o) + + +------------------------------------------------------------------------------ +setupDataIO :: (Int -> IO m) -> (m -> op -> IO m) -> DataStructure op +setupDataIO = DataStructure diff --git a/benchmark/src/Criterion/Collection/Main.hs b/benchmark/src/Criterion/Collection/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Criterion/Collection/Main.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE CPP #-} + +module Criterion.Collection.Main + ( CriterionCollectionConfig + , defaultCriterionCollectionConfig + , runBenchmark + ) where + +import Control.DeepSeq +import Control.Monad.Trans +import Criterion.Collection.Sample +import Criterion.Config +import Criterion.Environment +import Criterion.Measurement (secs) +import Criterion.Monad +import Data.List +import System.IO +import System.Random.MWC (GenIO) +import qualified System.Random.MWC as R +import Text.CSV + +#ifdef CHART +import Criterion.Collection.Chart +#endif + + +data CriterionCollectionConfig = Cfg { + _criterionConfig :: Config + , _logPlot :: Bool + -- todo: more here +} + + +defaultCriterionCollectionConfig :: CriterionCollectionConfig +defaultCriterionCollectionConfig = Cfg defaultConfig False + + +-- Fixme: fold chart output into config and generalize to other post-processing +-- functions (like alternative chart types and CSV output) +runBenchmark :: (NFData op) + => MeasurementMode + -> WorkloadMode + -> Benchmark op + -> CriterionCollectionConfig + -> Maybe FilePath + -> IO () +runBenchmark mMode wMode benchmark (Cfg cfg logPlot) fp = withConfig cfg $ do + rng <- liftIO $ R.withSystemRandom (\r -> return r :: IO GenIO) + env <- measureEnvironment + plotData <- takeSamples mMode wMode benchmark env rng + + liftIO $ mkChart logPlot (benchmarkName benchmark) fp plotData + liftIO $ mkCSV (benchmarkName benchmark) fp plotData + + +------------------------------------------------------------------------------ +mkCSV :: String + -> Maybe FilePath + -> [(String, [SampleData])] + -> IO () +mkCSV chartTitle output plotData = do + h <- maybe (return stdout) + (\f -> openFile (f ++ ".csv") WriteMode) + output + + hPutStr h $ printCSV allRows + maybe (return ()) + (\_ -> hClose h) + output + + where + + header = [ "Data Structure" + , "Input Size" + , "Mean (secs)" + , "Stddev (secs)" + , "95% (secs)" + , "Max (secs)" ] + + allRows = header : sampleRows + sampleRows = concatMap samplesToRows plotData + + samplesToRows (name, sds) = map (sampleToRow name) sds + + sampleToRow name sd = + [ name + , show inputSize + , show mean + , show stddev + , show ninetyFifth + , show maxVal ] + where + (mean, stddev) = computeMeanAndStddev sd + ninetyFifth = compute95thPercentile sd + maxVal = computeMax sd + inputSize = sdInputSize sd + + +------------------------------------------------------------------------------ +mkChart :: Bool + -> String + -> Maybe FilePath + -> [(String, [SampleData])] + -> IO () +#ifdef CHART +mkChart logPlot chartTitle output plotData' = do + go output + printChartResults chartTitle plotData' + + where + plotData = map (\(a,(b,c)) -> (a,b,c)) (defaultColors `zip` plotData') + + go Nothing = do + let chart = errBarChart logPlot 2.5 chartTitle plotData + _ <- renderableToWindow chart 1024 768 + return () + + go (Just fn) = do + let chart = errBarChart logPlot 1.5 chartTitle plotData + _ <- renderableToPNGFile chart 800 600 fn + return () + + +#else +-- FIXME +mkChart _ chartTitle _ plotData = printChartResults chartTitle plotData +#endif + + +------------------------------------------------------------------------------ +printChartResults :: String + -> [(String, [SampleData])] + -> IO () +printChartResults chartTitle plotData = do + -- fixme + putStrLn $ "Results for " ++ chartTitle + dashes + crlf + mapM_ printOne plotData + where + dashes = putStrLn $ replicate 78 '-' + crlf = putStrLn "" + + fieldSize = 14 + + rpad s = if n > fieldSize + then (take (fieldSize-2) s) ++ ".." + else replicate nsp ' ' ++ s + where + n = length s + nsp = fieldSize-n + + lpad s = if n > fieldSize + then (take (fieldSize-2) s) ++ ".." + else s ++ replicate nsp ' ' + where + n = length s + nsp = fieldSize-n + + printHeader = do + putStrLn $ concat [ lpad "Input Sz", " " + , lpad "Mean (secs)", " " + , lpad "Stddev (secs)", " " + , lpad "95% (secs)", " " + , lpad "Max (secs)"] + putStrLn $ concat [ replicate fieldSize '-', " " + , replicate fieldSize '-', " " + , replicate fieldSize '-', " " + , replicate fieldSize '-', " " + , replicate fieldSize '-' ] + + printOne (name, sampledata) = do + putStrLn $ "Data structure " ++ name + crlf + printHeader + mapM_ printSample sampledata + crlf + + printSample sd = do + --putStrLn $ "fixme: sample length is " ++ show sd + let (mean,stddev) = computeMeanAndStddev sd + let ninetyFifth = compute95thPercentile sd + let maxVal = computeMax sd + let inputSize = sdInputSize sd + + let f1 = rpad $ show inputSize + let f2 = rpad $ secs mean + let f3 = rpad $ secs stddev + let f4 = rpad $ secs ninetyFifth + let f5 = rpad $ secs maxVal + + putStrLn $ intercalate " " [f1, f2, f3, f4, f5] + diff --git a/benchmark/src/Criterion/Collection/Sample.hs b/benchmark/src/Criterion/Collection/Sample.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Criterion/Collection/Sample.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} + +module Criterion.Collection.Sample + ( Benchmark(..) + , SampleData(..) + , MeasurementMode(..) + , WorkloadMode(..) + , computeMeanAndStddev + , compute95thPercentile + , computeMax + , takeSample + , takeSamples + ) where + +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans +import Criterion hiding (Benchmark) +import Criterion.Config +import Criterion.Environment +import Criterion.IO +import Criterion.Measurement +import Criterion.Monad +import Criterion.Collection.Internal.Types +import Data.IORef +import Data.List (foldl') +import Data.Monoid +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Statistics.Quantile (continuousBy, cadpw) +import Statistics.Sample +import System.Mem (performGC) +import System.Random.MWC +import Text.Printf (printf) + +------------------------------------------------------------------------------ +data MeasurementMode = PerBatch | PerOperation +data WorkloadMode = Pure | Mutating + + +------------------------------------------------------------------------------ +data SampleData = SampleData { + sdInputSize :: !Int -- ^ what was the size of the input for this + -- sample? + , sdNumOps :: !Int -- ^ how many operations are covered by this + -- sample? For a per-operation measurement, + -- this value would be \"1\", and for a batch + -- measurement this value would be the number + -- of items in the batch. + , sdData :: !Sample -- ^ sample data. + } + + +instance Show SampleData where + show (SampleData is nop da) = "" + +------------------------------------------------------------------------------ +data (NFData op) => Benchmark op = Benchmark { + benchmarkName :: String + , dataStructures :: [(String, DataStructure op)] + , inputSizes :: [Int] + , workloadGenerator :: WorkloadGenerator op +} + + +------------------------------------------------------------------------------ +-- | Given some sample data, compute the mean time per operation (in seconds) +-- and standard deviation +computeMeanAndStddev :: SampleData -> (Double, Double) +computeMeanAndStddev (SampleData _ nops sample) = (v,s) + where + nopsReal = fromIntegral nops + (meanValue, var) = meanVarianceUnb sample + stddev = sqrt $ abs var + !v = meanValue / nopsReal + !s = stddev / nopsReal + + +------------------------------------------------------------------------------ +-- | Given some sample data, compute the 95th percentile. +compute95thPercentile :: SampleData -> Double +compute95thPercentile (SampleData _ nops sample) = v + where + nopsReal = fromIntegral nops + quantile = continuousBy cadpw 19 20 sample + v = quantile / nopsReal + + +------------------------------------------------------------------------------ +-- | Given some sample data, compute the maximum value +computeMax :: SampleData -> Double +computeMax (SampleData _ nops sample) = v + where + nopsReal = fromIntegral nops + maxval = U.foldl' max 0 sample + v = maxval / nopsReal + + +------------------------------------------------------------------------------ +takeSample :: (NFData op) => + MeasurementMode + -> WorkloadMode + -> Benchmark op + -> Environment + -> GenIO + -> Int + -> Criterion [SampleData] +takeSample !mMode !wMode !benchmark !env !rng !inputSize = do + workload <- liftIO $ runWorkloadMonad (workGen inputSize) rng + let setupOperations = setupWork workload + let genWorkData = genWorkload workload + + case mMode of + PerBatch -> batch setupOperations genWorkData + PerOperation -> perOp setupOperations genWorkData + + + where + -------------------------------------------------------------------------- + dss = dataStructures benchmark + workGen = workloadGenerator benchmark + + -------------------------------------------------------------------------- + batch setupOperations genWorkData = do + workData <- liftIO $ runWorkloadMonad (genWorkData $ inputSize `div` 2) + rng + let nOps = V.length workData + mapM (batchOne setupOperations workData nOps) dss + + + -------------------------------------------------------------------------- + mkRunOp runOpMutating = + let runOpPure = \m op -> do + m' <- runOpMutating m op + return $! m' `seq` m + in case wMode of + Pure -> runOpPure + Mutating -> runOpMutating + + + -------------------------------------------------------------------------- + runWorkData workData chunkSize runOp start i val = go i val + where + go !i !val + | i >= chunkSize = return val + | otherwise = do + let op = V.unsafeIndex workData (start+i) + !val' <- runOp val op + go (i+1) val' + + + -------------------------------------------------------------------------- + batchOne setupOperations workData nOps + (name, (DataStructure emptyValue runOpMutating)) = do + note $ "running batch benchmark on " ++ name ++ "\n" + let minTime = envClockResolution env * 1000 + cfg <- getConfig + let proc = V.foldM' runOpMutating + let mkStartValue = emptyValue inputSize >>= flip proc setupOperations + startValue1 <- liftIO mkStartValue + + liftIO performGC + let tProc = runWorkData workData nOps runOpMutating 0 0 + + prolix $ "running test batch with " ++ show nOps + ++ " work items\n" + + (tm,_) <- liftIO $ time (tProc startValue1) + + prolix $ "running initial timing on " ++ show nOps + ++ " work items\n" + + let iters = max 5 (ceiling (minTime / tm)) + + prolix $ "running benchmark on " ++ show nOps + ++ " work items, " ++ show iters ++ " iterations\n" + + sample <- liftIO $ U.generateM iters $ \_ -> do + sv <- mkStartValue + performGC + (!tm,_) <- time (tProc sv) + return $ tm - clockCost + + prolix $ "finished batch benchmark on " ++ name ++ "\n" + return (SampleData inputSize nOps sample) + + + -------------------------------------------------------------------------- + perOp setupOperations genWorkData = do + -- FIXME: lifted this code from criterion, is there some way to merge + -- them? + _ <- prolix "generating seed workload" + seedData <- liftIO $ runWorkloadMonad (genWorkData 1000) rng + _ <- prolix "seed workload generated" + + workData <- liftIO $ runWorkloadMonad (genWorkData inputSize) rng + mapM (perOpOne setupOperations workData seedData) dss + + + -------------------------------------------------------------------------- + perOpOne setupOperations workData seedData + (name, (DataStructure emptyValue runOpMutating)) = do + let runOp = mkRunOp runOpMutating + let proc = V.foldM' runOpMutating + + note $ "running per-op benchmark on " ++ name ++ "\n" + + startValue <- liftIO (emptyValue inputSize >>= + flip proc setupOperations) + liftIO performGC + + -- warm up clock + _ <- liftIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime) + let minTime = envClockResolution env * 1000 + + (testTime, testIters, startValue') <- + liftIO $ timeSeed (min minTime 0.1) seedData runOp startValue + _ <- note "ran %d iterations in %s\n" testIters (secs testTime) + cfg <- getConfig + + let testItersD = fromIntegral testIters + let sampleCount = fromLJ cfgSamples cfg + let timePer = (testTime - testItersD * clockCost) / testItersD + let chunkSizeD = minTime / timePer + let chunkSize = min (V.length workData) (ceiling chunkSizeD) + let nSamples1 = min (chunkSize * sampleCount) (V.length workData) + let numItersD = fromIntegral nSamples1 / fromIntegral chunkSize + let nSamples = max 1 (floor numItersD * chunkSize) + + _ <- note "collecting %d samples (in chunks of %d) in estimated %s\n" + nSamples chunkSize + (secs ((chunkSizeD * timePer + clockCost)*numItersD)) + + + (sample,_) <- mkSample chunkSize nSamples workData startValue' runOp + liftIO performGC + return (SampleData inputSize chunkSize sample) + + + -------------------------------------------------------------------------- + mkSample chunkSize nSamples workData startValue runOp = liftIO $ do + valRef <- newIORef startValue + + let numItersD = fromIntegral nSamples / fromIntegral chunkSize + -- make sure nSamples is an integral multiple of chunkSize + let numIters = max 1 (floor (numItersD :: Double)) + + sample <- U.generateM numIters $ \chunk -> do + !val <- readIORef valRef + (!tm, val') <- time (runWorkData workData chunkSize runOp + (chunk*chunkSize) 0 val) + writeIORef valRef val' + return $ tm - clockCost + + val <- readIORef valRef + return (sample :: U.Vector Double, val) + + -------------------------------------------------------------------------- + clockCost = envClockCost env + + -------------------------------------------------------------------------- + timeSeed howLong seedData runOp startValue = + loop startValue seedData (0::Int) =<< getTime + where + loop sv seed iters initTime = do + now <- getTime + let n = V.length seed + when (now - initTime > howLong * 10) $ + fail (printf "took too long to run: seed %d, iters %d" + (V.length seed) iters) + (elapsed, (_,sv')) <- time (mkSample 1 n seed sv runOp) + + if elapsed < howLong + then loop sv' (seed `mappend` seed) (iters+1) initTime + else return (elapsed, n, sv') + + +------------------------------------------------------------------------------ +takeSamples :: (NFData op) => + MeasurementMode + -> WorkloadMode + -> Benchmark op + -> Environment + -> GenIO + -> Criterion [(String, [SampleData])] +takeSamples !mMode !wMode !benchmark !env !rng = do + let szs = inputSizes benchmark + when (null szs) $ fail "No input sizes defined" + + ssamples <- mapM (takeSample mMode wMode benchmark env rng) szs + let names = map fst $ dataStructures benchmark + let inputs = foldl' combine (map (const []) names) (reverse ssamples) + + return $ names `zip` inputs + + where + combine :: [[SampleData]] -> [SampleData] -> [[SampleData]] + combine int samples = map (uncurry (flip (:))) (int `zip` samples) diff --git a/benchmark/src/Criterion/Collection/Types.hs b/benchmark/src/Criterion/Collection/Types.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Criterion/Collection/Types.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | The criterion collection is a set of utilities for benchmarking data +-- structures using criterion +-- (). +-- +-- The criterion collection allows you to test the /per-operation/ asymptotic +-- performance of your data structures under a variety of simulated +-- workloads. For testing a hash table, for example, you might be interested +-- in: +-- +-- * how lookup and insert performance changes as the number of elements in +-- your hash table grows +-- +-- * how lookup performance changes depending on the distribution of the +-- lookup keys; you might expect a heavily skewed lookup distribution, where +-- most of the requests are for a small subset of the keys, to have +-- different performance characteristics than a set of lookups for keys +-- uniformly distributed in the keyspace. +-- +-- * how the hashtable performs under a mixed workload of inserts, deletes, +-- and lookups. +-- +-- Whereas "Criterion" allows you to run a single benchmark a number of times +-- to see how fast it runs, @criterion-collection@ makes performance-testing +-- data structures easier by decoupling benchmarking from workload generation, +-- allowing you to see in-depth how performance changes as the input size +-- varies. +-- +-- To test your data structure using @criterion-collection@, you provide the +-- following: +-- +-- 1. A datatype which models the set of data structure operations you're +-- interested in testing. For instance, for our hashtable example, your +-- datatype might look like: +-- +-- > data Operation k = +-- > -- | Insert a k-v pair into the collection. If k existed, we +-- > -- should update the mapping. +-- > Insert {-# UNPACK #-} !k +-- > {-# UNPACK #-} !Int +-- > -- | Lookup a key in the mapping. +-- > | Lookup {-# UNPACK #-} !k +-- > -- | Delete a key from the mapping. +-- > | Delete {-# UNPACK #-} !k +-- > deriving (Show) +-- > +-- > +-- > instance (NFData k) => NFData (Operation k) where +-- > rnf (Insert k v) = rnf k `seq` rnf v +-- > rnf (Lookup k) = rnf k +-- > rnf (Delete k) = rnf k +-- +-- 2. A function which, given an operation, runs it on your datastructure. +-- +-- 3. A \"ground state\" for your datastructure, usually \"empty\". You can +-- test both pure data structures and data structures in 'IO'. +-- +-- 4. One or more \"workload simulators\" which, given a random number +-- generator and an input size, give you back some functions to generate +-- workloads: +-- +-- a) to prepopulate the data structure prior to the test +-- +-- b) to test the data structure with. +-- +-- (Side note: the reason @criterion-collection@ asks you to reify the +-- operation type instead of just generating a list of mutation functions of +-- type @[m -> m]@ is so you can test multiple datastructures under the same +-- workload.) + + +module Criterion.Collection.Types + ( Workload(..) + , WorkloadGenerator + , WorkloadMonad + , runWorkloadMonad + , getRNG + , DataStructure + , emptyData + , runOperation + , setupData + , setupDataIO + ) where + +------------------------------------------------------------------------------ +import Criterion.Collection.Internal.Types diff --git a/benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs b/benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.Benchmarks.UnorderedCollections.Distributions + ( makeRandomData + , makeRandomVariateData + -- * Workloads + , insertWorkload + , deleteWorkload + , uniformLookupWorkload + , exponentialLookupWorkload + + , loadOnly + , loadAndUniformLookup + , loadAndSkewedLookup + , loadAndDeleteAll + , loadAndDeleteSome + , uniformlyMixed + ) where + + +import qualified Control.Concurrent.Thread as Th +import Control.DeepSeq +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans (liftIO) +import Data.Benchmarks.UnorderedCollections.Types +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as VU +import Data.Vector (Vector) +import qualified Data.Vector.Algorithms.Shuffle as V +import GHC.Conc (numCapabilities) +import Statistics.Distribution +import Statistics.Distribution.Exponential +import System.Random.MWC + +import Criterion.Collection.Types + + +------------------------------------------------------------------------------ +debug :: (MonadIO m) => String -> m () +debug s = liftIO $ putStrLn s + + +------------------------------------------------------------------------------ +makeRandomData :: (NFData k) => + (GenIO -> IO k) + -> Int + -> WorkloadMonad (Vector (k,Int)) +makeRandomData !genFunc !n = do + rng <- getRNG + debug $ "making " ++ show n ++ " data items" + keys <- liftIO $ vreplicateM n rng genFunc + let !v = keys `V.zip` vals + let !_ = forceVector v + debug $ "made " ++ show n ++ " data items" + return $! v + + where + vals = V.enumFromN 0 n + + +------------------------------------------------------------------------------ +makeRandomVariateData :: (Ord k, NFData k, Variate k) => + Int + -> WorkloadMonad (Vector (k,Int)) +makeRandomVariateData = makeRandomData uniform + + +------------------------------------------------------------------------------ +insertWorkload :: (NFData k) => Vector (k,Int) -> Vector (Operation k) +insertWorkload = mapForce $ \(k,v) -> Insert k v + + +------------------------------------------------------------------------------ +deleteWorkload :: (NFData k) => Vector (k,Int) -> Vector (Operation k) +deleteWorkload = mapForce $ \(k,_) -> Delete k + + +------------------------------------------------------------------------------ +uniformLookupWorkload :: (NFData k) => + Vector (k,Int) + -> Int + -> WorkloadMonad (Vector (Operation k)) +uniformLookupWorkload !vec !ntimes = do + rng <- getRNG + debug $ "uniformLookupWorkload: generating " ++ show ntimes ++ " lookups" + v <- liftIO $ vreplicateM ntimes rng f + debug $ "uniformLookupWorkload: done" + return v + + where + !n = V.length vec + f r = do + idx <- pick + let (k,_) = V.unsafeIndex vec idx + return $ Lookup k + where + pick = uniformR (0,n-1) r + + +------------------------------------------------------------------------------ +exponentialLookupWorkload :: (NFData k) => + Double + -> Vector (k,Int) + -> Int + -> WorkloadMonad (Vector (Operation k)) +exponentialLookupWorkload !lambda !vec !ntimes = do + rng <- getRNG + liftIO $ vreplicateM ntimes rng f + where + !dist = exponential lambda + !n = V.length vec + !n1 = n-1 + !nd = fromIntegral n + + f r = do + x <- uniformR (0.1, 7.0) r + let idx = max 0 . min n1 . round $ nd * density dist x + let (k,_) = V.unsafeIndex vec idx + return $! Lookup k + + +------------------------------------------------------------------------------ +loadOnly :: (NFData k) => + (GenIO -> IO k) -- ^ rng for keys + -> WorkloadGenerator (Operation k) +loadOnly !genFunc !n = return $ Workload V.empty f + where + f _ = liftM insertWorkload $ makeRandomData genFunc n + + +------------------------------------------------------------------------------ +loadAndUniformLookup :: (NFData k) => + (GenIO -> IO k) -- ^ rng for keys + -> WorkloadGenerator (Operation k) +loadAndUniformLookup !genFunc !n = do + !vals <- makeRandomData genFunc n + let !inserts = insertWorkload vals + + return $! Workload inserts $ uniformLookupWorkload vals + + +------------------------------------------------------------------------------ +loadAndSkewedLookup :: (NFData k) => + (GenIO -> IO k) -- ^ rng for keys + -> WorkloadGenerator (Operation k) +loadAndSkewedLookup !genFunc !n = do + !vals <- makeRandomData genFunc n + let !inserts = insertWorkload vals + return $! Workload inserts $ exponentialLookupWorkload 1.5 vals + + +------------------------------------------------------------------------------ +loadAndDeleteAll :: (NFData k) => + (GenIO -> IO k) -- ^ key generator + -> WorkloadGenerator (Operation k) +loadAndDeleteAll !genFunc !n = do + rng <- getRNG + !vals <- makeRandomData genFunc n + let !inserts = insertWorkload vals + let !deletes = deleteWorkload $ V.shuffle rng vals + + return $ Workload inserts (const $ return deletes) + + +------------------------------------------------------------------------------ +loadAndDeleteSome :: (NFData k) => + (GenIO -> IO k) + -> WorkloadGenerator (Operation k) +loadAndDeleteSome !genFunc !n = do + !vals <- makeRandomData genFunc n + let !inserts = insertWorkload vals + + return $ Workload inserts $ f vals + + where + f vals k = do + rng <- getRNG + return $ deleteWorkload $ V.take k $ V.shuffle rng vals + + +------------------------------------------------------------------------------ +uniformlyMixed :: (NFData k) => + (GenIO -> IO k) + -> Double + -> Double + -> WorkloadGenerator (Operation k) +uniformlyMixed !genFunc !lookupPercentage !deletePercentage !n = do + let !numLookups = ceiling (fromIntegral n * lookupPercentage) + let !numDeletes = ceiling (fromIntegral n * deletePercentage) + + !vals <- makeRandomData genFunc n + let !inserts = insertWorkload vals + !lookups <- uniformLookupWorkload vals numLookups + + rng <- getRNG + let !deletes = deleteWorkload $ V.take numDeletes $ V.shuffle rng vals + let !out = V.shuffle rng $ V.concat [inserts, lookups, deletes] + + return $! Workload V.empty $ const $ return $ forceVector out + + +------------------------------------------------------------------------------ +-- utilities +------------------------------------------------------------------------------ +forceVector :: (NFData k) => Vector k -> Vector k +forceVector !vec = V.foldl' force () vec `seq` vec + where + force x v = x `deepseq` v `deepseq` () + + +mapForce :: (NFData b) => (a -> b) -> Vector a -> Vector b +mapForce !f !vIn = let !vOut = V.map f vIn + in forceVector vOut + + +-- split a GenIO +splitGenIO :: GenIO -> IO GenIO +splitGenIO rng = VU.replicateM 256 (uniform rng) >>= initialize + + +-- vector replicateM is slow as dogshit. +vreplicateM :: Int -> GenIO -> (GenIO -> IO a) -> IO (Vector a) +vreplicateM n origRng act = do + rngs <- replicateM numCapabilities (splitGenIO origRng) + mv <- MV.new n + let actions = map (f mv) (parts `zip` rngs) + results <- liftM (map snd) $ mapM Th.forkIO actions + _ <- sequence results + V.unsafeFreeze mv + + where + parts = partition (n-1) numCapabilities + + f mv ((low,high),rng) = do + f' low + where + f' !idx | idx > high = return () + | otherwise = do + x <- act rng + MV.unsafeWrite mv idx x + f' (idx+1) + + +partition :: Int -> Int -> [(Int,Int)] +partition n k = ys `zip` xs + where + xs = map f [1..k] + ys = 0:(map (+1) xs) + f i = (i * n) `div` k diff --git a/benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs b/benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.Benchmarks.UnorderedCollections.Types + ( Operation(..) + ) where + +import Control.DeepSeq + + +------------------------------------------------------------------------------ +data Operation k = + -- | Insert a k-v pair into the collection. If k existed, we should + -- update the mapping. + Insert {-# UNPACK #-} !k + {-# UNPACK #-} !Int + -- | Lookup a key in the mapping. + | Lookup {-# UNPACK #-} !k + -- | Delete a key from the mapping. + | Delete {-# UNPACK #-} !k + deriving (Show) + + +------------------------------------------------------------------------------ +instance (NFData k) => NFData (Operation k) where + rnf (Insert k v) = rnf k `seq` rnf v + rnf (Lookup k) = rnf k + rnf (Delete k) = rnf k diff --git a/benchmark/src/Data/Vector/Algorithms/Shuffle.hs b/benchmark/src/Data/Vector/Algorithms/Shuffle.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Data/Vector/Algorithms/Shuffle.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +module Data.Vector.Algorithms.Shuffle + ( shuffle ) where + +import Control.Monad.ST (unsafeIOToST) +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import System.Random.MWC + + +shuffle :: GenIO -> Vector k -> Vector k +shuffle rng v = V.modify go v + where + !n = V.length v + + go mv = f (n-1) + where + -- note: inclusive + pick b = unsafeIOToST $ uniformR (0,b) rng + + swap = MV.unsafeSwap mv + + f 0 = return () + f !k = do + idx <- pick k + swap k idx + f (k-1) + diff --git a/benchmark/src/Main.hs b/benchmark/src/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/src/Main.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE BangPatterns #-} + +module Main (main) where + +import Data.Bits +import qualified Data.ByteString as B +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as B16 +import Data.Hashable +import Control.DeepSeq +import Control.Monad +import Control.Monad.ST +import qualified Data.HashMap.Strict as UC +import qualified Data.HashTable as H +import qualified Data.Map as Map +import qualified Data.HashTable.IO as IOH +import Data.Benchmarks.UnorderedCollections.Distributions +import Data.Benchmarks.UnorderedCollections.Types +import System.Environment +import System.FilePath +import System.Random.MWC + +import Criterion.Collection.Main +import Criterion.Collection.Sample +import Criterion.Collection.Types + + +------------------------------------------------------------------------------ +dataMap :: DataStructure (Operation ByteString) +dataMap = setupData Map.empty f + where + f !m !op = case op of + (Insert k v) -> let !m' = Map.insert k v m in m' + (Lookup k) -> let !_ = Map.lookup k m in m + (Delete k) -> let !m' = Map.delete k m in m' + + +------------------------------------------------------------------------------ +hashMap :: DataStructure (Operation ByteString) +hashMap = setupData UC.empty f + where + f !m !op = case op of + (Insert k v) -> let !m' = UC.insert k v m in m' + (Lookup k) -> let !_ = UC.lookup k m in m + (Delete k) -> let !m' = UC.delete k m in m' + + +------------------------------------------------------------------------------ +hashTable :: DataStructure (Operation ByteString) +hashTable = setupDataIO (const (H.new (==) (toEnum . (.&. 0x7fffffff) . hash))) f + where + f !m !op = case op of + (Insert k v) -> H.update m k v >> return m + (Lookup k) -> do + !_ <- H.lookup m k + return m + (Delete k) -> do + !_ <- H.delete m k + return m + + +------------------------------------------------------------------------------ +basicHashTable :: DataStructure (Operation ByteString) +basicHashTable = setupDataIO (IOH.newSized :: Int -> IO (IOH.BasicHashTable k v)) + f + where + f !m !op = case op of + (Insert k v) -> IOH.insert m k v >> return m + (Lookup k) -> do + !_ <- IOH.lookup m k + return m + (Delete k) -> IOH.delete m k >> return m + +------------------------------------------------------------------------------ + +cuckooHashTable :: DataStructure (Operation ByteString) +cuckooHashTable = setupDataIO (IOH.newSized :: Int -> IO (IOH.CuckooHashTable k v)) + f + where + f !m !op = case op of + (Insert k v) -> IOH.insert m k v >> return m + (Lookup k) -> do + !_ <- IOH.lookup m k + return m + (Delete k) -> IOH.delete m k >> return m + + +------------------------------------------------------------------------------ +linearHashTable :: DataStructure (Operation ByteString) +linearHashTable = setupDataIO + (IOH.newSized :: Int -> IO (IOH.LinearHashTable k v)) + f + where + f !m !op = case op of + (Insert k v) -> IOH.insert m k v >> return m + (Lookup k) -> do + !_ <- IOH.lookup m k + return m + (Delete k) -> IOH.delete m k >> return m + + +mkByteString :: GenIO -> IO ByteString +mkByteString rng = do + n <- uniformR (4,16) rng + xs <- replicateM n (uniform rng) + let !s = B.pack xs + return $! B16.encode s + + +instance NFData ByteString where + rnf s = rnf $! B.unpack s + + +-- testStructures = [ ("Data.CuckooHashTable" , cuckooHashTable) +-- ] + +-- testStructures = [ ("Data.Map" , dataMap ) +-- , ("Data.Hashtable" , hashTable ) +-- , ("Data.BasicHashTable" , basicHashTable ) +-- , ("Data.LinearHashTable" , linearHashTable) +-- ] + +-- testStructures = [ ("Data.BasicHashTable" , basicHashTable ) +-- ] + +testStructures = [ ("Data.Map" , dataMap ) + , ("Data.Hashtable" , hashTable ) + , ("Data.HashMap" , hashMap ) + , ("Data.BasicHashTable" , basicHashTable ) + , ("Data.LinearHashTable" , linearHashTable) + , ("Data.CuckooHashTable" , cuckooHashTable) + ] + +-- testStructures = [ ("Data.Hashtable" , hashTable ) +-- , ("Data.LinearHashTable" , linearHashTable) +-- ] + + +testSizes = [ 250 + , 500 + , 1000 + , 2000 + , 4000 + , 8000 + , 16000 + , 32000 + , 64000 + , 128000 + , 256000 + , 512000 + , 1024000 + , 2048000 ] + +-- testSizes = [ 1024000 +-- , 2048000 +-- ] + +-- testSizes = [ 256000 +-- , 512000 +-- ] + +------------------------------------------------------------------------------ +lookupBenchmark :: Benchmark (Operation ByteString) +lookupBenchmark = Benchmark "Lookup Performance" + testStructures + testSizes + (loadAndUniformLookup mkByteString) + + +------------------------------------------------------------------------------ +insertBenchmark :: Benchmark (Operation ByteString) +insertBenchmark = Benchmark "Insert Performance" + testStructures + testSizes + (loadOnly mkByteString) + + + +------------------------------------------------------------------------------ +main :: IO () +main = do + args <- getArgs + let fn = case args of [] -> Nothing + (x:_) -> Just (dropExtensions x) + + let cfg = defaultCriterionCollectionConfig + runBenchmark PerBatch Mutating insertBenchmark cfg (fmap (++".insert") fn) + runBenchmark PerBatch Pure lookupBenchmark cfg (fmap (++".lookup") fn) + diff --git a/hashtables.cabal b/hashtables.cabal --- a/hashtables.cabal +++ b/hashtables.cabal @@ -1,5 +1,5 @@ Name: hashtables -Version: 1.0.1.4 +Version: 1.0.1.5 Synopsis: Mutable hash tables in the ST monad Homepage: http://github.com/gregorycollins/hashtables License: BSD3 @@ -107,6 +107,17 @@ Extra-Source-Files: README.md, haddock.sh, + benchmark/hashtable-benchmark.cabal, + benchmark/LICENSE, + benchmark/src/Criterion/Collection/Internal/Types.hs, + benchmark/src/Criterion/Collection/Chart.hs, + benchmark/src/Criterion/Collection/Main.hs, + benchmark/src/Criterion/Collection/Types.hs, + benchmark/src/Criterion/Collection/Sample.hs, + benchmark/src/Main.hs, + benchmark/src/Data/Vector/Algorithms/Shuffle.hs, + benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs, + benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs, test/compute-overhead/ComputeOverhead.hs, test/hashtables-test.cabal, test/runTestsAndCoverage.sh, @@ -158,11 +169,10 @@ Data.HashTable.Internal.Utils, Data.HashTable.Internal.Linear.Bucket - Build-depends: base >= 4 && <5, - hashable >= 1.1 && <2, + Build-depends: base >= 4 && <5, + hashable >= 1.1 && <2, primitive, - vector >= 0.7 - + vector >= 0.7 && < 0.10 if flag(portable) cpp-options: -DNO_C_SEARCH -DPORTABLE