diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -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 diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -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" } ] diff --git a/Dist.hs b/Dist.hs new file mode 100644 --- /dev/null +++ b/Dist.hs @@ -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 diff --git a/Shellish.hs b/Shellish.hs --- a/Shellish.hs +++ b/Shellish.hs @@ -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 diff --git a/Standard.hs b/Standard.hs --- a/Standard.hs +++ b/Standard.hs @@ -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 ] diff --git a/TabularRST.hs b/TabularRST.hs --- a/TabularRST.hs +++ b/TabularRST.hs @@ -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 = [] diff --git a/darcs-benchmark.cabal b/darcs-benchmark.cabal --- a/darcs-benchmark.cabal +++ b/darcs-benchmark.cabal @@ -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 author: Eric Kow , Simon Michael and Petr Rockai -maintainer: Petr Rockai +maintainer: Darcs Project 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 diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -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