diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2008, Maybench developers + +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 the Maybench developers nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/Test/Maybench.hs b/Test/Maybench.hs new file mode 100644 --- /dev/null +++ b/Test/Maybench.hs @@ -0,0 +1,111 @@ +module Test.Maybench where + +import System.Time +import System.Cmd (system) -- ideally this should use System.Process in the future, but for the sake of a first version this will do. +import Data.Maybe (maybe, isJust, fromJust) +import Control.Monad (when,replicateM) +import Control.Monad.State (MonadIO, liftIO) +import System.Directory (findExecutable) +import System.IO (putStr,hPutStr,hClose,hGetContents) +import System.Process (waitForProcess, runInteractiveProcess) + +import Test.Maybench.Command (CommandModifier, Command(Cmd), modifyCmd) + +data Benchmark = Benchmark {benchIters :: Int, benchTimes :: [TimeDiff]} + +run :: MonadIO m => CommandModifier m -> m (String, String) +run cmd = modifyCmd cmd >>= (\m -> runC $ m (Cmd "" [] "")) + +runC :: MonadIO m => Command -> m (String, String) +runC (Cmd exe' args input) = liftIO $ do + exe <- findExecutable exe' >>= maybe (fail $ "cannot find " ++ exe') return + putStr "Running... " + let cmd_str = unwords $ map showSh (exe:args) + putStrLn cmd_str + (output, err) <- runProcessWithInput exe args input + return (output, err) + where showSh x | ' ' `elem` x = show x + | otherwise = x + +runProcessWithInput :: FilePath -> [String] -> String -> IO (String, String) +runProcessWithInput cmd args input = do + (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing + hPutStr pin input + hClose pin + output <- hGetContents pout + when (output==output) $ return () + err <- hGetContents perr + when (err==err) $ return () + hClose pout + hClose perr + waitForProcess ph -- should check exit code here... + return (output, err) + +bench :: Maybe (IO a) -- ^ setup + -> IO b -- ^ action + -> Maybe (IO c) -- ^ cleanup + -> Int -- ^ iterations + -> IO Benchmark +bench setup action cleanup reps = do times <- replicateM reps core + return $ Benchmark reps times + where core = do maybe (return ()) (>> return ()) setup + start <- getClockTime + action + end <- getClockTime + maybe (return ()) (>> return ()) cleanup + return $ end `diffClockTimes` start + +benchSimple :: IO a -> Int -> IO Benchmark +benchSimple f = bench Nothing f Nothing + +timeProgram :: String -> String -> String -> IO (String, TimeDiff) +timeProgram cmd setup cleanup = do time <- bench (Just $ system setup) (system cmd) (Just $ system cleanup) 1 + return $ (cmd,averageTimeDiffs $ benchTimes time) + +averageTimeDiffs :: [TimeDiff] -> TimeDiff +averageTimeDiffs = secondsToTimeDiff . mean . map timeDiffToSeconds + where mean xs = sum xs `div` length xs + +averageTime :: String -> String -> String -> Int -> IO (String, TimeDiff) +averageTime cmd setup cleanup n = do times <- replicateM n (timeProgram cmd setup cleanup) + return (cmd,averageTimeDiffs (map snd times)) + +showTimeDiff :: (String, TimeDiff) -> String +showTimeDiff (cmd,td) = case filter isJust [helper tdYear "years", + helper tdMonth "months", + helper tdDay "days", + helper tdHour "hours", + helper tdMin "minutes", + helper tdSec "seconds"] + of [] -> (show cmd) ++ " took less than a second." + xs -> (((show cmd) ++ " took ") ++) . intercalate ", " . map fromJust $ xs + where helper accessor string = if accessor td > 0 + then (Just (show (accessor td) ++ " " ++ string)) + else Nothing + intercalate _ [] = [] + intercalate x (y:ys) = y++x++intercalate x ys + +printTimeDiff :: (String, TimeDiff) -> IO () +printTimeDiff = putStrLn . showTimeDiff + +minute, hour, day, month, year :: Int +minute = 60 +hour = minute * 60 +day = hour * 24 +month = day * 30 +year = day * 365 + +timeDiffToSeconds :: TimeDiff -> Int +timeDiffToSeconds td = tdSec td + (tdMin td) * minute + (tdHour td) * hour + (tdDay td) * day + (tdMonth td) * month + (tdYear td) * year + +secondsToTimeDiff :: Int -> TimeDiff +secondsToTimeDiff sec = normalizeTimeDiff $ TimeDiff 0 0 0 0 0 sec 0 + +compareTimes :: (String, TimeDiff) -> (String, TimeDiff) -> Maybe String +compareTimes (cmd1,td1) (cmd2,td2) = case (td1,td2) of + (TimeDiff 0 0 0 0 0 0 _, + TimeDiff 0 0 0 0 0 0 _) -> Nothing + _ -> Just $ show cmd2 ++ " took " ++ + (show ((fromIntegral $ timeDiffToSeconds td2) `percentage` (fromIntegral $ timeDiffToSeconds td1) :: Double)) + ++ "% of the time " ++ show cmd1 ++ " took." + where percentage x y = (fromIntegral $ (truncate $ (x / y * 10000 :: Double) :: Int)) / 100 diff --git a/Test/Maybench/Command.hs b/Test/Maybench/Command.hs new file mode 100644 --- /dev/null +++ b/Test/Maybench/Command.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GADTs, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} +module Test.Maybench.Command where + +import Test.Maybench.Utils ((|>)) + +infixl 5 <@> + +data Command = Cmd { cmdName :: String, cmdArgs :: [String], cmdInput :: String } + +updateCmdName :: (String -> String) -> (Command -> Command) +updateCmdName f c = c { cmdName = f $ cmdName c } + +updateCmdInput :: (String -> String) -> (Command -> Command) +updateCmdInput f c = c { cmdInput = f $ cmdInput c } + +updateCmdArgs :: ([String] -> [String]) -> (Command -> Command) +updateCmdArgs f c = c { cmdArgs = f $ cmdArgs c } + +addArg :: String -> (Command -> Command) +addArg arg = updateCmdArgs (|> arg) + +addArgs :: [String] -> (Command -> Command) +addArgs arg = updateCmdArgs (++ arg) + +class Monad m => CommandModifierClass m mod where + modifyCmd :: mod -> m (Command -> Command) + +data CommandModifier m where + Nop :: CommandModifier m + CmdMod :: (Monad m, CommandModifierClass m mod) => CommandModifier m -> mod -> CommandModifier m + +(<@>) :: (Monad m, CommandModifierClass m mod) => CommandModifier m -> mod -> CommandModifier m +(<@>) = CmdMod + +instance Monad m => CommandModifierClass m (CommandModifier m) where + modifyCmd Nop = return id + modifyCmd (CmdMod f g) = do + f' <- modifyCmd f + g' <- modifyCmd g + return (g' . f') + +{- +instance CommandModifierClass mod => CommandModifierClass [mod] where + modifyCmd [] = id + modifyCmd (mod:mods) = modifyCmd mod . modifyCmd mods +-} + +instance Monad m => CommandModifierClass m String where + modifyCmd = return . addArg + +instance Monad m => CommandModifierClass m [String] where + modifyCmd = return . addArgs + +instance Monad m => CommandModifierClass m Command where + modifyCmd = return . const diff --git a/Test/Maybench/Utils.hs b/Test/Maybench/Utils.hs new file mode 100644 --- /dev/null +++ b/Test/Maybench/Utils.hs @@ -0,0 +1,30 @@ +module Test.Maybench.Utils where + +import Data.Monoid (Monoid,mappend) + +infixr 5 <| +infixl 5 |> + +class ConsLeft f where + (<|) :: a -> f a -> f a + +class ConsRight f where + (|>) :: f a -> a -> f a + +instance ConsLeft [] where + (<|) = (:) + +instance ConsRight [] where + xs |> x = xs ++ [x] + +infix 5 <++> +(<++>) :: Monoid a => a -> a -> a +(<++>) = mappend + +list :: b -> (a -> [a] -> b) -> [a] -> b +list nil _ [] = nil +list _ cons (x:xs) = cons x xs + +fromList :: a -> [a] -> a +fromList _ [x] = x +fromList def _ = def diff --git a/darcs-benchmark/DarcsBenchmark.hs b/darcs-benchmark/DarcsBenchmark.hs new file mode 100644 --- /dev/null +++ b/darcs-benchmark/DarcsBenchmark.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +import Prelude hiding (foldr, foldl, foldr1, foldl1) +import Control.Arrow (second) +import Control.Monad () +import Control.Monad.Reader +import Control.Monad.State +import Control.Applicative +import Data.List (isInfixOf,find) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Time.Clock (getCurrentTime,diffUTCTime) +import System.FilePath (()) +import System.Directory (createDirectory, setCurrentDirectory, removeDirectoryRecursive, + getTemporaryDirectory, getCurrentDirectory ) +import System.IO (hPutStrLn,stderr) +import System.Environment (getArgs) +import System.Posix (fileExist) +import System.Console.GetOpt + +import Test.Maybench (run) +import Test.Maybench.Command (Command(..), CommandModifier(..), CommandModifierClass, modifyCmd, (<@>), + updateCmdInput, addArgs) +import Test.Maybench.Utils (fromList) + +data Counts = Counts + { allPatches :: Int + , manyPatches :: Int + , somePatches :: Int + } + +data BenchConf = BenchConf + { benchUrlRepo :: String + , benchCounts :: Counts + , interactive :: Bool + , darcsExecutable :: String + } + +data BenchState = BenchState + { benchDirRepo :: String + } + +newtype BenchM a = BenchM { benchM :: ReaderT BenchConf (StateT BenchState IO) a } + deriving (Functor, Monad, MonadIO, MonadReader BenchConf, MonadState BenchState) + +type DarcsCmd = CommandModifier BenchM + +runD :: DarcsCmd -> BenchM (String, String) +runD cmd = do + dir <- gets benchDirRepo + run $ cmd <@> RepoDir dir + +-- doing a lot of replaces finally slow down + +data DarcsCommand = DarcsCommand { _darcsCmd :: String, _darcsSubCmds :: [String] } + +instance CommandModifierClass BenchM DarcsCommand where + modifyCmd (DarcsCommand cmd subCmds) = do + exe <- asks darcsExecutable + let reset (Cmd "" [] "") = Cmd exe (cmd:subCmds) "" + reset _ = error "DarcsCommand: unexpected non empty command" + return reset + +data DarcsOpts = All + | Confirmed -- ^ for that final 'are you sure' prompt + | Last Int + | RepoDir String + | IgnoreTimes + | NoTest + | Quiet + | Author String + | Message String + | RTS String + | Arbitrary [String] + +instance CommandModifierClass BenchM DarcsOpts where + modifyCmd Confirmed = return $ updateCmdInput (++ "y") + + modifyCmd All = do + b <- asks interactive + return $ + if b then + updateCmdInput ('a':) + else + addArgs ["--all"] + + modifyCmd (Last n) = do + b <- asks interactive + return $ + if b then + updateCmdInput ((replicate n 'y' ++) . ('d' :)) + else + addArgs ["--last", show n] + + modifyCmd (RepoDir d) = return $ addArgs ["--repodir", d] + modifyCmd IgnoreTimes = return $ addArgs ["--ignore-times"] + modifyCmd NoTest = return $ addArgs ["--no-test"] + modifyCmd Quiet = return $ addArgs ["--quiet"] + modifyCmd (Author a) = return $ addArgs ["--author", a] + modifyCmd (Message m) = return $ addArgs ["-m", m] + -- not darcs flags + modifyCmd (RTS x) = return $ addArgs ["+RTS", x, "-RTS"] + modifyCmd (Arbitrary x) = return $ addArgs x + +darcs :: String -> [String] -> DarcsCmd +darcs cmd subCmds = Nop <@> DarcsCommand cmd subCmds <@> Quiet <@> RTS "-tstderr" + +darcs_unrecord, darcs_obliterate, darcs_record, darcs_add, darcs_get, + darcs_pull, darcs_show_repo, darcs_init :: DarcsCmd + +darcs_init = darcs "init" [] +darcs_unrecord = darcs "unrecord" [] +darcs_obliterate = darcs "obliterate" [] <@> IgnoreTimes +darcs_record = darcs "record" [] <@> IgnoreTimes <@> NoTest +darcs_show_repo = darcs "show" ["repo"] +darcs_add = darcs "add" [] +darcs_get = darcs "get" [] +darcs_pull = darcs "pull" [] + +data BenchResult = BR String String + +instance Show BenchResult where + show (BR k v) = k ++ ":" ++ v + +bench :: String -> BenchM (String, String) -> BenchM String +bench title f = do + start <- liftIO $ do + putStrLn title + getCurrentTime + (out, err) <- f + stop <- liftIO getCurrentTime + let diff = diffUTCTime stop start + (avgmem, maxmem) = grabMemStats err + results = [ BR "time" (show diff) + , BR "avgmem" avgmem + , BR "maxmem" maxmem ] + liftIO $ do putStr "bench stats " + print results + return out + +-- | given a string like +-- +-- <> +-- +-- return only the memory usage, so here 86016, 86016 +grabMemStats :: String -> (String, String) +grabMemStats s = + case (dropWhile (/= "GCs,") . words $ s) of + (_:x:_) -> breakOn '/' x + _ -> ("ERR","ERR") + +-- | Split a string in two at and dropping @delim@ +breakOn :: Char -- ^ delim + -> String -> (String, String) +breakOn c = second (drop 1) . break (== c) + +-- get +-- URL +-- last tag +-- medium tag +-- partial +-- format hashed/old-f + +data RepoSize = RepoSize { duration :: Int, + nfiles :: Int, + filesize :: Int } + +defaultRepoSize :: RepoSize +defaultRepoSize = RepoSize { duration = 100, + nfiles = 100, + filesize = 25 } + +make_repo :: RepoSize -> String -> BenchM () +make_repo sh name = + do cwd <- liftIO $ getCurrentDirectory + liftIO $ createDirectory name + liftIO $ setCurrentDirectory name + bench "darcs init" $ run $ darcs_init + mapM_ (\n -> createFile ("file-"++show n) (filesize sh) n) [0..nfiles sh] + bench "initial record" $ run $ darcs_record <@> All <@> Author "me" <@> Message "initial record" + let modifyFiles seed = do mapM_ (\n -> modifyFile ("file-"++show n) (seed+n)) [0..nfiles sh] + run $ darcs_record <@> All <@> Author "me" <@> Message ("change "++show seed) + mapM_ modifyFiles [0..duration sh] + liftIO $ setCurrentDirectory cwd + return () + +createFile :: String -> Int -> Int -> BenchM () +createFile f size seed = do liftIO $ writeFile f $ unlines x + bench ("add "++f) $ run $ darcs_add <@> f + return () + where x = map toline [0 .. size] + toline n | n `mod` (seed+1) == 0 = "" + | otherwise = "line "++ show n + +modifyFile :: String -> Int -> BenchM () +modifyFile _ seed | seed `mod` 10 /= 1 = return () -- only modify one in ten files +modifyFile f seed = do x <- liftIO $ readFile f + liftIO $ (seq (length x) writeFile) f $ unlines $ modi seed $ lines x + where modi 0 (_:ls) = modi seed ls + modi 3 (l:ls) = l:('x':l): modi 2 ls + modi 7 (l:ls) = ('y':l): modi 6 ls + modi n (l:ls) = l : modi (n-1) ls + modi _ [] = [] + +bench_unrecord_record :: BenchM () +bench_unrecord_record = + do bench "unrecord last 1" $ runD $ darcs_unrecord <@> Last 1 <@> All <@> Confirmed + bench "record" $ runD $ darcs_record <@> All <@> Message "test patch" <@> Author "me" + return () + +bench_obliterate_pull_last :: Int -> BenchM () +bench_obliterate_pull_last n = + do bench ("obliterate last "++show n) $ + runD $ darcs_obliterate <@> Last n <@> All <@> Confirmed + bench ("pull "++show n) $ runD $ darcs_pull <@> All + return () + +replicateBench :: (Int -> BenchM ()) -> BenchM () +replicateBench m = do + counts <- asks benchCounts + m 1 + m $ somePatches counts + m $ manyPatches counts + +benchAll :: BenchM () +benchAll = do + bench_unrecord_record + replicateBench bench_obliterate_pull_last + +-- TODO +-- whatsnew +-- record +-- unrecord +-- amend-record +-- mark-conflicts +-- rollback + +-- TODO: but these commands are not that problematic about performance +-- tag +-- unrevert +-- add +-- remove +-- mv +-- replace +-- setpref + +runBenchM :: BenchConf -> BenchState -> BenchM a -> IO a +runBenchM conf state f = evalStateT (runReaderT (benchM f) conf) state + +countPatches :: String -> BenchM Int +countPatches repo = + (read . last . words . fromList (error "bad 'darcs show repo' output") . + filter ("Num Patches:" `isInfixOf`) . lines . fst) + <$> (run $ darcs_show_repo <@> RepoDir repo) + +data Flag = DarcsFlag { darcsFlag :: String } + | RepoFlag String + | InteractiveFlag | HelpFlag + deriving (Eq) + +options :: [OptDescr Flag] +options = + [Option ['h','?'] ["help"] (NoArg HelpFlag) "show this help message", + Option ['i'] ["interactive"] (NoArg InteractiveFlag) "use the interactive mode of darcs", + Option ['r'] ["repo"] (ReqArg RepoFlag "URL") "run on a specific repository", + Option [] ["darcs"] (ReqArg DarcsFlag "COMMAND") "set the darcs command to use"] + +usage :: [String] -> IO a +usage errs = do hPutStrLn stderr $ usageInfo header options + hPutStrLn stderr dargs + ioError $ userError $ concat errs + where header = "Usage: " ++ me ++ " [OPTION...] [cmd [darcsarg...]]" + dargs = "If you pass in a darcs command, maybench will ignore any flags and\n" ++ + "just run darcs with the arguments specified.\n" ++ + "If you pass in no arguments, maybench will run its own set of standard\n" ++ + "darcs benchmarks." + +me :: String +me = "darcs-benchmark" + +ourBench :: Maybe String -> BenchConf -> IO () +ourBench mUrl initBenchConf = do + tmp <- getTemporaryDirectory + let bench_dir = tmp me + let main_repo = "main" + let displayInfo url = liftIO $ do + putStrLn ("bench directory: " ++ bench_dir) + putStrLn ("origin repository: " ++ url) + putStrLn ("main repository: " ++ main_repo) + b <- fileExist bench_dir + when b $ removeDirectoryRecursive bench_dir + createDirectory bench_dir + setCurrentDirectory bench_dir + (url, count) <- runBenchM initBenchConf undefined $ do + url <- case mUrl of + Nothing -> do displayInfo "fresh" + make_repo defaultRepoSize "fresh" + return (bench_dir "fresh") + Just r -> do displayInfo r + return r + bench "darcs get" $ run $ darcs_get <@> url <@> main_repo + count <- countPatches main_repo + return (url, count) + let counts = Counts { allPatches = count + , manyPatches = min (count `div` 3) 500 + , somePatches = min (count `div` 10) 50 } + let benchConf = initBenchConf { benchUrlRepo = url + , benchCounts = counts + } + runBenchM benchConf (BenchState main_repo) benchAll + +main :: IO () +main = do + args <- getArgs + (opts, d_args) <- + case getOpt Permute options args of + (o,n,[]) -> return (o,n) + (_,_,errs) -> usage errs + when (HelpFlag `elem` opts) $ usage [] + -- + let is_darcs_flag (DarcsFlag _) = True + is_darcs_flag _ = False + let initBenchConf = BenchConf { benchUrlRepo = undefined + , benchCounts = undefined + , interactive = InteractiveFlag `elem` opts + , darcsExecutable = fromMaybe "darcs" $ darcsFlag <$> find is_darcs_flag opts + } + mUrl = listToMaybe [ f | RepoFlag f <- opts ] + -- + case d_args of + [] -> ourBench mUrl initBenchConf + (c:das) -> runBenchM initBenchConf (BenchState "") $ do + bench "arbitrary_command" $ run $ darcs c [] <@> Arbitrary das + return () diff --git a/maybench.cabal b/maybench.cabal new file mode 100644 --- /dev/null +++ b/maybench.cabal @@ -0,0 +1,57 @@ +Name: maybench +Version: 0.1 +License: BSD3 +License-file: LICENSE +Author: Maybench developers +Maintainer: + +Category: Development +Synopsis: Automated benchmarking tool +Description: Maybench is a tool for comparing the performance + between two versions of the same program, on a + series of benchmarks that you design. + . + Maybench aims to be easy to use, almost as easy + as running "time your-program arg1..arg2". Ideally, + it should be a simple matter for outsiders to write + timing tests for your programming project and contribute + them as part of your performance testing suite. + . + The Darcs repository is available at . +Homepage: http://code.google.com/p/maybench/ + +Build-Type: Simple +Cabal-Version: >= 1.2 +Tested-With: GHC==6.8.2 + +Flag splitBase + Description: Choose the new smaller, split-up base package. +Library + if flag(splitBase) + build-depends: base >= 3, process, old-time + else + build-depends: base < 3, time, mtl + Exposed-Modules: Test.Maybench + Test.Maybench.Command + Test.Maybench.Utils + ghc-options: -Wall + +Executable maybench + Hs-Source-Dirs: ., wrapper + if flag(splitBase) + build-depends: base >= 3, + process + else + build-depends: base < 3, time, mtl + Main-Is: Maybench.hs + ghc-options: -Wall + +Executable darcs-benchmark + Hs-Source-Dirs: ., darcs-benchmark + if flag(splitBase) + build-depends: base >= 3, + process, unix, directory, time, mtl, filepath + else + build-depends: base < 3, unix, time, mtl + Main-Is: DarcsBenchmark.hs + ghc-options: -Wall diff --git a/wrapper/Maybench.hs b/wrapper/Maybench.hs new file mode 100644 --- /dev/null +++ b/wrapper/Maybench.hs @@ -0,0 +1,48 @@ +import Control.Monad (when) +import System.Cmd -- ideally this should use System.Process in the future, but for the sake of a first version this will do. +import System.Exit +import System.Console.GetOpt +import System.Environment +import Data.Maybe (maybe, isJust, fromMaybe) + +import Test.Maybench + +optList :: [OptDescr (String, String)] +optList = [Option [] ["setup"] (ReqArg (\x -> ("setup",x)) "CMD") "Command to be run prior to benchmarking to prepare the environment.", + Option [] ["setup1"] (ReqArg (\x -> ("setup1",x)) "CMD") "Command to be run prior to first benchmark to prepare the environment.", + Option [] ["setup2"] (ReqArg (\x -> ("setup2",x)) "CMD") "Command to be run prior to second benchmark to prepare the environment.", + Option [] ["cleanup"] (ReqArg (\x -> ("cleanup",x)) "CMD") "Command to be run post benchmarking to cleanup the environment.", + Option [] ["cleanup1"] (ReqArg (\x -> ("cleanup1",x)) "CMD") "Command to be run post first benchmark to cleanup the environment.", + Option [] ["cleanup2"] (ReqArg (\x -> ("cleanup2",x)) "CMD") "Command to be run post second benchmark to cleanup the environment.", + Option ['n'] ["repetitions"] (ReqArg (\x -> ("repetitions",x)) "NUMBER") "Number of trials to run and average.", + Option ['h'] ["help"] (NoArg ("help","help")) "Display usage information."] + +optsDef :: [String] -> ([([Char], String)], [String], [String]) +optsDef = getOpt Permute optList + +help :: IO () +help = do p <- getProgName + putStrLn $ usageInfo (p ++ " cmd1 cmd2") optList + exitWith ExitSuccess + return () + +main :: IO () +main = do args <- getArgs + let opts = optsDef args + lookupOpt opt = lookup opt . fst3 $ opts + setup i = fromMaybe "true" (lookupOpt ("setup" ++ show i)) + cleanup i = fromMaybe "true" (lookupOpt ("cleanup" ++ show i)) + test n c = case lookupOpt "repetitions" of + Nothing -> timeProgram c (setup n) (cleanup n) + Just r -> averageTime c (setup n) (cleanup n) (read r) + case opts of + (_,[cmd1,cmd2],_) -> do + when (isJust $ lookupOpt "help") help -- this exits + system $ setup "" + time1 <- test (1::Int) cmd1 + time2 <- test (2::Int) cmd2 + system $ cleanup "" + maybe (return ()) putStrLn (compareTimes time1 time2) + _ -> help + where + fst3 (x,_,_) = x