hashtables 1.0.1.4 → 1.0.1.5
raw patch · 13 files changed
+1371/−6 lines, 13 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- LICENSE +1/−1
- benchmark/LICENSE +28/−0
- benchmark/hashtable-benchmark.cabal +46/−0
- benchmark/src/Criterion/Collection/Chart.hs +101/−0
- benchmark/src/Criterion/Collection/Internal/Types.hs +100/−0
- benchmark/src/Criterion/Collection/Main.hs +193/−0
- benchmark/src/Criterion/Collection/Sample.hs +302/−0
- benchmark/src/Criterion/Collection/Types.hs +89/−0
- benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs +251/−0
- benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs +27/−0
- benchmark/src/Data/Vector/Algorithms/Shuffle.hs +29/−0
- benchmark/src/Main.hs +189/−0
- hashtables.cabal +15/−5
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011, Google, Inc.+Copyright (c) 2011-2012, Google, Inc. All rights reserved.
+ benchmark/LICENSE view
@@ -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.
+ benchmark/hashtable-benchmark.cabal view
@@ -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"
+ benchmark/src/Criterion/Collection/Chart.hs view
@@ -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
+ benchmark/src/Criterion/Collection/Internal/Types.hs view
@@ -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
+ benchmark/src/Criterion/Collection/Main.hs view
@@ -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]+
+ benchmark/src/Criterion/Collection/Sample.hs view
@@ -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) = "<SampleData inputSize=" ++ show is+ ++ ", nops=" ++ show nop+ ++ ", sample size=" ++ show (U.length 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)
+ benchmark/src/Criterion/Collection/Types.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | The criterion collection is a set of utilities for benchmarking data+-- structures using criterion+-- (<http://hackage.haskell.org/package/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
+ benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs view
@@ -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
+ benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs view
@@ -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
+ benchmark/src/Data/Vector/Algorithms/Shuffle.hs view
@@ -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)+
+ benchmark/src/Main.hs view
@@ -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)+
hashtables.cabal view
@@ -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