darcs-benchmark 0.1.7 → 0.1.8
raw patch · 10 files changed
+615/−294 lines, 10 filesdep +hs-gchartdep +old-localedep +splitdep ~network
Dependencies added: hs-gchart, old-locale, split
Dependency ranges changed: network
Files
- Benchmark.hs +16/−261
- Config.hs +2/−0
- Definitions.hs +298/−0
- Graph.hs +54/−0
- Report.hs +168/−0
- Run.hs +32/−0
- Shellish.hs +0/−1
- Standard.hs +22/−24
- darcs-benchmark.cabal +11/−3
- main.hs +12/−5
Benchmark.hs view
@@ -1,143 +1,24 @@ module Benchmark where +import Definitions 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.Environment import System.FilePath( (</>), (<.>), splitDirectories, joinPath ) import System.IO-import qualified Text.Tabular as Tab-import TabularRST as TR import System.Exit-import Text.Printf import Text.Regex.Posix( (=~) ) import Data.Time.Clock import Control.Monad.Error-import Control.Monad.State( liftIO ) import Control.Exception( throw ) import Control.Concurrent( forkIO ) import Control.Concurrent.Chan( newChan, writeChan, readChan, Chan ) 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 :: Int-precision = 1--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 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 "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"- Just v -> readJSON v- jlookupMaybe a = case lookup a (fromJSObject o) of- 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 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 = description -- FIXME: is this right?---- note that the order of the variants is reflected in the tables-data VariantName = DefaultVariant | OptimizePristineVariant- deriving (Eq, Ord, 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@@ -148,16 +29,6 @@ when is_dir $ copyTree (from </> item) (to </> item) when is_file $ copyFile (from </> item) (to </> item) -description :: Benchmark a -> String-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@@ -224,7 +95,7 @@ iters_enough = iters_max - iters_min run :: Test a -> Command (Maybe MemTimeOutput)-run (Test benchmark tr (TestBinary bin)) = do+run test@(Test benchmark tr (TestBinary bin)) = do (Just `fmap` run') `catchError` \e -> do echo_n_err $ " error: " ++ show e return Nothing@@ -238,97 +109,23 @@ Just p -> return p 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)+ liftIO (maybeVMFlush darcs_path)+ m <- timed (exec benchmark darcs_path tr)+ return m+ let result = mkMemTimeOutput times spaces = 45 - (length bin + length (description benchmark) + length (trName tr))- result_str = unwords [ formatTimeResult result, formatMemoryResult result, formatSampleSize result ]+ tu = appropriateUnit (mtTimeMean result)+ result_str = unwords $ concatMap (\f -> f tu (Cell result)) [ formatTimeResult, formatMemoryResult, formatSampleSize ]+ liftIO $ appendResult test times progress $ (replicate spaces ' ') ++ result_str ++ "\n" verbose $ "# result: " ++ result_str return result -formatNumber :: (PrintfArg a, Fractional a) => a -> String-formatNumber = printf $ "%."++(show precision)++"f"--formatSampleSize :: MemTimeOutput -> String-formatSampleSize mt = show (mtSampleSize mt) ++ "x"--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 ]- rownames = nub [ description bench | (Test bench _ _, _) <- interesting ]- interesting = [ test | test@(Test _ r _, _) <- results, trName r == repo ]- rows = [ concat [ fmt $ find (match row column) interesting | column <- colnames ]- | row <- rownames ]- match bench binary (Test bench' _ (TestBinary binary'), _) =- bench == description bench' && binary == binary'- fmt (Just (_, Just x)) = [ format x ]- fmt _ = [ "-" ]--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 t1 <- liftIO $ getCurrentTime- a+ _ <- a t2 <- liftIO $ getCurrentTime mem <- memoryUsed resetMemoryUsed@@ -338,7 +135,7 @@ check_darcs cmd = do (_,outH,_,procH) <- runInteractiveCommand $ cmd ++ " --version" out <- strictGetContents outH- waitForProcess procH+ _ <- waitForProcess procH case out of '2':'.':_ -> return () _ -> fail $ cmd ++ ": Not darcs 2.x binary."@@ -357,7 +154,7 @@ when verb $ putStrLn ("## " ++ line) work (acc ++ line) `catch` \_ -> writeChan chan acc- forkIO $ work ""+ _ <- forkIO $ work "" return chan darcs :: String -> [String] -> Command String@@ -406,6 +203,10 @@ pieces = splitDirectories dir playground = "_playground" +-- ----------------------------------------------------------------------+-- variants+-- ----------------------------------------------------------------------+ mkVariant :: String -> String -> Variant -> Command () mkVariant origrepo darcs_path v = case vId v of@@ -437,49 +238,3 @@ 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 <- 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 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
@@ -11,6 +11,7 @@ , dump :: Bool , extra :: [String] } | Dist { repo :: FilePath }+ | Report deriving (Show, Data, Typeable) defaultConfig :: [Mode Config]@@ -23,4 +24,5 @@ , extra = [] &= args & typ "BINARY" } , mode $ Dist { repo = "" &= argPos 0 & typ "DIRECTORY" }+ , mode $ Report ]
+ Definitions.hs view
@@ -0,0 +1,298 @@+module Definitions where++import Control.Applicative+import Data.Array.Vector+import Data.Function+import Data.IORef+import Data.List+import Data.Maybe+import Data.Time+import Network.BSD ( HostName, getHostName )+import Statistics.Sample+import System.Directory+import System.FilePath+import System.Locale+import System.IO.Unsafe+import Text.JSON+import Text.Printf++import Shellish (Command)++type Darcs = [String] -> Command String++data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Show)++data TestBinary = TestBinary String deriving (Show, Eq)++data ParamStamp = Params { pHostName :: HostName+ , pFlush :: Maybe (FilePath -> IO ()) }+type TimeStamp = UTCTime++global :: IORef (ParamStamp, TimeStamp)+global = unsafePerformIO $ do t <- getCurrentTime+ hn <- getHostName+ newIORef (Params hn Nothing, t)++maybeVMFlush :: FilePath -> IO ()+maybeVMFlush darcs = do+ (p,_) <- readIORef global+ case pFlush p of+ Just f -> f darcs+ Nothing -> return ()++-- ----------------------------------------------------------------------+-- benchmarks+-- ----------------------------------------------------------------------++type BenchmarkCmd a = Darcs -> TestRepo -> Command a++data BenchmarkSpeed = FastB | SlowB deriving (Eq)++data Benchmark a = Idempotent String BenchmarkSpeed (BenchmarkCmd a)+ | Destructive String BenchmarkSpeed (BenchmarkCmd a)+ | Description String++instance Show (Benchmark a) where+ show = description -- FIXME: is this right?++description :: Benchmark a -> String+description (Idempotent d _ _) = d+description (Destructive d _ _) = d+description (Description d) = d++speed :: Benchmark a -> BenchmarkSpeed+speed (Idempotent _ s _) = s+speed (Destructive _ s _) = s+speed (Description _) = FastB++-- ----------------------------------------------------------------------+-- repositories+-- ----------------------------------------------------------------------++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 "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"+ Just v -> readJSON v+ jlookupMaybe a = case lookup a (fromJSObject o) of+ 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"++-- note that the order of the variants is reflected in the tables+data VariantName = DefaultVariant | OptimizePristineVariant+ deriving (Enum, Bounded, Eq, Ord, 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"++-- | Given a name of a repo like "tabular opt pris", figure out what the+-- variant was. If there are no suffixes, like "opt pris", we assume+-- it's not a variant.+nameToVariant :: String -> Variant+nameToVariant n =+ case [ v | v <- variants, vShortName v `isSuffixOf` n ] of+ [] -> toVariant DefaultVariant+ (v:_) -> v+ where+ variants = sortBy (compare `on` (negate . suffixLength)) -- longest suffixes first+ $ allVariants+ suffixLength = length . vShortName++allVariants :: [Variant]+allVariants = map toVariant [minBound .. maxBound]++-- ----------------------------------------------------------------------+-- long-term storage+-- ----------------------------------------------------------------------++-- TODO: machine info? hash this?+paramStampPath :: ParamStamp -> String+paramStampPath p = intercalate "-" [ pHostName p, flushStr ]+ where+ flushStr = if isJust (pFlush p) then "cold" else "warm"++timeStampPath :: TimeStamp -> String+timeStampPath t = formatTime defaultTimeLocale "%Y-%m-%dT%H%M" t -- we don't need to be super-precise here++resultsDir :: IO FilePath+resultsDir =+ do home <- getHomeDirectory+ return $ home </> ".darcs-benchmark"++timingsDir :: ParamStamp -> IO FilePath+timingsDir cstmp =+ do d <- resultsDir+ return $ d </> paramStampPath cstmp <.> "timings"++appendResult :: Test a -> [MemTime] -> IO ()+appendResult (Test benchmark tr (TestBinary bin)) times =+ do (pstmp, tstmp) <- readIORef global+ d <- resultsDir+ createDirectoryIfMissing False d+ td <- timingsDir pstmp+ createDirectoryIfMissing False td+ appendFile (td </> timeStampPath tstmp) block+ where+ block = unlines $ map (intercalate "\t" . fields) times+ fields mt = [ trName tr, bin, description benchmark ] ++ fieldMt mt+ fieldMt (MemTime m t) = [ show (fromRational m :: Float), show t ]++-- ----------------------------------------------------------------------+-- outputs+-- ----------------------------------------------------------------------++precision :: Int+precision = 1++data MemTime = MemTime Rational Double deriving (Read, Show, Ord, Eq)++data MemTimeOutput = MemTimeOutput { mtTimeMean :: Double+ , mtTimeDev :: Double+ , mtSampleSize :: Int+ , mtMemMean :: Rational+ }+ deriving (Show)++mkMemTimeOutput :: [MemTime] -> MemTimeOutput+mkMemTimeOutput xs =+ MemTimeOutput { mtTimeMean = mean time_v+ , mtTimeDev = stdDev time_v+ , mtMemMean = toRational (mean mem_v)+ , mtSampleSize = lengthU time_v+ }+ where+ time_v = toU [ t | MemTime _ t <- xs ]+ mem_v = toU [ fromRational m | MemTime m _ <- xs ]++data RepoTable = RepoTable { rtRepo :: String+ , rtColumns :: [String]+ , rtRows :: [String]+ , rtTable :: [(TimeUnit, [Maybe MemTimeOutput])]+ }++-- Reformat (test, output) array as a square table by (core) Repository+repoTables :: [Benchmark ()] -> [(Test a, Maybe MemTimeOutput)] -> [RepoTable]+repoTables benchmarks results = [RepoTable { rtRepo = reponame (head repo)+ , rtColumns = columns+ , rtRows = rows+ , rtTable = table repo+ } | repo <- reposResults]+ where+ reposResults = groupBy sameRepo $ sortBy repoOrder results+ sameRepo (Test _ tr1 _, _) (Test _ tr2 _, _) = trCoreName tr1 == trCoreName tr2+ reponame (Test _ tr _, _) = trCoreName tr+ repoOrder a b = compare (reponame a) (reponame b)+ --+ rows = map description . filter hasBenchmark $ benchmarks+ hasBenchmark b = any (\ (Test tb _ _, _) -> description tb == description b) results+ --+ columns = map mkColName columnInfos+ columnInfos = nub [ (b, trName tr) | (Test _ tr b, _) <- results ]+ mkColName (TestBinary b, tname) =+ let v = nameToVariant tname+ prefix = case vId v of+ DefaultVariant -> ""+ _-> vSuffix v ++ " "+ in prefix ++ cutdown b+ cutdown d | "darcs-" `isPrefixOf` d = cutdown (drop 6 d)+ | takeExtension d == ".exe" = dropExtension d+ | otherwise = d+ --+ table repo = [(tu (tableRow row), map justMemTimeOutput $ tableRow row)+ | row <- rows]+ where+ tableRow row = [find (match row col) repo | col <- columnInfos]+ getTime (Just (_, Just mt)) = Just (mtTimeMean mt)+ getTime _ = Nothing+ tu row = case mapMaybe getTime row of+ [] -> Milliseconds+ xs -> appropriateUnit (minimum xs)+ match bench (binary, name) (Test bench' tr binary', _) =+ bench == description bench' && binary == binary' && trName tr == name+ justMemTimeOutput (Just (_, mt)) = mt+ justMemTimeOutput Nothing = Nothing++data TimeUnit = MinutesAndSeconds | Milliseconds++formatTimeElapsed :: TimeUnit -> Double -> String+formatTimeElapsed Milliseconds raw = formatNumber (raw * 1000) ++ "ms"+formatTimeElapsed MinutesAndSeconds raw =+ case mins raw of+ Nothing -> formatNumber (secs raw) ++ "s"+ Just m -> show m ++ "m" ++ formatNumber (secs raw) ++ "s"+ where+ secs x = (fromInteger (floor x `mod` 60)) + (x - fromInteger (floor x))+ mins x | x > 60 = Just (floor x `div` 60 :: Int)+ | otherwise = Nothing++appropriateUnit :: Double -> TimeUnit+appropriateUnit s | s < 2 = Milliseconds+ | otherwise = MinutesAndSeconds++data Cell h a = ColHeader h | Cell a | MissingCell++formatNumber :: (PrintfArg a, Fractional a) => a -> String+formatNumber = printf $ "%."++(show precision)++"f"++type Formatter = TimeUnit -> Cell String MemTimeOutput -> [String]++formatSampleSize :: Formatter+formatSampleSize _ (ColHeader h) = [ h ]+formatSampleSize _ MissingCell = [ "-" ]+formatSampleSize _ (Cell mt) = [ show (mtSampleSize mt) ++ "x" ]++formatTimeResult :: Formatter+formatTimeResult _ (ColHeader h) = [ h, "sdev" ]+formatTimeResult _ MissingCell = [ "-", "-" ]+formatTimeResult tu (Cell mt) =+ [ vouchFor $ time $ mtTimeMean mt, "(" ++ time (mtTimeDev mt) ++ ")" ]+ where+ time t = formatTimeElapsed tu t+ vouchFor = case mtSampleSize mt of -- FIXME: YUCK! hard coded; cf. criterion+ sz | sz < 5 -> showChar '?'+ | sz < 20 -> showChar '~'+ | otherwise -> id++formatMemoryResult :: Formatter+formatMemoryResult _ (ColHeader s) = [ s ]+formatMemoryResult _ MissingCell = [ "-" ]+formatMemoryResult _ (Cell mt) =+ [ formatNumber ((realToFrac (mtMemMean mt / (1024*1024))) :: Float) ++ "M" ]
+ Graph.hs view
@@ -0,0 +1,54 @@+module Graph where++import Data.List+import Graphics.GChart++import Definitions++graphRepoMemory :: RepoTable -> [String]+graphRepoMemory repo = map graphUrl rows+ where+ rows = [(title rowname, rtColumns repo, graphdata rowdata)+ | (rowname, (_, rowdata)) <- zip (rtRows repo) (rtTable repo)]+ title rowname = rowname ++ " (MiB)"+ graphdata rowdata = map selectMemory rowdata+ selectMemory (Just mt) = fromRational (mtMemMean mt) / (1024 * 1024)+ selectMemory _ = 0.0++graphRepoTime :: RepoTable -> [String]+graphRepoTime repo = map graphUrl rows+ where+ rows = [(title tu rowname, rtColumns repo, graphdata tu rowdata)+ | (rowname, (tu, rowdata)) <- zip (rtRows repo) (rtTable repo)]+ title Milliseconds rowname = rowname ++ " (ms)"+ title MinutesAndSeconds rowname = rowname ++ " (s)"+ graphdata tu rowdata = map (selectTime tu) rowdata+ selectTime Milliseconds (Just mt) = mtTimeMean mt * 1000+ selectTime MinutesAndSeconds (Just mt) = mtTimeMean mt+ selectTime _ _ = 0.0 ++graphUrl :: (String, [String], [Double]) -> String+graphUrl (title, labels, results) = getChartUrl $ do+ setChartSize 200 200+ setDataEncoding simple+ setChartType BarVerticalGrouped+ setBarWidthSpacing $ barwidthspacing 23 5 20+ setChartTitle title+ addAxis $ makeAxis { axisType = AxisBottom, axisLabels = Just labels }+ addAxis $ makeAxis { axisType = AxisLeft,+ axisRange = Just $ Range (0, realToFrac range) Nothing }+ setColors palette+ addChartData row+ where+ range = case results of+ [] -> 1+ xs -> maximum xs+ row = [truncate (result * 61.0 / range) | result <- results] :: [Int]+-- Color palette for bars, based on the Tango palette (Butter, Orange, Choc)+ -- TODO: Adjust palette size based on actual number of results?+ palette = [intercalate "|" ["fce94f"+ , "c4a000"+ , "fcaf3e"+ , "ce5c00"+ , "e9b96e"+ , "8f5902"]]
+ Report.hs view
@@ -0,0 +1,168 @@+module Report where++import Control.Arrow+import Control.Monad.Error+import Data.Function+import Data.List+import Data.List.Split+import Data.Maybe+import qualified Data.Map as Map+import qualified Text.Tabular as Tab+import System.Directory+import System.FilePath+import System.IO++import Definitions+import Graph+import Shellish hiding ( run )+import Standard+import TabularRST as TR++-- ----------------------------------------------------------------------+-- tables+-- ----------------------------------------------------------------------++type BenchmarkTable = Tab.Table String String String++tabulateRepo :: Formatter -> RepoTable -> Tab.Table String String String+tabulateRepo format repo = Tab.Table rowhdrs colhdrs rows+ where+ rowhdrs = Tab.Group Tab.NoLine $ map Tab.Header (rtRows repo)+ colhdrs = Tab.Group Tab.SingleLine $ map Tab.Header $+ concatMap (format myundefined . ColHeader) $ rtColumns repo+ myundefined = error "Formatting is undefined for column headers"+ rows = map formatRow $ rtTable repo+ formatRow (tu, rs) = concatMap (fmt tu) rs+ fmt tu (Just mt) = format tu (Cell mt)+ fmt tu Nothing = format tu MissingCell++-- ----------------------------------------------------------------------+-- timings files+-- ----------------------------------------------------------------------++readAllTimings :: IO [[(Test a, Maybe MemTimeOutput)]]+readAllTimings = do+ rdir <- resultsDir+ tdirs <- filter isTimingFile `fmap` getDirectoryContents rdir+ let pstamps = map dropExtension tdirs+ mapM readTimingsForParams pstamps+ where+ isTimingFile f = takeExtension f == ".timings"++readTimingsForParams :: String -> IO [(Test a, Maybe MemTimeOutput)]+readTimingsForParams pstamp = do+ rdir <- resultsDir+ let pdir = rdir </> pstamp <.> "timings"+ -- let ifile = replaceExtension ".timings" ".info" pdir+ tfiles <- filter notJunk `fmap` getDirectoryContents pdir+ entries <- concat `fmap` mapM parseTimingsFile (map (pdir </>) tfiles)+ return . map process . Map.toList . Map.fromListWith (++) . map (second (:[])) $ entries+ where+ notJunk = not . (`elem` [".",".."])++process :: ((String, String, String), [MemTime]) -> (Test a, Maybe MemTimeOutput)+process ((repo, dbin, bm), times) = (key, val)+ where+ key = Test (Description bm) (mkTr repo) (TestBinary dbin)+ val = Just $ mkMemTimeOutput times+ mkTr n = TestRepo n (guessCoreName n) n Nothing []++guessCoreName :: String -> String+guessCoreName n =+ case [ n `chop` (' ':s) | s <- suffixes, s `isSuffixOf` n ] of+ [] -> n+ (h:_) -> h+ where+ x `chop` s = take (length x - length s) x+ suffixes = sortBy (compare `on` (negate . length)) -- longest suffixes first+ $ map vShortName allVariants++type TimingsFileEntry = ((String,String,String),MemTime)++parseTimingsFile :: FilePath -> IO [TimingsFileEntry]+parseTimingsFile tf = do+ ms <- (map parseLine . lines) `fmap` readFile tf+ let unknowns = length $ filter isNothing ms+ when (unknowns > 0) $+ hPutStrLn stderr $ "Warning: could not understand " ++ show unknowns ++ " lines in " ++ tf+ return (catMaybes ms)++parseLine :: String -> Maybe TimingsFileEntry+parseLine l =+ case wordsBy (== '\t') l of+ [ repo, dbin, bm, mem, time ] -> Just ((repo, dbin, bm), memtime time mem)+ _ -> Nothing+ where+ memtime t m = MemTime (toRational (read m :: Float)) (read t)++-- ----------------------------------------------------------------------+-- reports+-- ----------------------------------------------------------------------++renderMany :: [(Test a, Maybe MemTimeOutput)] -> Command ()+renderMany results = do+ echo . unlines $+ [ "Copy and paste below"+ , "====================================================="+ , ""+ , machine_details+ , ""+ , "How to read these tables"+ , "====================================================="+ , ""+ , def "?x" "less than 5 runs used"+ , def "~x" "less than 20 runs used"+ , def "sdev" "std deviation"+ , descriptions_of_variants+ , ""+ , "Timings"+ , "===================================================="+ , ""+ , intercalate "\n" (map showT t_tables)+ , "Memory"+ , "===================================================="+ , ""+ , intercalate "\n" (map showT m_tables)+ , "Timing Graphs"+ , "===================================================="+ , ""+ , intercalate "\n" (map showG t_graphs)+ , "Memory Graphs"+ , "===================================================="+ , ""+ , intercalate "\n" (map showG m_graphs)+ ]+ where+ tables = repoTables benchmarks results+ --+ machine_details = intercalate "\n" $+ map detail [ "GHC version"+ , "Machine description", "Year", "CPU", "Memory", "Hard disk"+ , "Notes" ]+ detail k = k ++ "\n ????"+ --+ descriptions_of_variants = intercalate "\n" $+ map (describe . toVariant) [ OptimizePristineVariant ]+ describe v = def (vSuffix v) (vDescription v ++ " variant")+ def k v = "* " ++ k ++ " = " ++ v+ --+ repoTuple tabulate repo = (rtRepo repo, tabulate repo)+ t_tables = map (repoTuple $ tabulateRepo formatTimeResult) tables+ m_tables = map (repoTuple $ tabulateRepo formatMemoryResult) tables+ showT (r,t) = intercalate "\n" [ r+ , replicate (length r) '-'+ , ""+ , TR.render id id id t ]+ --+ t_graphs = map (repoTuple graphRepoTime) tables+ m_graphs = map (repoTuple graphRepoMemory) tables+ showG (r,gs) = intercalate "\n" $ [ r+ , replicate (length r) '-'+ , ""+ ] ++ (map imgDirective gs) ++ [""]+ imgDirective = (".. image:: " ++)++printCumulativeReport :: Command ()+printCumulativeReport = do+ ts <- liftIO readAllTimings+ mapM_ renderMany ts -- TODO: split this into sections for each param stamp
+ Run.hs view
@@ -0,0 +1,32 @@+module Run where++import Control.Monad.Error++import Benchmark+import Definitions+import Report+import Shellish hiding ( run )+import Standard+import qualified TabularRST as TR++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 <- rs, bin <- bins, bench <- benches ]+ let tables = repoTables benchmarks res+ if length tables == 1 then+ echo_n $ TR.render id id id $ tabulateRepo formatTimeResult (head tables)+ else 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+ }
Shellish.hs view
@@ -13,7 +13,6 @@ import Control.Monad.Error import Data.Time.Clock( getCurrentTime, diffUTCTime, UTCTime(..) ) import Control.Exception ( bracket, evaluate )-import Control.Monad ( when ) import qualified Data.ByteString.Char8 as B import System.Process( runInteractiveProcess, waitForProcess ) import qualified System.IO.UTF8 as UTF8
Standard.hs view
@@ -1,8 +1,9 @@-module Standard( standard, fast ) where+module Standard( benchmarks ) where import System.FilePath import Shellish import Benchmark hiding ( darcs )-import Control.Monad( forM_, mapM_, forM, filterM, when )+import Definitions+import Control.Monad( forM_, filterM, when ) import Control.Monad.Trans( liftIO ) import qualified Control.Monad.State as MS @@ -22,8 +23,8 @@ annotate darcs tr = do cd "repo" whenM ((not . or) `fmap` mapM test_e files) $ fail "no files to annotate"- sequence [ whenM (test_e f) $ (darcs [ "annotate", f ] >> return ())- | f <- files ]+ sequence_ [ whenM (test_e f) $ (darcs [ "annotate", f ] >> return ())+ | f <- files ] return () where files = maybe id (:) (trAnnotate tr) [ "Setup.hs", "Setup.lhs" ] @@ -60,9 +61,9 @@ 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_ files $ \f -> mv f $ f <.> "__foo__" darcs_wh [] darcs tr- forM files $ \f -> mv (f <.> "__foo__") f+ forM_ files $ \f -> mv (f <.> "__foo__") f return () wh_l :: BenchmarkCmd ()@@ -99,22 +100,19 @@ darcs [ "revert", "--all" ] return () -fast :: [ Benchmark () ]-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+benchmarks :: [ Benchmark () ]+benchmarks =+ [ Idempotent "wh" FastB wh+ , Idempotent "wh mod" FastB wh_mod+ , Idempotent "wh -l" FastB wh_l+ , Idempotent "record mod" FastB $ record_mod+ , Idempotent "revert mod" FastB revert_mod+ , Idempotent "(un)revert mod" FastB revert_unrevert+ , Destructive "get (full)" SlowB $ get []+ , Destructive "get (lazy)" FastB $ get ["--lazy"]+ , Idempotent "pull 100" FastB $ pull 100+ , Idempotent "pull 1000" SlowB $ pull 1000+ , Idempotent "check" SlowB check+ , Idempotent "repair" SlowB repair+ , Idempotent "annotate" SlowB annotate ]--standard :: [ Benchmark () ]-standard = fast ++- [ Idempotent Seconds "check" check- , Idempotent Seconds "repair" repair- , Idempotent Seconds "annotate" annotate- , Idempotent Seconds "pull 1000" $ pull 1000 ]-
darcs-benchmark.cabal view
@@ -1,5 +1,5 @@ name: darcs-benchmark-version: 0.1.7+version: 0.1.8 synopsis: Comparative benchmark suite for darcs. description: A simple tool to compare performance of different Darcs 2.x@@ -22,25 +22,33 @@ executable darcs-benchmark if impl(ghc >= 6.8) ghc-options: -fwarn-tabs- ghc-options: -Wall -threaded+ ghc-options: -Wall -threaded -fno-warn-unused-do-bind ghc-prof-options: -prof -auto-all -threaded build-depends: base < 5, cmdargs >= 0.1 && < 0.2,- process, mtl, tabular >= 0.2.2.1, time,+ process, mtl, tabular >= 0.2.2.1,+ time, old-locale, regex-posix, html, filepath, directory, json == 0.4.*, containers, bytestring, network, statistics == 0.4.*, uvector == 0.1.*, HTTP >= 4000.0.8 && < 4000.1,+ network == 2.2.*,+ split == 0.1.*, utf8-string == 0.3.*,+ hs-gchart, tar, zlib main-is: main.hs other-modules: Shellish Benchmark Config+ Definitions Dist+ Graph+ Report+ Run Standard Download TabularRST
main.hs view
@@ -1,6 +1,6 @@ #!/usr/bin/env runhaskell import Shellish( shellish, rm_rf )-import Control.Arrow ( second )+import Control.Arrow ( first, second ) import System.Console.CmdArgs import System.Cmd ( system ) import System.Exit@@ -9,8 +9,11 @@ import Control.Monad import Control.Monad.Trans import Benchmark-import Config (Config(Get,Run,Dist))+import Config (Config(Get,Run,Dist,Report))+import Definitions import qualified Config as C+import Report+import Run import Standard import Dist ( createTarball ) import Download@@ -59,6 +62,9 @@ Dist {} -> do createTarball (C.repo cfg) exitWith ExitSuccess+ Report {} -> do+ shellish printCumulativeReport+ exitWith ExitSuccess Run {} -> do haveConf <- doesFileExist "config" conf <- if haveConf then lines `fmap` readFile "config"@@ -68,11 +74,12 @@ (bins,repos) = second (drop 1) $ break (== "/") (C.extra cfg) userepos = if null repos then confrepos else repos usebins = map TestBinary $ if null bins then confbins else bins- usetests' = if C.fast cfg then fast else standard+ usetests' = if C.fast cfg then filter (\b -> speed b == FastB) benchmarks else benchmarks 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+ let setParams p = p { pFlush = if C.cold cfg then Just doVMFlush else Nothing }+ modifyIORef global (first setParams) when (null usebins) $ do hPutStrLn stderr "Please specify at least one darcs binary to benchmark" exitWith (ExitFailure 1)@@ -104,7 +111,7 @@ let name r = intercalate ", " $ map trName r putStrLn $ "Missing repositories: " ++ name (repos \\ allrepos) exitWith $ ExitFailure 2- forM binaries $ \(TestBinary bin) -> check_darcs bin+ forM_ binaries $ \(TestBinary bin) -> check_darcs bin when (null repos) $ do putStrLn $ "Oops, no repositories! Consider doing a darcs-benchmark get." putStrLn $ "(Alternatively, check that you are in the right directory.)"