darcs-benchmark 0.1.5.1 → 0.1.6
raw patch · 8 files changed
+360/−103 lines, 8 filesdep +statisticsdep +utf8-stringdep +uvector
Dependencies added: statistics, utf8-string, uvector
Files
- Benchmark.hs +268/−51
- Config.hs +4/−0
- Dist.hs +15/−0
- Shellish.hs +6/−4
- Standard.hs +39/−42
- TabularRST.hs +1/−1
- darcs-benchmark.cabal +5/−2
- main.hs +22/−3
Benchmark.hs view
@@ -2,11 +2,17 @@ import Shellish hiding ( run ) import Control.Applicative+import Control.Arrow ( first, second )+import Data.Array.Vector import Data.Char+import Data.Function ( on ) import Data.List+import Data.Either ( rights ) import Data.Maybe+import Statistics.Sample import System.Directory-import System.FilePath( (</>) )+import System.Environment+import System.FilePath( (</>), (<.>), splitDirectories, joinPath ) import System.IO import qualified Text.Tabular as Tab import TabularRST as TR@@ -22,28 +28,56 @@ import System.Console.CmdArgs (isLoud) import System.Process( runInteractiveProcess, runInteractiveCommand, waitForProcess )+import Data.IORef+import System.IO.Unsafe import Text.JSON+import qualified System.IO.UTF8 as UTF8 -precision, iterations :: Int+precision :: Int precision = 1-iterations = 2-combine :: Ord a => [a] -> a-combine = minimum +maybeVMFlush :: IORef (x -> IO ())+maybeVMFlush = unsafePerformIO $ newIORef $ const $ return ()+ type Darcs = [String] -> Command String type BenchmarkCmd a = Darcs -> TestRepo -> Command a -data MemTime = MemTime Rational Float deriving (Read, Show, Ord, Eq)+data MemTime = MemTime Rational Double deriving (Read, Show, Ord, Eq)+data MemTimeOutput = MemTimeOutput { mtTimeMean :: Double+ , mtTimeDev :: Double+ , mtSampleSize :: Int+ , mtUnit :: TimeUnit+ , mtMemMean :: Rational+ }+ deriving (Show)++mkMemTimeOutput :: [MemTime] -> TimeUnit -> MemTimeOutput+mkMemTimeOutput xs u =+ MemTimeOutput { mtTimeMean = mean tv+ , mtTimeDev = stdDev tv+ , mtMemMean = toRational (mean mv)+ , mtSampleSize = lengthU tv+ , mtUnit = u+ }+ where+ tv = toU [ t | MemTime _ t <- xs ]+ mv = toU [ fromRational m | MemTime m _ <- xs ]+ data TestRepo = TestRepo { trName :: String+ , trCoreName :: String -- ^ (variants only) name of the orig repo , trPath :: FilePath -- ^ relative to the config file , trAnnotate :: Maybe FilePath -- ^ relative to repo, eg. @Just "README"@+ , trVariants :: [Variant] } deriving (Read, Show, Eq, Ord) instance JSON TestRepo where readJSON (JSObject o) =- TestRepo <$> jlookup "name" <*> jlookup "path"+ TestRepo <$> jlookup "name"+ <*> jlookup "name" -- 2nd time for trCoreName+ <*> jlookup "path" <*> jlookupMaybe "annotate"+ <*> (map toVariant . (DefaultVariant :) <$> jlookupMaybeList "variants") where jlookup a = case lookup a (fromJSObject o) of Nothing -> fail "Unable to read TestRepo"@@ -52,25 +86,58 @@ Nothing -> return Nothing Just JSNull -> return Nothing Just v -> Just <$> readJSON v+ jlookupMaybeList a = case lookup a (fromJSObject o) of+ Nothing -> return []+ Just v -> readJSONs v readJSON _ = fail "Unable to read TestRepo" showJSON = error "showJSON not defined for TestRepo yet" data TestBinary = TestBinary String deriving (Show, Read) -data Benchmark a = Idempotent String (BenchmarkCmd a)- | Destructive String (BenchmarkCmd a)+data TimeUnit = MilliSeconds | Seconds++instance Show TimeUnit where+ show MilliSeconds = "ms"+ show Seconds = "s"++multiplier :: TimeUnit -> Double+multiplier MilliSeconds = 1000+multiplier Seconds = 1++data Benchmark a = Idempotent TimeUnit String (BenchmarkCmd a)+ | Destructive TimeUnit String (BenchmarkCmd a) | Description String instance Show (Benchmark a) where- show (Idempotent s _) = s- show (Destructive s _) = s- show (Description s) = s+ show = description -- FIXME: is this right? -instance Read (Benchmark a) where- readsPrec _ str = [(Description str, "")]+-- note that the order of the variants is reflected in the tables+data VariantName = DefaultVariant | OptimizePristineVariant+ deriving (Eq, Ord, Read, Show) -data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Read, Show)+instance JSON VariantName where+ readJSON (JSString s) =+ case fromJSString s of+ "optimize-pristine" -> return OptimizePristineVariant+ x -> fail $ "Unknown variant: " ++ x+ readJSON _ = fail "Unable to VariantName"+ showJSON = error "showJSON not defined for VariantName yet" +data Variant = Variant { vId :: VariantName+ , vShortName :: String+ , vDescription :: String+ , vSuffix :: String+ }+ deriving (Eq, Ord, Show, Read)++toVariant :: VariantName -> Variant+toVariant n@DefaultVariant =+ Variant n "default" "default (hashed)" ""+toVariant n@OptimizePristineVariant =+ Variant n "opt pris" "optimize --pristine" "op"++data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Show)+ copyTree :: FilePath -> FilePath -> IO () copyTree from to = do subs <- (\\ [".", ".."]) `fmap` getDirectoryContents from@@ -82,21 +149,26 @@ when is_file $ copyFile (from </> item) (to </> item) description :: Benchmark a -> String-description (Idempotent d _) = d-description (Destructive d _) = d+description (Idempotent _ d _) = d+description (Destructive _ d _) = d description (Description d) = d +timeUnit :: Benchmark a -> TimeUnit+timeUnit (Idempotent u _ _) = u+timeUnit (Destructive u _ _) = u+timeUnit (Description _) = Seconds+ reset :: Command () reset = do resetMemoryUsed resetTimeUsed exec :: Benchmark a -> FilePath -> TestRepo -> Command a-exec (Idempotent _ cmd) darcs_path tr = do+exec (Idempotent _ _ cmd) darcs_path tr = do cd "_playground" verbose "cd _playground" cmd (darcs darcs_path) tr-exec (Destructive _ cmd) darcs_path tr = do+exec (Destructive _ _ cmd) darcs_path tr = do cd "_playground" let cleanup = verbose "cd .. ; rm -rf _playground" >> cd ".." >> rm_rf "_playground" res <- cmd (darcs darcs_path) tr `catchError` \e -> (cleanup >> throw e)@@ -134,7 +206,24 @@ then progress "..." >> verbose ("# leaving " ++ playrepo ++ " alone") else prepare origrepo -run :: Test a -> Command (Maybe MemTime)+-- | Run a benchmark as many times as it takes to pass a minimum threshold+-- of time or iterations (whichever comes first)+-- Useful for very small benchmarks+adaptive :: Double -- ^ seconds+ -> (Int,Int) -- ^ min, max iterations+ -> Command MemTime -> Command [MemTime]+adaptive thresh (iters_min,iters_max) cmd =+ cmd >> -- just once to warm up the disk cache (eliminate a source of variance)+ go thresh iters_max []+ where+ go t i acc | i <= 0 || (t <= 0 && i <= iters_enough) = return acc+ go t i acc =+ do verbose $ "# adaptive: iterations remaining: " ++ show i ++ " time remaining: " ++ show t+ mt@(MemTime _ t2) <- cmd+ go (t - t2) (i - 1) (mt : acc)+ iters_enough = iters_max - iters_min++run :: Test a -> Command (Maybe MemTimeOutput) run (Test benchmark tr (TestBinary bin)) = do (Just `fmap` run') `catchError` \e -> do echo_n_err $ " error: " ++ show e@@ -147,16 +236,13 @@ darcs_path <- case exe of Nothing -> canonize bin Just p -> return p- times <- sequence [- do progress (show i) >> verbose ("# try " ++ show i)- sub $ do prepareIfDifferent (trPath tr)- timed (exec benchmark darcs_path tr)- | i <- [1 .. iterations] ]- let time = combine [ t | MemTime _ t <- times ]- mem = combine [ m | MemTime m _ <- times ]+ times <- adaptive 10 (3,100) . sub $ do+ prepareIfDifferent (trPath tr)+ liftIO (readIORef maybeVMFlush >>= \go -> go darcs_path)+ timed (exec benchmark darcs_path tr)+ let result = mkMemTimeOutput times (timeUnit benchmark) spaces = 45 - (length bin + length (description benchmark) + length (trName tr))- result = MemTime mem time- result_str = (concat $ intersperse ", " $ formatResult result)+ result_str = unwords [ formatTimeResult result, formatMemoryResult result, formatSampleSize result ] progress $ (replicate spaces ' ') ++ result_str ++ "\n" verbose $ "# result: " ++ result_str return result@@ -164,13 +250,23 @@ formatNumber :: (PrintfArg a, Fractional a) => a -> String formatNumber = printf $ "%."++(show precision)++"f" -formatResult :: MemTime -> [String]-formatResult (MemTime mem time) =- [ formatNumber time ++ "s, " ++ formatNumber ((realToFrac (mem / (1024*1024))) :: Float) ++ "M" ]+formatSampleSize :: MemTimeOutput -> String+formatSampleSize mt = show (mtSampleSize mt) ++ "x" -tabulateRepo :: String -> [(Test a, Maybe MemTime)] -> Tab.Table String String String-tabulateRepo repo results = Tab.Table rowhdrs colhdrs rows+formatTimeResult :: MemTimeOutput -> String+formatTimeResult mt =+ formatNumber (adjust (mtTimeMean mt)) ++ show (mtUnit mt) ++ " d=" ++ formatNumber (mtTimeDev mt) where+ adjust = (*) (multiplier (mtUnit mt))++formatMemoryResult :: MemTimeOutput -> String+formatMemoryResult mt =+ formatNumber ((realToFrac (mtMemMean mt / (1024*1024))) :: Float) ++ "M"++tabulateRepo :: (MemTimeOutput -> String) -- ^ formatter+ -> String -> [(Test a, Maybe MemTimeOutput)] -> Tab.Table String String String+tabulateRepo format repo results = Tab.Table rowhdrs colhdrs rows+ where rowhdrs = Tab.Group Tab.NoLine $ map Tab.Header rownames colhdrs = Tab.Group Tab.SingleLine $ map Tab.Header colnames colnames = nub [ label | (Test _ _ (TestBinary label), _) <- interesting ]@@ -180,13 +276,54 @@ | row <- rownames ] match bench binary (Test bench' _ (TestBinary binary'), _) = bench == description bench' && binary == binary'- fmt (Just (_, Just x)) = formatResult x- fmt _ = [ "-, -" ]+ fmt (Just (_, Just x)) = [ format x ]+ fmt _ = [ "-" ] -tabulate :: [(Test a, Maybe MemTime)] -> [(String, Tab.Table String String String)]-tabulate results = zip repos $ map (flip tabulateRepo results) repos- where repos = nub [ trName r | (Test _ r _, _) <- results ]+type BenchmarkTable = Tab.Table String String String +tabulate :: [(Test a, Maybe MemTimeOutput)] -> [(String, (BenchmarkTable, BenchmarkTable))]+tabulate results =+ map (second tables) repoGroups+ where+ tables [] = error "tabulate error - empty list"+ tables trs@(tr0:_) =+ ( mergeVariantTables (trVariants tr0) $ map (mkTimeTable . trName) trs+ , mergeVariantTables (trVariants tr0) $ map (mkMemTable . trName) trs+ )+ repoGroups = buckets trCoreName $ nub [ r | (Test _ r _, _) <- results ]+ mkTimeTable r = tabulateRepo formatTimeResult r results+ mkMemTable r = tabulateRepo formatMemoryResult r results++buckets :: Ord b => (a -> b) -> [a] -> [ (b,[a]) ]+buckets f = map (first head . unzip)+ . groupBy ((==) `on` fst)+ . sortBy (compare `on` fst)+ . map (\x -> (f x, x))++-- For now we'll try just putting them side by side+mergeVariantTables :: [Variant] -> [BenchmarkTable] -> BenchmarkTable+mergeVariantTables _ [] = error "can't merge empty tables"+mergeVariantTables _ [t] = t -- don't do anything weird if there's only one variant+mergeVariantTables variants tbls@(t0:_) =+ Tab.Table rowhdrs colhdrs rows+ where+ rowhdrs = getRowhdrs t0+ colhdrs = Tab.Group Tab.NoLine . map Tab.Header+ . appendVariants+ . rights . Tab.flattenHeader $ getColHdrs t0+ rows = map concat . transpose . map getRows $ tbls+ --+ getRowhdrs (Tab.Table rh _ _) = rh+ getColHdrs (Tab.Table _ ch _) = ch+ getRows (Tab.Table _ _ rs) = rs+ --+ appendVariants hs =+ concatMap (\v -> map (\h -> appendVariant h v) hs) variants+ appendVariant h v =+ case vId v of+ DefaultVariant -> h+ _ -> vSuffix v ++ " " ++ h+ timed :: Command a -> Command MemTime timed a = do resetMemoryUsed@@ -208,11 +345,11 @@ verbose :: String -> Command () verbose m = liftIO $ do loud <- isLoud- when loud $ hPutStrLn stderr m+ when loud $ UTF8.hPutStrLn stderr m progress :: String -> Command () progress m = liftIO $ do loud <- isLoud- unless loud $ hPutStr stderr m+ unless loud $ UTF8.hPutStr stderr m drain :: Handle -> Bool -> IO (Chan String) drain h verb = do chan <- newChan@@ -234,7 +371,11 @@ loud <- liftIO isLoud verbose . unwords $ cmd:args (res, _, stats) <- liftIO $ do- (_,outH,errH,procH) <- runInteractiveProcess cmd args Nothing Nothing+ mPlayground <- seekPlayground `fmap` getCurrentDirectory+ mEnv <- case mPlayground of+ Nothing -> return Nothing+ Just p -> (Just . replace "HOME" p) `fmap` getEnvironment+ (_,outH,errH,procH) <- runInteractiveProcess cmd args Nothing mEnv res' <- drain outH loud errs' <- drain errH loud ex <- waitForProcess procH@@ -253,16 +394,92 @@ mem = (read (filter (`elem` "0123456789") bytes) :: Int) recordMemoryUsed $ mem * 1024 * 1024 return res+ where+ replace k v xs = (k,v) : filter ((/= k) . fst) xs -benchMany :: [TestRepo] -> [TestBinary] -> [Benchmark a] -> Command [(Test a, Maybe MemTime)]-benchMany repos bins benches =- sequence [ do let test = Test bench repo bin+seekPlayground :: FilePath -> Maybe FilePath+seekPlayground dir =+ if playground `elem` pieces+ then Just . joinPath . reverse . dropWhile (/= playground) . reverse $ pieces+ else Nothing+ where+ pieces = splitDirectories dir+ playground = "_playground"++mkVariant :: String -> String -> Variant -> Command ()+mkVariant origrepo darcs_path v =+ case vId v of+ OptimizePristineVariant -> do+ isrepo <- liftIO $ doesDirectoryExist (origrepo </> "_darcs")+ unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!"+ variant_isrepo <- liftIO $ doesDirectoryExist (variant_repo </> "_darcs")+ unless variant_isrepo $ do+ echo $ "Setting up " ++ vDescription v ++ " variant of " ++ origrepo+ verbose ("cp -a '" ++ origrepo ++ "' '" ++ variant_repo ++ "'")+ liftIO $ copyTree origrepo variant_repo+ verbose ("# sanitize " ++ variant_repo)+ liftIO $ removeFile (sources variant_repo) `catch` \_ -> return ()+ darcs darcs_path [ "optimize", "--pristine", "--repodir", variant_repo ]+ return ()+ DefaultVariant -> return ()+ where+ variant_repo = variantRepoName v origrepo++variantRepoName :: Variant -> String -> String+variantRepoName (Variant { vId = DefaultVariant }) x = x+variantRepoName v x = "variant" <.> stripped x ++ "-" ++ vSuffix v+ where+ stripped y | "repo." `isPrefixOf` y = stripped (drop 5 y)+ | "-hashed" `isSuffixOf` y = take (length y - 7) y+ | otherwise = y++setupVariants :: [TestRepo] -> TestBinary -> Command ()+setupVariants repos (TestBinary bin) =+ sequence_ [ mkVariant (trPath repo) bin variant+ | repo <- repos, variant <- trVariants repo ]++benchMany :: [TestRepo] -> [TestBinary] -> [Benchmark a] -> Command [(Test a, Maybe MemTimeOutput)]+benchMany repos bins benches = do+ fmap concat $ forM (map repoAndVariants repos) $ \rs -> do+ res <- sequence+ [ do let test = Test bench repo bin memtime <- run test return (test, memtime)- | repo <- repos, bin <- bins, bench <- benches ]+ | repo <- rs, bin <- bins, bench <- benches ]+ case tabulate res of+ [] -> return ()+ [(_,(t,_))] -> echo_n $ TR.render id id id t+ _ -> error "Not expecting more than one table for a repo and its variants"+ return res+ where+ repoAndVariants r = map (r `tweakVia`) (trVariants r)+ tweakVia tr v =+ case vId v of+ DefaultVariant -> tr+ _ -> tr { trPath = variantRepoName v (trPath tr)+ , trName = trName tr ++ " " ++ vShortName v+ } -renderMany :: [(Test a, Maybe MemTime)] -> Command ()-renderMany t = sequence_ [ do echo r- echo $ replicate (length r) '-' ++ "\n"- echo_n $ TR.render id id id tab- | (r, tab) <- tabulate t ]+renderMany :: [(Test a, Maybe MemTimeOutput)] -> Command ()+renderMany t = do+ echo . unlines $+ [ "Copy and paste below"+ , "====================================================="+ , ""+ ]+ ++ map detail [ "Machine description", "Year", "CPU", "Memory", "Hard disk", "Notes" ]+ ++ [ ""+ , "NB:"+ , ""+ , def "d" "std deviation"+ ] ++ map (describe . toVariant) [ OptimizePristineVariant ]+ echo ""+ sequence_ [ do echo r+ echo $ replicate (length r) '-' ++ "\n"+ echo_n $ TR.render id id id t_tab+ echo_n $ TR.render id id id m_tab+ | (r, (t_tab,m_tab)) <- tabulate t ]+ where+ detail k = k ++ "\n ????"+ describe v = def (vSuffix v) (vDescription v ++ " variant")+ def k v = "* " ++ k ++ " = " ++ v
Config.hs view
@@ -6,17 +6,21 @@ data Config = Get { repos :: [String] } | Run { fast :: Bool+ , cold :: Bool , only :: [String] , dump :: Bool , extra :: [String] }+ | Dist { repo :: FilePath } deriving (Show, Data, Typeable) defaultConfig :: [Mode Config] defaultConfig = [ mode $ Get { repos = [] &= args & typ "REPONAME" } , mode $ Run { fast = False &= text "Exclude the most time-consuming benchmarks"+ , cold = False &= text "Try to flush VM caches between iterations" , dump = False &= text "Produce machine-readable output on stdout" , only = [] &= text "Only run benchmarks with one of these substrings in their names" & typ "BENCHMARK" , extra = [] &= args & typ "BINARY" }+ , mode $ Dist { repo = "" &= argPos 0 & typ "DIRECTORY" } ]
+ Dist.hs view
@@ -0,0 +1,15 @@+module Dist where++import qualified Codec.Archive.Tar as Tar+import Codec.Compression.GZip( compress )+import qualified Data.ByteString.Lazy as BL+import Data.List ( isPrefixOf )+import System.FilePath++createTarball :: FilePath -> IO ()+createTarball dir = do+ str <- (compress . Tar.write) `fmap` Tar.pack dir [ "." ]+ let tarball = dropPrefix "repo." (takeBaseName dir) <.> "tgz"+ BL.writeFile tarball str+ where+ dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x
Shellish.hs view
@@ -16,7 +16,9 @@ import Control.Monad ( when ) import qualified Data.ByteString.Char8 as B import System.Process( runInteractiveProcess, waitForProcess )+import qualified System.IO.UTF8 as UTF8 + -- TODO maxMem is sort of a layering violation here... but who cares. data St = St { sCode :: Int, sStderr :: B.ByteString , sStdout :: B.ByteString, sVerbose :: Bool, maxMem :: Int, startTime :: UTCTime }@@ -36,10 +38,10 @@ pwd = liftIO $ getCurrentDirectory echo, echo_n, echo_err, echo_n_err :: String -> Command ()-echo = liftIO . putStrLn-echo_n = liftIO . (>> hFlush System.IO.stdout) . putStr-echo_err = liftIO . hPutStrLn stderr-echo_n_err = liftIO . (>> hFlush stderr) . hPutStr stderr+echo = liftIO . UTF8.putStrLn+echo_n = liftIO . (>> hFlush System.IO.stdout) . UTF8.putStr+echo_err = liftIO . UTF8.hPutStrLn stderr+echo_n_err = liftIO . (>> hFlush stderr) . UTF8.hPutStr stderr which :: String -> Command (Maybe String) which = liftIO . findExecutable
Standard.hs view
@@ -27,9 +27,9 @@ return () where files = maybe id (:) (trAnnotate tr) [ "Setup.hs", "Setup.lhs" ] -get :: Int -> [String] -> BenchmarkCmd ()-get n param darcs _ = do- forM [1..n] $ \x -> darcs $ "get" : param ++ ["repo", "get" ++ show x]+get :: [String] -> BenchmarkCmd ()+get param darcs _ = do+ darcs $ "get" : param ++ ["repo", "get"] return () pull :: Int -> BenchmarkCmd ()@@ -49,75 +49,72 @@ (\_ -> return state) MS.put newstate -wh :: Int -> BenchmarkCmd ()-wh n darcs tr = do+wh :: BenchmarkCmd ()+wh darcs tr = do cd "repo"- forM [1..n] $ \_ -> darcs_wh [] darcs tr+ darcs_wh [] darcs tr return () -wh_mod :: Int -> BenchmarkCmd ()-wh_mod n darcs tr = do+wh_mod :: BenchmarkCmd ()+wh_mod darcs tr = do cd "repo" files <- filterM test_f =<< ls "." when (null files) $ fail "no files to modify in repo root!" forM files $ \f -> mv f $ f <.> "__foo__"- forM [1..n] $ \_ -> darcs_wh [] darcs tr+ darcs_wh [] darcs tr forM files $ \f -> mv (f <.> "__foo__") f return () -wh_l :: Int -> BenchmarkCmd ()-wh_l n darcs tr = do+wh_l :: BenchmarkCmd ()+wh_l darcs tr = do cd "repo"- forM [1..n] $ \_ -> darcs_wh [ "--look-for-adds" ] darcs tr+ darcs_wh [ "--look-for-adds" ] darcs tr return () -- | n patches for each file-record_mod :: Int -> BenchmarkCmd ()-record_mod n darcs _ = do+record_mod :: BenchmarkCmd ()+record_mod darcs _ = do cd "repo" files <- filterM test_f =<< ls "."- forM_ [1..n] $ \x -> do- forM_ files $ \f -> liftIO (appendFile f (show n))- darcs [ "record", "--all", "-m", show x, "--no-test"]- darcs [ "obliterate", "--last=" ++ show n, "--all" ]+ forM_ files $ \f -> liftIO (appendFile f "x")+ darcs [ "record", "--all", "-m", "test record", "--no-test"]+ darcs [ "obliterate", "--last=1", "--all" ] return () -revert_mod :: Int -> BenchmarkCmd ()-revert_mod n darcs _ = do+revert_mod :: BenchmarkCmd ()+revert_mod darcs _ = do cd "repo" files <- filterM test_f =<< ls "."- forM_ [1..n] $ \x -> do- forM_ files $ \f -> liftIO (appendFile f (show n))- darcs [ "revert", "--all" ]+ forM_ files $ \f -> liftIO (appendFile f "foo")+ darcs [ "revert", "--all" ] return () -revert_unrevert :: Int -> BenchmarkCmd ()-revert_unrevert n darcs _ = do+revert_unrevert :: BenchmarkCmd ()+revert_unrevert darcs _ = do cd "repo" files <- filterM test_f =<< ls "."- forM_ [1..n] $ \x -> do- forM_ files $ \f -> liftIO (appendFile f (show n))- darcs [ "revert", "--all" ]- darcs [ "unrevert", "--all" ]+ forM_ files $ \f -> liftIO (appendFile f (show "foo")) darcs [ "revert", "--all" ]+ darcs [ "unrevert", "--all" ]+ darcs [ "revert", "--all" ] return () fast :: [ Benchmark () ]-fast = [ Destructive "get (full)" $ get 1 []- , Destructive "get (lazy, x10)" $ get 10 ["--lazy"]- , Idempotent "pull 100" $ pull 100- , Idempotent "wh x50" $ wh 50- , Idempotent "wh mod x50" $ wh_mod 50- , Idempotent "wh -l x20" $ wh_l 20- , Idempotent "record mod x10" $ record_mod 10- , Idempotent "revert mod x50" $ revert_mod 50- , Idempotent "(un)revert mod x10" $ revert_unrevert 10+fast = [ Destructive Seconds "get (full)" $ get []+ , Destructive Seconds "get (lazy)" $ get ["--lazy"]+ , Idempotent Seconds "pull 100" $ pull 100+ , Idempotent MilliSeconds "wh" wh+ , Idempotent MilliSeconds "wh mod" wh_mod+ , Idempotent MilliSeconds "wh -l" wh_l+ , Idempotent MilliSeconds "record mod" $ record_mod+ , Idempotent MilliSeconds "revert mod" revert_mod+ , Idempotent MilliSeconds "(un)revert mod" revert_unrevert ] standard :: [ Benchmark () ] standard = fast ++- [ Idempotent "check" check- , Idempotent "repair" repair- , Idempotent "annotate" annotate- , Idempotent "pull 1000" $ pull 1000 ]+ [ Idempotent Seconds "check" check+ , Idempotent Seconds "repair" repair+ , Idempotent Seconds "annotate" annotate+ , Idempotent Seconds "pull 1000" $ pull 1000 ]
TabularRST.hs view
@@ -19,7 +19,7 @@ , bar DoubleLine ] ++ (renderRs $ fmap renderR $ zipHeader [] cells $ fmap fr rh) ++- [ bar DoubleLine ] -- +--------------------------------------++ [ bar DoubleLine, "" ] -- note the extra blank line where bar = concat . renderTHLine sizes ch2 renderTHLine _ _ NoLine = []
darcs-benchmark.cabal view
@@ -1,5 +1,5 @@ name: darcs-benchmark-version: 0.1.5.1+version: 0.1.6 synopsis: Comparative benchmark suite for darcs. description: A simple tool to compare performance of different Darcs 2.x@@ -12,7 +12,7 @@ copyright: 2009 Petr Rockai <me@mornfall.net> author: Eric Kow <kowey@darcs.net>, Simon Michael <simon@joyful.com> and Petr Rockai <me@mornfall.net>-maintainer: Petr Rockai <me@mornfall.net>+maintainer: Darcs Project <darcs-users@darcs.net> homepage: http://wiki.darcs.net/Development/Benchmarks category: Testing build-type: Custom@@ -31,13 +31,16 @@ regex-posix, html, filepath, directory, json == 0.4.*, containers, bytestring, network,+ statistics == 0.4.*, uvector == 0.1.*, HTTP >= 4000.0.8 && < 4000.1,+ utf8-string == 0.3.*, tar, zlib main-is: main.hs other-modules: Shellish Benchmark Config+ Dist Standard Download TabularRST
main.hs view
@@ -2,20 +2,23 @@ import Shellish( shellish, rm_rf ) import Control.Arrow ( second ) import System.Console.CmdArgs+import System.Cmd ( system ) import System.Exit import System.Directory import System.IO import Control.Monad import Control.Monad.Trans import Benchmark-import Config (Config(Get,Run))+import Config (Config(Get,Run,Dist)) import qualified Config as C import Standard+import Dist ( createTarball ) import Download import Data.List import Data.Version ( showVersion ) import Paths_darcs_benchmark import Text.JSON+import Data.IORef help :: String help = unlines [ "darcs-benchmark " ++ showVersion version ++ ": run standard darcs benchmarks"@@ -37,17 +40,25 @@ , "Thank you for benchmarking darcs!" ] known_repos :: [String]-known_repos = [ "ghc-hashed", "darcs" ]+known_repos = [ "tabular", "tahoe-lafs", "darcs", "ghc-hashed" ] download_repos :: [String] -> IO () download_repos r = forM_ (if null r then known_repos else r) download +doVMFlush :: FilePath -> IO ()+doVMFlush path = do system "sudo sh -c 'echo 3 > /proc/sys/vm/drop_caches'"+ system $ path ++ " --version > /dev/null"+ return ()+ config :: [TestRepo] -> C.Config -> IO ([TestRepo], [TestBinary], [Benchmark ()]) config allrepos cfg = do case cfg of Get {} -> do download_repos (C.repos cfg) exitWith ExitSuccess+ Dist {} -> do+ createTarball (C.repo cfg)+ exitWith ExitSuccess Run {} -> do haveConf <- doesFileExist "config" conf <- if haveConf then lines `fmap` readFile "config"@@ -61,6 +72,7 @@ usetests = case C.only cfg of [] -> usetests' os -> filter (\b -> any (\o -> o `isInfixOf` show b) os) usetests'+ when (C.cold cfg) $ writeIORef maybeVMFlush doVMFlush when (null usebins) $ do hPutStrLn stderr "Please specify at least one darcs binary to benchmark" exitWith (ExitFailure 1)@@ -74,7 +86,9 @@ matchRepo tr x = trName tr == x || dropPrefix "repo." (trPath tr) == x testRepoFromDir :: String -> TestRepo-testRepoFromDir d = TestRepo (drop (length "repo.") d) d Nothing+testRepoFromDir d = TestRepo n n d Nothing [toVariant DefaultVariant]+ where+ n = drop (length "repo.") d main :: IO () main = do@@ -96,6 +110,11 @@ putStrLn $ "(Alternatively, check that you are in the right directory.)" exitWith $ ExitFailure 3 shellish $ do rm_rf "_playground"+ -- for setting up variants, we probably want the latest/greatest+ -- version of darcs in case the variant involves some new feature+ case reverse binaries of+ [] -> return ()+ (b:_) -> setupVariants repos b res <- benchMany repos binaries tests if C.dump cfg then liftIO $ print res