diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -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 diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -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 ] diff --git a/Definitions.hs b/Definitions.hs new file mode 100644 --- /dev/null +++ b/Definitions.hs @@ -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" ] diff --git a/Graph.hs b/Graph.hs new file mode 100644 --- /dev/null +++ b/Graph.hs @@ -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"]] diff --git a/Report.hs b/Report.hs new file mode 100644 --- /dev/null +++ b/Report.hs @@ -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 diff --git a/Run.hs b/Run.hs new file mode 100644 --- /dev/null +++ b/Run.hs @@ -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 + } diff --git a/Shellish.hs b/Shellish.hs --- a/Shellish.hs +++ b/Shellish.hs @@ -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 diff --git a/Standard.hs b/Standard.hs --- a/Standard.hs +++ b/Standard.hs @@ -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 ] - 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.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 diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -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.)"