diff --git a/Benchmark.hs b/Benchmark.hs deleted file mode 100644 --- a/Benchmark.hs +++ /dev/null @@ -1,251 +0,0 @@ -module Benchmark where - -import Definitions -import Shellish hiding ( run ) -import Data.Char -import Data.List -import Data.List.Split ( wordsBy ) -import System.Directory -import System.Environment -import System.FilePath( (), (<.>), splitDirectories, joinPath ) -import System.IO -import System.Exit -import Text.Regex.Posix( (=~) ) -import Data.Time.Clock -import Control.Monad.Error -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 qualified System.IO.UTF8 as UTF8 - -copyTree :: FilePath -> FilePath -> IO () -copyTree from to = - do subs <- (\\ [".", ".."]) `fmap` getDirectoryContents from - createDirectory to - forM_ subs $ \item -> do - is_dir <- doesDirectoryExist (from item) - is_file <- doesFileExist (from item) - when is_dir $ copyTree (from item) (to item) - when is_file $ copyFile (from item) (to item) - -reset :: Command () -reset = do - resetMemoryUsed - resetTimeUsed - -exec :: Benchmark a -> FilePath -> TestRepo -> Command a -exec (Idempotent _ _ cmd) darcs_path tr = do - cd "_playground" - verbose "cd _playground" - cmd (darcs darcs_path) tr -exec (Destructive _ _ cmd) darcs_path tr = do - cd "_playground" - let cleanup = verbose "cd .. ; rm -rf _playground" >> cd ".." >> rm_rf "_playground" - res <- cmd (darcs darcs_path) tr `catchError` \e -> (cleanup >> throw e) - cleanup - return res -exec (Description _) _ _ = fail "Cannot run description-only benchmark." - -defaultrepo, sources :: FilePath -> FilePath -defaultrepo path = path "_darcs" "prefs" "defaultrepo" -sources path = path "_darcs" "prefs" "sources" - -prepare :: String -> Command () -prepare origrepo = do - progress "!" >> verbose "rm -rf _playground" - rm_rf "_playground" - liftIO $ createDirectory "_playground" - let playrepo = "_playground" "repo" - isrepo <- liftIO $ doesDirectoryExist (origrepo "_darcs") - unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!" - progress "." >> verbose ("cp -a '" ++ origrepo ++ "' '" ++ playrepo ++ "'") - liftIO $ copyTree origrepo playrepo - progress "." >> verbose ("# sanitize " ++ playrepo) - wd <- pwd - liftIO $ do writeFile (defaultrepo playrepo) (wd origrepo) - removeFile (sources playrepo) `catch` \_ -> return () - -prepareIfDifferent :: String -> Command () -prepareIfDifferent origrepo = do - let playrepo = "_playground" "repo" - exist <- test_e "_playground" - current' <- if exist then liftIO $ readFile (defaultrepo playrepo) else return "" - let current = reverse (dropWhile (=='\n') $ reverse current') - wd <- pwd - if (exist && current == wd origrepo) - then progress "..." >> verbose ("# leaving " ++ playrepo ++ " alone") - else prepare origrepo - --- | Run a benchmark as many times as it takes to pass a minimum threshold --- of time or iterations (whichever comes first) --- Useful for very small benchmarks -adaptive :: Double -- ^ seconds - -> (Int,Int) -- ^ min, max iterations - -> Command MemTime -> Command [MemTime] -adaptive thresh (iters_min,iters_max) cmd = - cmd >> -- just once to warm up the disk cache (eliminate a source of variance) - go thresh iters_max [] - where - go t i acc | i <= 0 || (t <= 0 && i <= iters_enough) = return acc - go t i acc = - do verbose $ "# adaptive: iterations remaining: " ++ show i ++ " time remaining: " ++ show t - mt@(MemTime _ t2) <- cmd - go (t - t2) (i - 1) (mt : acc) - iters_enough = iters_max - iters_min - -run :: Test a -> Command (Maybe MemTimeOutput) -run test@(Test benchmark tr (TestBinary bin)) = do - (Just `fmap` run') `catchError` \e -> - do echo_n_err $ " error: " ++ show e - return Nothing - where run' = do - progress $ bin ++ " " ++ description benchmark ++ " [" ++ trName tr ++ "]: " - verbose $ "\n# testing; binary = " ++ bin ++ ", benchmark = " ++ - description benchmark ++ ", repository = " ++ trName tr - exe <- which $ bin - darcs_path <- case exe of - Nothing -> canonize bin - Just p -> return p - times <- adaptive 10 (3,100) . sub $ do - prepareIfDifferent (trPath tr) - 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)) - 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 - -timed :: Command a -> Command MemTime -timed a = do - resetMemoryUsed - t1 <- liftIO $ getCurrentTime - _ <- a - t2 <- liftIO $ getCurrentTime - mem <- memoryUsed - resetMemoryUsed - return $ MemTime (fromIntegral mem) (realToFrac $ diffUTCTime t2 t1) - -darcsVersion :: String -> IO Version -darcsVersion cmd = do - (_,outH,_,procH) <- runInteractiveCommand $ cmd ++ " --version" - out <- strictGetContents outH - _ <- waitForProcess procH - return $ map read . wordsBy (== '.') . takeWhile (not . isSpace) $ out - -check_darcs :: String -> IO () -check_darcs cmd = do - out <- darcsVersion cmd - case out of - 2:_ -> return () - _ -> fail $ cmd ++ ": Not darcs 2.x binary." - -verbose :: String -> Command () -verbose m = liftIO $ do loud <- isLoud - when loud $ UTF8.hPutStrLn stderr m - -progress :: String -> Command () -progress m = liftIO $ do loud <- isLoud - unless loud $ UTF8.hPutStr stderr m - -drain :: Handle -> Bool -> IO (Chan String) -drain h verb = do chan <- newChan - let work acc = do line <- hGetLine h - when verb $ putStrLn ("## " ++ line) - work (acc ++ line) - `catch` \_ -> writeChan chan acc - _ <- forkIO $ work "" - return chan - -readFile' :: FilePath -> IO String -readFile' f = do s <- readFile f - length s `seq` return s - -darcs :: String -> [String] -> Command String -darcs cmd args' = do - stats_f <- liftIO $ - do tmpdir <- getTemporaryDirectory - (f, h) <- openTempFile tmpdir "darcs-stats-XXXX" - hClose h - return f - let args = args' ++ ["+RTS", "-s" ++ stats_f, "-RTS"] - loud <- liftIO isLoud - verbose . unwords $ cmd:args - (res, _, stats) <- liftIO $ do - mPlayground <- seekPlayground `fmap` getCurrentDirectory - mEnv <- case mPlayground of - Nothing -> return Nothing - Just p -> (Just . replace "HOME" p) `fmap` getEnvironment - (_,outH,errH,procH) <- runInteractiveProcess cmd args Nothing mEnv - res' <- drain outH loud - errs' <- drain errH loud - ex <- waitForProcess procH - stats <- do c <- readFile' stats_f - removeFile stats_f `catch` \e -> hPutStrLn stderr (show e) - return c - `catch` \_ -> return "" - errs <- readChan errs' - case ex of - ExitSuccess -> return () - ExitFailure n -> fail $ "darcs failed with error code " - ++ show n ++ "\nsaying: " ++ errs - res <- readChan res' - return (res, errs, stats) - let bytes = (stats =~ "([0-9, ]+) M[bB] total memory in use") :: String - mem = (read (filter (`elem` "0123456789") bytes) :: Int) - recordMemoryUsed $ mem * 1024 * 1024 - return res - where - replace k v xs = (k,v) : filter ((/= k) . fst) xs - -seekPlayground :: FilePath -> Maybe FilePath -seekPlayground dir = - if playground `elem` pieces - then Just . joinPath . reverse . dropWhile (/= playground) . reverse $ pieces - else Nothing - where - pieces = splitDirectories dir - playground = "_playground" - --- ---------------------------------------------------------------------- --- variants --- ---------------------------------------------------------------------- - -mkVariant :: String -> String -> Variant -> Command () -mkVariant origrepo darcs_path v = - case vId v of - OptimizePristineVariant -> do - isrepo <- liftIO $ doesDirectoryExist (origrepo "_darcs") - unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!" - variant_isrepo <- liftIO $ doesDirectoryExist (variant_repo "_darcs") - unless variant_isrepo $ do - echo $ "Setting up " ++ vDescription v ++ " variant of " ++ origrepo - verbose ("cp -a '" ++ origrepo ++ "' '" ++ variant_repo ++ "'") - liftIO $ copyTree origrepo variant_repo - verbose ("# sanitize " ++ variant_repo) - liftIO $ removeFile (sources variant_repo) `catch` \_ -> return () - darcs darcs_path [ "optimize", "--pristine", "--repodir", variant_repo ] - return () - DefaultVariant -> return () - where - variant_repo = variantRepoName v origrepo - -variantRepoName :: Variant -> String -> String -variantRepoName (Variant { vId = DefaultVariant }) x = x -variantRepoName v x = "variant" <.> stripped x ++ "-" ++ vSuffix v - where - stripped y | "repo." `isPrefixOf` y = stripped (drop 5 y) - | "-hashed" `isSuffixOf` y = take (length y - 7) y - | otherwise = y - -setupVariants :: [TestRepo] -> TestBinary -> Command () -setupVariants repos (TestBinary bin) = - sequence_ [ mkVariant (trPath repo) bin variant - | repo <- repos, variant <- trVariants repo ] diff --git a/Config.hs b/Config.hs deleted file mode 100644 --- a/Config.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Config where - -import System.Console.CmdArgs - -data Config = Get { repos :: [String] } - | Run { fast :: Bool - , cold :: Bool - , only :: [String] - , dump :: Bool - , extra :: [String] } - | Dist { repo :: FilePath } - | Report - deriving (Show, Data, Typeable) - -defaultConfig :: [Mode Config] -defaultConfig = - [ mode $ Get { repos = [] &= args & typ "REPONAME" } - , mode $ Run { fast = False &= text "Exclude the most time-consuming benchmarks" - , cold = False &= text "Try to flush VM caches between iterations" - , dump = False &= text "Produce machine-readable output on stdout" - , only = [] &= text "Only run benchmarks with one of these substrings in their names" & typ "BENCHMARK" - , extra = [] &= args & typ "BINARY" - } - , mode $ Dist { repo = "" &= argPos 0 & typ "DIRECTORY" } - , mode $ Report - ] diff --git a/Definitions.hs b/Definitions.hs deleted file mode 100644 --- a/Definitions.hs +++ /dev/null @@ -1,308 +0,0 @@ -module Definitions where - -import Control.Applicative -import Data.Array.Vector -import Data.Function -import Data.IORef -import Data.List -import Data.Maybe -import Data.Ord -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 - -type Version = [Int] -- we could also use Data.Version - -- the difference here is just that we explicitly - -- do not have a notion of version tags - -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] - --- | The subset of variants appropriate to the given darcs version -appropriateVariants :: Version -> [Variant] -> [Variant] -appropriateVariants v | v < [2,3,97] = filter ((/= OptimizePristineVariant) . vId) - | v > [2,4,96] = filter ((/= DefaultVariant) . vId) - | otherwise = id - --- ---------------------------------------------------------------------- --- 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 repo - , rtRows = rows - , rtTable = table repo - } | repo <- reposResults] - where - reposResults = groupBy (on (==) reponame) $ sortBy repoOrder results - reponame (Test _ tr _, _) = trCoreName tr - repoOrder = comparing reponame - -- - rows = map description . filter hasBenchmark $ benchmarks - hasBenchmark b = any (\ (Test tb _ _, _) -> description tb == description b) results - -- - columns repo = map mkColName $ columnInfos repo - columnInfos repo = nub [ (b, trName tr) | (Test _ tr b, _) <- repo ] - 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 repo] - 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/Dist.hs b/Dist.hs deleted file mode 100644 --- a/Dist.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Dist where - -import qualified Codec.Archive.Tar as Tar -import Codec.Compression.GZip( compress ) -import qualified Data.ByteString.Lazy as BL -import Data.List ( isPrefixOf ) -import System.FilePath - -createTarball :: FilePath -> IO () -createTarball dir = do - str <- (compress . Tar.write) `fmap` Tar.pack dir [ "." ] - let tarball = dropPrefix "repo." (takeBaseName dir) <.> "tgz" - BL.writeFile tarball str - where - dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x diff --git a/Download.hs b/Download.hs deleted file mode 100644 --- a/Download.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Download where - -import Network.Browser -import Network.URI -import Network.HTTP.Base - -import qualified Codec.Archive.Tar as Tar ( read, unpack ) -import System.FilePath -import System.Directory -import Codec.Compression.GZip( decompress ) -import Control.Monad - -baseurl :: String -baseurl = "http://code.haskell.org/darcs/benchmark-repos/" - -exists :: FilePath -> IO Bool -exists f = - do exists_file <- doesFileExist f - exists_dir <- doesDirectoryExist f - return (exists_file || exists_dir) - -download :: String -> IO () -download repo = do - let Just repo_url = parseURI $ baseurl ++ repo ++ ".tgz" - Just config_url = parseURI $ baseurl ++ "config" <.> repo - config_file = "config" <.> repo - putStrLn $ "downloading and extracting: " ++ show repo_url - repo_exists <- exists ("repo" <.> repo) - config_exists <- exists ("config" <.> repo) - let go = do rsp <- fetch repo_url - when (rspCode rsp /= (2, 0, 0)) $ - fail ("download failed: " ++ rspReason rsp) - createDirectory $ "repo" <.> repo - let bits = rspBody rsp - entries = Tar.read $ decompress bits - Tar.unpack ("repo" <.> repo) entries - go_cfg = do rsp <- fetch config_url - case rspCode rsp of - (4, 0, 4) -> putStrLn $ "No config file detected for " ++ repo ++ " and that's fine!" - (2, 0, 0) -> writeFile ("config" <.> repo) (rspBody rsp) - _ -> fail ("download failed: " ++ rspReason rsp) - if repo_exists - then putStrLn $ "repo" <.> repo ++ " already exists, fetching config file only." - else go - if config_exists - then putStrLn $ config_file ++ " already exists, skipping!" - else go_cfg - where - fetch url = - do (_, rsp) <- browse $ do setCheckForProxy True - setOutHandler (const $ return ()) - request (mkRequest GET url) - return rsp diff --git a/Graph.hs b/Graph.hs deleted file mode 100644 --- a/Graph.hs +++ /dev/null @@ -1,54 +0,0 @@ -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 deleted file mode 100644 --- a/Report.hs +++ /dev/null @@ -1,168 +0,0 @@ -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 *Replace Me*" - -- - 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 deleted file mode 100644 --- a/Run.hs +++ /dev/null @@ -1,35 +0,0 @@ -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 - binsVers <- liftIO $ forM bins $ - \bin@(TestBinary b) -> do v <- darcsVersion b - return (bin, v) - fmap concat $ forM repos $ \r -> do - res <- sequence - [ do let test = Test bench repo bin - memtime <- run test - return (test, memtime) - | (bin,ver) <- binsVers, repo <- repoAndVariants ver r, 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 v r = map (r `tweakVia`) (appropriateVariants v (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 deleted file mode 100644 --- a/Shellish.hs +++ /dev/null @@ -1,166 +0,0 @@ -module Shellish( cd, pwd, run, (#), withCurrentDirectory, strictGetContents, - shellish, silently, verbosely, Command, sub, echo, echo_n, - which, canonize, resetMemoryUsed, recordMemoryUsed, - memoryUsed, rm_rf, rm_f, whenM, test_e, test_f, test_d, - resetTimeUsed, timeUsed, mv, ls, echo_err, echo_n_err ) - where - -import Data.List -import System.IO -import System.Directory -import System.Exit -import Control.Monad.State -import Control.Monad.Error -import Data.Time.Clock( getCurrentTime, diffUTCTime, UTCTime(..) ) -import Control.Exception ( bracket, evaluate ) -import qualified Data.ByteString.Char8 as B -import System.Process( runInteractiveProcess, waitForProcess ) -import qualified System.IO.UTF8 as UTF8 - - --- TODO maxMem is sort of a layering violation here... but who cares. -data St = St { sCode :: Int, sStderr :: B.ByteString , sStdout :: B.ByteString, - sVerbose :: Bool, maxMem :: Int, startTime :: UTCTime } - -type Command a = StateT St IO a - -cd :: String -> Command () -cd = liftIO . setCurrentDirectory - -mv :: String -> String -> Command () -mv a b = liftIO $ renameFile a b - -ls :: String -> Command [String] -ls dir = liftIO $ (\\ [".", ".."]) `fmap` getDirectoryContents dir - -pwd :: Command String -pwd = liftIO $ getCurrentDirectory - -echo, echo_n, echo_err, echo_n_err :: String -> Command () -echo = liftIO . UTF8.putStrLn -echo_n = liftIO . (>> hFlush System.IO.stdout) . UTF8.putStr -echo_err = liftIO . UTF8.hPutStrLn stderr -echo_n_err = liftIO . (>> hFlush stderr) . UTF8.hPutStr stderr - -which :: String -> Command (Maybe String) -which = liftIO . findExecutable - -canonize :: String -> Command String -canonize = liftIO . canonicalizePath - -whenM :: Monad m => m Bool -> m () -> m () -whenM c a = do res <- c - when res a - -test_e :: String -> Command Bool -test_e f = liftIO $ do - dir <- doesDirectoryExist f - file <- doesFileExist f - return $ file || dir - -test_f :: String -> Command Bool -test_f = liftIO . doesFileExist - -test_d :: String -> Command Bool -test_d = liftIO . doesDirectoryExist - -rm_rf :: String -> Command () -rm_rf f = whenM (test_e f) $ liftIO $ removeDirectoryRecursive f - -rm_f :: String -> Command () -rm_f f = whenM (test_e f) $ liftIO $ removeFile f - -run :: String -> [String] -> Command String -run cmd args = do - (_,outH,errH,procH) <- liftIO $ runInteractiveProcess cmd args Nothing Nothing - st <- get - res <- liftIO $ B.hGetContents outH - errs <- liftIO $ B.hGetContents errH - ex <- liftIO $ waitForProcess procH - when (sVerbose st) $ do - liftIO $ B.putStr res - liftIO $ B.putStr errs - case ex of - ExitSuccess -> return () - ExitFailure n -> fail $ "command " ++ cmd ++ " " ++ show args - ++ " failed with exit code " ++ show n - put $ st { sCode = 0, sStderr = errs, sStdout = res } - return $ B.unpack res - -(#) :: String -> [String] -> Command String -cmd # args = run cmd args - -silently :: Command a -> Command a -silently a = do - x <- get - put $ x { sVerbose = False } - r <- a - put x - return r - -verbosely :: Command a -> Command a -verbosely a = do - x <- get - put $ x { sVerbose = True } - r <- a - put x - return r - -sub :: Command a -> Command a -sub a = do - -- TODO save environment as well? - dir <- liftIO $ getCurrentDirectory - r <- a `catchError` (\e -> (liftIO $ setCurrentDirectory dir) >> throwError e) - liftIO $ setCurrentDirectory dir - return r - -shellish :: MonadIO m => Command a -> m a -shellish a = do - dir <- liftIO $ getCurrentDirectory - time <- liftIO getCurrentTime - r <- liftIO $ evalStateT a $ empty time - liftIO $ setCurrentDirectory dir - return r - where empty t = St { sCode = 0, sStderr = B.empty, - sStdout = B.empty, sVerbose = True, - maxMem = 0, startTime = t } - -strictGetContents :: Handle -> IO String -strictGetContents h = - do res <- hGetContents h - evaluate (length res) - return res - -withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory name m = - bracket - (do cwd <- getCurrentDirectory - when (name /= "") (setCurrentDirectory name) - return cwd) - (\oldwd -> setCurrentDirectory oldwd `catch` (\_ -> return ())) - (const m) - -recordMemoryUsed :: Int -> Command () -recordMemoryUsed u = do - x <- get - put x { maxMem = maximum [maxMem x, u] } - -resetMemoryUsed :: Command () -resetMemoryUsed = do - x <- get - put x { maxMem = 0 } - -resetTimeUsed :: Command () -resetTimeUsed = do - x <- get - t <- liftIO getCurrentTime - put x { startTime = t } - -memoryUsed :: Command Int -memoryUsed = do x <- get - return $ maxMem x - -timeUsed :: Command Float -timeUsed = do x <- get - t <- liftIO getCurrentTime - return $ realToFrac $ diffUTCTime t (startTime x) diff --git a/Standard.hs b/Standard.hs deleted file mode 100644 --- a/Standard.hs +++ /dev/null @@ -1,118 +0,0 @@ -module Standard( benchmarks ) where -import System.FilePath -import Shellish -import Benchmark hiding ( darcs ) -import Definitions -import Control.Monad( forM_, filterM, when ) -import Control.Monad.Trans( liftIO ) -import qualified Control.Monad.State as MS - -check :: BenchmarkCmd () -check darcs _ = do - cd "repo" - darcs [ "check", "--no-test" ] - return () - -repair :: BenchmarkCmd () -repair darcs _ = do - cd "repo" - darcs [ "repair" ] - return () - -annotate :: BenchmarkCmd () -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 ] - return () - where files = maybe id (:) (trAnnotate tr) [ "Setup.hs", "Setup.lhs" ] - -get :: [String] -> BenchmarkCmd () -get param darcs _ = do - darcs $ "get" : param ++ ["repo", "get"] - return () - -pull :: Int -> BenchmarkCmd () -pull n darcs _ = do - cd "repo" - rm_f "_darcs/patches/unrevert" - darcs [ "unpull", "--last", show n, "--all" ] - reset -- the benchmark starts here - darcs [ "pull", "--all" ] - return () - --- Oh my eyes! Oh noes! Horrible! -darcs_wh :: [String] -> BenchmarkCmd () -darcs_wh param darcs _ = do - state <- MS.get - newstate <- liftIO $ catch (MS.execStateT (darcs $ "whatsnew" : param) state) - (\_ -> return state) - MS.put newstate - -wh :: BenchmarkCmd () -wh darcs tr = do - cd "repo" - darcs_wh [] darcs tr - return () - -wh_mod :: BenchmarkCmd () -wh_mod darcs tr = do - cd "repo" - files <- filterM test_f =<< ls "." - when (null files) $ fail "no files to modify in repo root!" - forM_ files $ \f -> mv f $ f <.> "__foo__" - darcs_wh [] darcs tr - forM_ files $ \f -> mv (f <.> "__foo__") f - return () - -wh_l :: BenchmarkCmd () -wh_l darcs tr = do - cd "repo" - darcs_wh [ "--look-for-adds" ] darcs tr - return () - --- | n patches for each file -record_mod :: BenchmarkCmd () -record_mod darcs _ = do - cd "repo" - files <- filterM test_f =<< ls "." - forM_ files $ \f -> liftIO (appendFile f "x") - darcs [ "record", "-A", "me", "--all", "-m", "test record", "--no-test"] - darcs [ "obliterate", "--last=1", "--all" ] - return () - -revert_mod :: BenchmarkCmd () -revert_mod darcs _ = do - cd "repo" - files <- filterM test_f =<< ls "." - forM_ files $ \f -> liftIO (appendFile f "foo") - darcs [ "revert", "--all" ] - return () - -revert_unrevert :: BenchmarkCmd () -revert_unrevert darcs _ = do - cd "repo" - files <- filterM test_f =<< ls "." - forM_ files $ \f -> liftIO (appendFile f (show "foo")) - darcs [ "revert", "--all" ] - darcs [ "unrevert", "--all" ] - darcs [ "revert", "--all" ] - return () - -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 - ] diff --git a/TabularRST.hs b/TabularRST.hs deleted file mode 100644 --- a/TabularRST.hs +++ /dev/null @@ -1,70 +0,0 @@ -module TabularRST where - -import Data.List (intersperse, transpose) -import Text.Tabular - --- RST renderer for tabular --- (being incubated; when this matures, it should become part of tabular) - --- | for simplicity, we assume that each cell is rendered --- on a single line -render :: (rh -> String) - -> (ch -> String) - -> (a -> String) - -> Table rh ch a - -> String -render fr fc f (Table rh ch cells) = - unlines $ [ bar DoubleLine - , renderColumns sizes ch2 - , bar DoubleLine - ] ++ - (renderRs $ fmap renderR $ zipHeader [] cells $ fmap fr rh) ++ - [ bar DoubleLine, "" ] -- note the extra blank line - where - bar = concat . renderTHLine sizes ch2 - renderTHLine _ _ NoLine = [] - renderTHLine w h SingleLine = [renderHLine' w '-' h] - renderTHLine w h DoubleLine = [renderHLine' w '=' h] - -- ch2 and cell2 include the row and column labels - ch2 = Group DoubleLine [Header "", fmap fc ch] - cells2 = headerContents ch2 - : zipWith (\h cs -> h : map f cs) rhStrings cells - -- - renderR (cs,h) = renderColumns sizes $ Group DoubleLine - [ Header h - , fmap fst $ zipHeader "" (map f cs) ch] - rhStrings = map fr $ headerContents rh - -- maximum width for each column - sizes = map (maximum . map length) . transpose $ cells2 - renderRs (Header s) = [s] - renderRs (Group p hs) = concat . intersperse sep . map renderRs $ hs - where sep = renderHLine sizes ch2 p - --- | We stop rendering on the shortest list! -renderColumns :: [Int] -- ^ max width for each column - -> Header String - -> String -renderColumns is h = coreLine - where - coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h - helper = either hsep (uncurry padLeft) - hsep :: Properties -> String - hsep _ = " " - -renderHLine :: [Int] -- ^ width specifications - -> Header String - -> Properties - -> [String] -renderHLine _ _ _ = [] - -renderHLine' :: [Int] -> Char -> Header String -> String -renderHLine' is sep h = coreLine - where - coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h - helper = either vsep dashes - dashes (i,_) = replicate i sep - vsep _ = " " - -padLeft :: Int -> String -> String -padLeft l s = padding ++ s - where padding = replicate (l - length s) ' ' 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.8.3 +version: 0.1.9 synopsis: Comparative benchmark suite for darcs. description: A simple tool to compare performance of different Darcs 2.x @@ -22,12 +22,11 @@ executable darcs-benchmark if impl(ghc >= 6.8) ghc-options: -fwarn-tabs - - ghc-options: -Wall -threaded -fno-warn-unused-do-bind + ghc-options: -Wall -threaded ghc-prof-options: -prof -auto-all -threaded - build-depends: base < 5, - cmdargs >= 0.1 && < 0.2, + build-depends: base < 5, strict, + cmdargs, process, mtl, tabular >= 0.2.2.1, time, old-locale, regex-posix, html, filepath, directory, @@ -39,9 +38,10 @@ split == 0.1.*, utf8-string == 0.3.*, hs-gchart, - tar, zlib + tar, zlib, SHA, datetime main-is: main.hs + hs-source-dirs: source other-modules: Shellish Benchmark Config diff --git a/main.hs b/main.hs deleted file mode 100644 --- a/main.hs +++ /dev/null @@ -1,134 +0,0 @@ -#!/usr/bin/env runhaskell -import Shellish( shellish, rm_rf ) -import Control.Arrow ( first, second ) -import System.Console.CmdArgs -import System.Cmd ( system ) -import System.Exit -import System.Directory -import System.IO -import Control.Monad -import Control.Monad.Trans -import Benchmark -import Config (Config(Get,Run,Dist,Report)) -import Definitions -import qualified Config as C -import Report -import Run -import Standard -import Dist ( createTarball ) -import Download -import Data.List -import Data.Version ( showVersion ) -import Paths_darcs_benchmark -import Text.JSON -import Data.IORef - -help :: String -help = unlines [ "darcs-benchmark " ++ showVersion version ++ ": run standard darcs benchmarks" - , "" - , "Please either specify the repositories and binaries to run on like this:" - , "$ darcs-benchmark run [binary] [/ [repository] [repository]]" - , "" - , "or alternatively, to run on all available repos:" - , "$ darcs-benchmark run [binary]" - , "" - , "You can also create a file called 'config' in the working directory." - , "Put two lines in it, one with list of binaries, one with list of repos:" - , "" - , "binary binary binary" - , "repo repo repo" - , "" - , "(again, if the second line is not there, we run on all available repos)" - , "" - , "Thank you for benchmarking darcs!" ] - -known_repos :: [String] -known_repos = [ "tabular", "tahoe-lafs", "darcs", "ghc-hashed" ] - -download_repos :: [String] -> IO () -download_repos r = forM_ (if null r then known_repos else r) download - -doVMFlush :: FilePath -> IO () -doVMFlush path = do system "sudo sh -c 'echo 3 > /proc/sys/vm/drop_caches'" - system $ path ++ " --version > /dev/null" - return () - -config :: [TestRepo] -> C.Config -> IO ([TestRepo], [TestBinary], [Benchmark ()]) -config allrepos cfg = do - case cfg of - Get {} -> do - download_repos (C.repos cfg) - exitWith ExitSuccess - Dist {} -> do - createTarball (C.repo cfg) - exitWith ExitSuccess - Report {} -> do - shellish printCumulativeReport - exitWith ExitSuccess - Run {} -> do - haveConf <- doesFileExist "config" - conf <- if haveConf then lines `fmap` readFile "config" - else return [] - let confrepos = if length conf > 1 then (words $ conf !! 1) else [] - confbins = if length conf > 0 then words $ conf !! 0 else [] - (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 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' - 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) - return ( if null userepos then allrepos - else filter (\r -> any (matchRepo r) userepos) allrepos - , usebins - , usetests - ) - where - dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x - matchRepo tr x = trName tr == x || dropPrefix "repo." (trPath tr) == x - -testRepoFromDir :: String -> TestRepo -testRepoFromDir d = TestRepo n n d Nothing [toVariant DefaultVariant] - where - n = drop (length "repo.") d - -main :: IO () -main = do - cfg <- cmdArgs help C.defaultConfig - allrepos <- do listing <- getDirectoryContents "." - configs <- mapM readC $ filter ("config." `isPrefixOf`) listing - let other = [ testRepoFromDir d | d <- listing - , "repo." `isPrefixOf` d - , d `notElem` map trPath configs ] - return (configs ++ other) - (repos, binaries, tests) <- config allrepos cfg - unless (null $ repos \\ allrepos) $ do - let name r = intercalate ", " $ map trName r - putStrLn $ "Missing repositories: " ++ name (repos \\ allrepos) - exitWith $ ExitFailure 2 - 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.)" - exitWith $ ExitFailure 3 - shellish $ do rm_rf "_playground" - -- for setting up variants, we probably want the latest/greatest - -- version of darcs in case the variant involves some new feature - case reverse binaries of - [] -> return () - (b:_) -> setupVariants repos b - res <- benchMany repos binaries tests - if C.dump cfg - then liftIO $ print res - else renderMany res - where - readC f = - do mj <- (resultToEither . decode) `fmap` readFile f - case mj of - Left e -> fail $ "Could not read " ++ f ++ ": " ++ show e - Right j -> return $ j diff --git a/source/Benchmark.hs b/source/Benchmark.hs new file mode 100644 --- /dev/null +++ b/source/Benchmark.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +module Benchmark where + +import Prelude hiding ( readFile, catch ) +import Definitions +import Shellish hiding ( run ) +import Data.Typeable( Typeable ) +import Data.Char +import Data.List +import Data.Maybe +import Data.DateTime( parseDateTime, startOfTime ) +import Data.List.Split ( splitOn ) +import System.Directory +import System.Environment +import System.FilePath( (), (<.>), splitDirectories, joinPath ) +import System.IO hiding ( readFile ) +import System.IO.Strict( readFile ) +import System.Exit +import Text.Regex.Posix( (=~) ) +import Data.Time.Clock +import Control.Monad.Error +import Control.Exception( Exception(..), throw, catch, SomeException ) +import Control.Concurrent( forkIO ) +import Control.Concurrent.Chan( newChan, writeChan, readChan, Chan ) +import System.Console.CmdArgs (isLoud) +import System.Process( runInteractiveProcess, runInteractiveCommand, + waitForProcess ) +import qualified System.IO.UTF8 as UTF8 +import qualified Data.ByteString.Char8 as BS + +catchany :: IO a -> (SomeException -> IO a) -> IO a +catchany = catch + +copyTree :: FilePath -> FilePath -> IO () +copyTree from to = + do subs <- (\\ [".", ".."]) `fmap` getDirectoryContents from + createDirectory to + forM_ subs $ \item -> do + is_dir <- doesDirectoryExist (from item) + is_file <- doesFileExist (from item) + when is_dir $ copyTree (from item) (to item) + when is_file $ copyFile (from item) (to item) + +reset :: Command () +reset = do + resetMemoryUsed + resetTimeUsed + +exec :: Benchmark a -> TestBinary -> TestRepo -> Command a +exec (Idempotent _ _ cmd) bin tr = do + cd "_playground" + verbose "cd _playground" + cmd (vcs bin) tr +exec (Destructive _ _ cmd) bin tr = do + cd "_playground" + let cleanup = verbose "cd .. ; rm -rf _playground" >> cd ".." >> rm_rf "_playground" + res <- cmd (vcs bin) tr `catch_sh` \(e :: SomeException) -> (cleanup >> throw e) + cleanup + return res +exec (Description _) _ _ = fail "Cannot run description-only benchmark." + +defaultrepo, sources :: FilePath -> FilePath +defaultrepo path = path "_darcs" "prefs" "defaultrepo" +sources path = path "_darcs" "prefs" "sources" + +prepare :: String -> Command () +prepare origrepo = do + progress "!" >> verbose "rm -rf _playground" + rm_rf "_playground" + liftIO $ createDirectory "_playground" + let playrepo = "_playground" "repo" + isrepo <- liftIO $ doesDirectoryExist (origrepo "_darcs") + progress "." >> verbose ("cp -a '" ++ origrepo ++ "' '" ++ playrepo ++ "'") + liftIO $ copyTree origrepo playrepo + progress "." >> verbose ("# sanitize " ++ playrepo) + wd <- pwd + mkdir_p (playrepo "_darcs" "prefs") -- FIXME ... this is not very nice in git repos + liftIO $ do writeFile (defaultrepo playrepo) (wd origrepo) + removeFile (sources playrepo) `catchany` \_ -> return () + +prepareIfDifferent :: String -> Command () +prepareIfDifferent origrepo = do + let playrepo = "_playground" "repo" + exist <- test_e "_playground" + isrepo <- test_d $ playrepo "_darcs" + if isrepo then do + current' <- if exist then liftIO $ readFile (defaultrepo playrepo) else return "" + let current = reverse (dropWhile (=='\n') $ reverse current') + wd <- pwd + if (exist && current == wd origrepo) + then progress "..." >> verbose ("# leaving " ++ playrepo ++ " alone") + else prepare origrepo + else prepare origrepo + +-- | Run a benchmark as many times as it takes to pass a minimum threshold +-- of time or iterations (whichever comes first) +-- Useful for very small benchmarks +adaptive :: Double -- ^ seconds + -> (Int,Int) -- ^ min, max iterations + -> Command MemTime -> Command [MemTime] +adaptive thresh (iters_min,iters_max) cmd = + cmd >> -- just once to warm up the disk cache (eliminate a source of variance) + go thresh iters_max [] + where + go t i acc | i <= 0 || (t <= 0 && i <= iters_enough) = return acc + go t i acc = + do verbose $ "# adaptive: iterations remaining: " ++ show i ++ " time remaining: " ++ show t + mt@(MemTime _ t2) <- cmd + go (t - t2) (i - 1) (mt : acc) + iters_enough = iters_max - iters_min + +run :: Test a -> Command (Maybe MemTimeOutput) +run test@(Test benchmark tr bin) = do + (Just `fmap` run') `catch_sh` \(e :: SomeException) -> + do echo_err $ " error: " ++ show e + return Nothing + where run' = do + progress $ cmd ++ " " ++ description benchmark ++ " [" ++ trName tr ++ "]: " + verbose $ "\n# testing; binary = " ++ cmd ++ ", benchmark = " ++ + description benchmark ++ ", repository = " ++ trName tr + times <- adaptive 10 (3,100) . sub $ do + prepareIfDifferent (trPath tr) + binPath bin >>= liftIO . maybeVMFlush + m <- timed (exec benchmark bin tr) + return m + let result = mkMemTimeOutput times + spaces = 45 - (length cmd + length (description benchmark) + length (trName tr)) + 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 + cmd = binCommand bin + +timed :: Command a -> Command MemTime +timed a = do + resetMemoryUsed + t1 <- liftIO $ getCurrentTime + _ <- a + t2 <- liftIO $ getCurrentTime + mem <- memoryUsed + resetMemoryUsed + return $ MemTime (fromIntegral mem) (realToFrac $ diffUTCTime t2 t1) + +darcsMeta :: String -> [String] -> IO String +darcsMeta cmd args = do + (_,outH,_,procH) <- runInteractiveProcess cmd args Nothing Nothing + out <- strictGetContents outH + _ <- waitForProcess procH + return out + +check_vcs :: String -> IO TestBinary +check_vcs cmd = do + ver <- darcsMeta cmd ["--version"] + case ver of + _ | "git" `isPrefixOf` ver -> + return TestBinary { binCommand = cmd + , binVCS = VCSGit + , binVersionString = numeric ver + , binDate = startOfTime + , binGHC = "none at all" + , binContext = BS.empty } + _ | "Mercurial" `isPrefixOf` ver -> + return TestBinary { binCommand = cmd + , binVCS = VCSHg + , binVersionString = numeric ver + , binDate = startOfTime + , binGHC = "none at all" + , binContext = BS.empty } + _ -> check_darcs cmd + where numeric str = takeWhile (`elem` "1234567890.-") $ dropWhile (`notElem` "1234567890") str + + +check_darcs :: String -> IO TestBinary +check_darcs cmd = do + version <- darcsMeta cmd ["--version"] + [info, context] <- splitOn "Context:\n\n" `fmap` darcsMeta cmd ["--exact-version"] + rts <- read `fmap` darcsMeta cmd ["+RTS", "--info"] + let date' = case info of + _ | "darcs compiled on" `isPrefixOf` info -> + drop 18 . takeWhile (/='\n') $ info + _ -> "" + date = fromMaybe startOfTime $ parseDateTime "%b %e %Y, at %H:%M:%S" date' + bin = TestBinary { binCommand = cmd + , binVCS = VCSDarcs + , binVersionString = takeWhile (/='\n') version + , binDate = date + , binGHC = fromMaybe "unknown" $ lookup "GHC version" rts + , binContext = BS.pack context } + case binVersion bin of + 2:_ -> return bin + _ -> fail $ cmd ++ ": Not darcs 2.x binary." + +verbose :: String -> Command () +verbose m = liftIO $ do loud <- isLoud + when loud $ UTF8.hPutStrLn stderr m + +progress :: String -> Command () +progress m = liftIO $ do loud <- isLoud + unless loud $ UTF8.hPutStr stderr m + +drain :: Handle -> Bool -> IO (Chan String) +drain h verb = do chan <- newChan + let work acc = do line <- hGetLine h + when verb $ putStrLn ("## " ++ line) + work (acc ++ line ++ "\n") + `catchany` \_ -> writeChan chan acc + _ <- forkIO $ work "" + return chan + +readFile' :: FilePath -> IO String +readFile' f = do s <- readFile f + length s `seq` return s + +data RunFailed = RunFailed String Int String deriving (Typeable) + +instance Show RunFailed where + show (RunFailed cmd code errs) = + "error running " ++ cmd ++ ": exit status " ++ show code ++ ":\n" ++ errs + +instance Exception RunFailed + +runInPlayground :: String -> [String] -> Command String +runInPlayground cmd args = do + loud <- liftIO isLoud + verbose . unwords $ cmd:args + liftIO $ do + mPlayground <- seekPlayground `fmap` getCurrentDirectory + mEnv <- case mPlayground of + Nothing -> return Nothing + Just p -> (Just . replace "HOME" p) `fmap` getEnvironment + (_,outH,errH,procH) <- runInteractiveProcess cmd args Nothing mEnv + res' <- drain outH loud + errs' <- drain errH loud + ex <- waitForProcess procH + errs <- readChan errs' + case ex of + ExitSuccess -> return () + ExitFailure n -> throw $ RunFailed (cmd ++ " " ++ show args) n errs + res <- readChan res' + return res + where + replace k v xs = (k,v) : filter ((/= k) . fst) xs + +binPath :: TestBinary -> Command String +binPath bin = do exe <- which (binCommand bin) + case exe of + Nothing -> canonize $ binCommand bin + Just p -> return p + +vcs :: TestBinary -> [String] -> Command String +vcs bin args = + do exe <- binPath bin + case binVCS bin of + VCSDarcs -> darcs exe args + VCSGit -> git exe args + VCSHg -> hg exe args + +darcs :: String -> [String] -> Command String +darcs cmd args' = do + stats_f <- liftIO $ + do tmpdir <- getTemporaryDirectory + (f, h) <- openTempFile tmpdir "darcs-stats-XXXX" + hClose h + return f + let args = args' ++ ["+RTS", "-s" ++ stats_f, "-RTS"] + res <- runInPlayground cmd args + stats <- liftIO $ do c <- readFile' stats_f + removeFile stats_f `catchany` \e -> hPutStrLn stderr (show e) + return c + `catchany` \_ -> return "" + let bytes = (stats =~ "([0-9, ]+) M[bB] total memory in use") :: String + mem = case length bytes of + 0 -> 0 + _ -> (read (filter (`elem` "0123456789") bytes) :: Int) + recordMemoryUsed $ mem * 1024 * 1024 + return res + +git :: String -> [String] -> Command String +git cmd args = case args of + ["obliterate", "--last", n, "--all"] -> obliterate n + _ -> runInPlayground cmd ("--no-pager" : args') + where args' | ("whatsnew":rem) <- args = "diff" : rem + | ("revert":rem) <- args = "reset" : "--hard" : filter (/="-a") rem + | ("record":rem) <- args = "commit" : filter (/= "--no-test") rem + | ("get":rem) <- args = "clone" : rem + | otherwise = args + obliterate n = do + rev <- (last . lines) `fmap` runInPlayground cmd + ["rev-list", "--max-count=" ++ n, "HEAD"] + runInPlayground cmd ["reset", "--hard", rev] + +hg :: String -> [String] -> Command String +hg cmd args = case args of + ["obliterate", "--last", "1", "--all"] -> rollback + _ -> runInPlayground cmd args' + where args' | ("whatsnew":rem) <- args = "diff" : rem + | ("record":rem) <- args = "commit" : [ if opt == "--author" then "--user" else opt + | opt <- rem, opt /= "--no-test", opt /= "--all" ] + | ("get":rem) <- args = "clone" : rem + | otherwise = args + rollback = do runInPlayground cmd ["rollback"] + runInPlayground cmd ["revert", "-a"] + +seekPlayground :: FilePath -> Maybe FilePath +seekPlayground dir = + if playground `elem` pieces + then Just . joinPath . reverse . dropWhile (/= playground) . reverse $ pieces + else Nothing + where + pieces = splitDirectories dir + playground = "_playground" + +-- ---------------------------------------------------------------------- +-- variants +-- ---------------------------------------------------------------------- + +mkVariant :: String -> TestBinary -> Variant -> Command () +mkVariant origrepo bin v = do + isrepo <- liftIO $ doesDirectoryExist (origrepo "_darcs") + unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!" + case vId v of + OptimizePristineVariant -> do + variant_isrepo <- liftIO $ doesDirectoryExist (variant_repo "_darcs") + unless variant_isrepo $ do + echo $ "Setting up " ++ vDescription v ++ " variant of " ++ origrepo + verbose ("cp -a '" ++ origrepo ++ "' '" ++ variant_repo ++ "'") + liftIO $ copyTree origrepo variant_repo + verbose ("# sanitize " ++ variant_repo) + liftIO $ removeFile (sources variant_repo) `catchany` \_ -> return () + darcs (binCommand bin) [ "optimize", "--pristine", "--repodir", variant_repo ] + return () + GitVariant -> do + variant_exists <- liftIO $ doesDirectoryExist (variant_repo ".git") + unless variant_exists $ do + mkdir_p variant_repo + sub $ do + cd variant_repo + system "git init" + system ("darcs convert --export ../" ++ origrepo ++ " | git fast-import") + system "git checkout" + return () + HgVariant -> do + variant_exists <- liftIO $ doesDirectoryExist (variant_repo ".hg") + gitvariant <- case reverse variant_repo of + 'g':'h':'-':rest -> return $ reverse rest ++ "-git" + _ -> fail "can't figure the git variant..." + unless variant_exists $ do + mkVariant origrepo bin (toVariant GitVariant) + system $ "hg convert " ++ gitvariant ++ " " ++ variant_repo + sub $ cd variant_repo >> system "hg checkout" + return () + DefaultVariant -> return () + where + variant_repo = variantRepoName v origrepo + +variantRepoName :: Variant -> String -> String +variantRepoName (Variant { vId = DefaultVariant }) x = x +variantRepoName v x = "variant" <.> stripped x ++ "-" ++ vSuffix v + where + stripped y | "repo." `isPrefixOf` y = stripped (drop 5 y) + | "-hashed" `isSuffixOf` y = take (length y - 7) y + | otherwise = y + +setupVariants :: [TestRepo] -> TestBinary -> Command () +setupVariants repos bin = + sequence_ [ mkVariant (trPath repo) bin variant + | repo <- repos, variant <- trVariants repo ] diff --git a/source/Config.hs b/source/Config.hs new file mode 100644 --- /dev/null +++ b/source/Config.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Config where + +import System.Console.CmdArgs + +data Config = Get { repos :: [String] } + | Run { fast :: Bool + , converge :: Bool + , cold :: Bool + , only :: [String] + , dump :: Bool + , extra :: [String] } + | Dist { repo :: FilePath } + | Report + deriving (Show, Data, Typeable) + +defaultConfig :: [Mode Config] +defaultConfig = + [ mode $ Get { repos = [] &= args & typ "REPONAME" } + , mode $ Run { fast = False &= text "Exclude the most time-consuming benchmarks" + , converge = False &= text "Focus on benchmarks with not enough data" + , cold = False &= text "Try to flush VM caches between iterations" + , dump = False &= text "Produce machine-readable output on stdout" + , only = [] &= text "Only run benchmarks with one of these substrings in their names" & typ "BENCHMARK" + , extra = [] &= args & typ "BINARY" + } + , mode $ Dist { repo = "" &= argPos 0 & typ "DIRECTORY" } + , mode $ Report + ] diff --git a/source/Definitions.hs b/source/Definitions.hs new file mode 100644 --- /dev/null +++ b/source/Definitions.hs @@ -0,0 +1,363 @@ +module Definitions where + +import Prelude hiding ( readFile ) +import System.IO.Strict( readFile ) +import Control.Applicative +import Data.Array.Vector +import Data.Function +import Data.IORef +import Data.List +import Data.List.Split ( wordsBy, splitOn ) +import Data.Maybe +import Data.DateTime( DateTime, formatDateTime ) +import Data.Ord +import Data.Time +import Data.Char +import Data.Digest.Pure.SHA +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 qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BL + +import Shellish (Command) + +type Darcs = [String] -> Command String + +data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Show) +data VCS = VCSDarcs | VCSGit | VCSHg deriving (Eq, Ord, Show, Read) + +data TestBinary = TestBinary { binCommand :: String + , binVersionString :: String + , binDate :: DateTime + , binGHC :: String + , binVCS :: VCS + , binContext :: BS.ByteString } + deriving (Eq, Ord, Show, Read) + +binVersion :: TestBinary -> [Int] +binVersion = parsever . binVersionString + where parsever = map read . wordsBy (== '.') . takeWhile (`elem` "0123456789.-") + +binSha1 :: TestBinary -> String +binSha1 bin = showDigest (sha1 $ BL.fromChunks [BS.pack txt, binContext bin]) + where txt = show (binVersionString bin) ++ " " ++ + (formatDateTime "%Y-%m-%d %H:%M:%S" $ binDate bin) ++ " " + +data ParamStamp = Params { pHostName :: HostName + , pFlush :: Maybe (FilePath -> IO ()) } +type TimeStamp = UTCTime + +type Version = [Int] -- we could also use Data.Version + -- the difference here is just that we explicitly + -- do not have a notion of version tags + +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] + , trSkip :: [String] -- ^ skip benchmarks w/ description matching any of these strings + } + 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") + <*> jlookupMaybeList "skip" + 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 | GitVariant | HgVariant + deriving (Enum, Bounded, Eq, Ord, Read, Show) + +instance JSON VariantName where + readJSON (JSString s) = + case fromJSString s of + "optimize-pristine" -> return OptimizePristineVariant + "git" -> return GitVariant + "hg" -> return HgVariant + 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" +toVariant n@GitVariant = + Variant n "git" "git" "git" +toVariant n@HgVariant = + Variant n "hg" "hg" "hg" + +-- | 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] + +-- | The subset of variants appropriate to the given darcs version +appropriateVariants :: TestBinary -> [Variant] -> [Variant] +appropriateVariants bin = filter (appropriate . vId) + where appropriate GitVariant + | vcs /= VCSGit = False + appropriate HgVariant + | vcs /= VCSHg = False + appropriate OptimizePristineVariant + | vcs /= VCSDarcs || ver < [2,3,97] = False + appropriate DefaultVariant + | vcs /= VCSDarcs || ver > [2,4,96] = False + appropriate _ = True + vcs = binVCS bin + ver = binVersion bin + +-- ---------------------------------------------------------------------- +-- 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" + +appendBinary :: TestBinary -> IO () +appendBinary bin = + do (pstmp, _) <- readIORef global + path <- flip replaceExtension "info" `fmap` timingsDir pstmp + current <- (read `fmap` readFile path) `catch` \_ -> return [] + let new = (sha, bin) : [ (s, x) | (s, x) <- current, s /= sha ] + writeFile path (show new) + where sha = binSha1 bin + +appendResult :: Test a -> [MemTime] -> IO () +appendResult (Test benchmark tr 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, binSha1 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 repo + , rtRows = rows + , rtTable = table repo + } | repo <- reposResults] + where + reposResults = groupBy (on (==) reponame) $ sortBy repoOrder results + reponame (Test _ tr _, _) = trCoreName tr + repoOrder = comparing reponame + -- + rows = map description . filter hasBenchmark $ benchmarks + hasBenchmark b = any (\ (Test tb _ _, _) -> description tb == description b) results + -- + columns repo = map mkColName $ columnInfos repo + columnInfos repo = nub [ (b, trName tr) | (Test _ tr b, _) <- repo ] + mkColName (b, tname) = + let v = nameToVariant tname + prefix = case vId v of + DefaultVariant -> "" + _-> vSuffix v ++ " " + in prefix ++ cutdown (binCommand 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 repo] + 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 $ combineMeanStddev 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 + +-- | This is simply mean + stddev, but we could potentially +-- change it in the future to, for example, mean + 2 stddev +combineMeanStddev :: MemTimeOutput -> Double +combineMeanStddev mt = mtTimeMean mt + mtTimeDev mt + +formatMemoryResult :: Formatter +formatMemoryResult _ (ColHeader s) = [ s ] +formatMemoryResult _ MissingCell = [ "-" ] +formatMemoryResult _ (Cell mt) = + [ formatNumber ((realToFrac (mtMemMean mt / (1024*1024))) :: Float) ++ "M" ] diff --git a/source/Dist.hs b/source/Dist.hs new file mode 100644 --- /dev/null +++ b/source/Dist.hs @@ -0,0 +1,15 @@ +module Dist where + +import qualified Codec.Archive.Tar as Tar +import Codec.Compression.GZip( compress ) +import qualified Data.ByteString.Lazy as BL +import Data.List ( isPrefixOf ) +import System.FilePath + +createTarball :: FilePath -> IO () +createTarball dir = do + str <- (compress . Tar.write) `fmap` Tar.pack dir [ "." ] + let tarball = dropPrefix "repo." (takeBaseName dir) <.> "tgz" + BL.writeFile tarball str + where + dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x diff --git a/source/Download.hs b/source/Download.hs new file mode 100644 --- /dev/null +++ b/source/Download.hs @@ -0,0 +1,53 @@ +module Download where + +import Network.Browser +import Network.URI +import Network.HTTP.Base + +import qualified Codec.Archive.Tar as Tar ( read, unpack ) +import System.FilePath +import System.Directory +import Codec.Compression.GZip( decompress ) +import Control.Monad + +baseurl :: String +baseurl = "http://code.haskell.org/darcs/benchmark-repos/" + +exists :: FilePath -> IO Bool +exists f = + do exists_file <- doesFileExist f + exists_dir <- doesDirectoryExist f + return (exists_file || exists_dir) + +download :: String -> IO () +download repo = do + let Just repo_url = parseURI $ baseurl ++ repo ++ ".tgz" + Just config_url = parseURI $ baseurl ++ "config" <.> repo + config_file = "config" <.> repo + putStrLn $ "downloading and extracting: " ++ show repo_url + repo_exists <- exists ("repo" <.> repo) + config_exists <- exists ("config" <.> repo) + let go = do rsp <- fetch repo_url + when (rspCode rsp /= (2, 0, 0)) $ + fail ("download failed: " ++ rspReason rsp) + createDirectory $ "repo" <.> repo + let bits = rspBody rsp + entries = Tar.read $ decompress bits + Tar.unpack ("repo" <.> repo) entries + go_cfg = do rsp <- fetch config_url + case rspCode rsp of + (4, 0, 4) -> putStrLn $ "No config file detected for " ++ repo ++ " and that's fine!" + (2, 0, 0) -> writeFile ("config" <.> repo) (rspBody rsp) + _ -> fail ("download failed: " ++ rspReason rsp) + if repo_exists + then putStrLn $ "repo" <.> repo ++ " already exists, fetching config file only." + else go + if config_exists + then putStrLn $ config_file ++ " already exists, skipping!" + else go_cfg + where + fetch url = + do (_, rsp) <- browse $ do setCheckForProxy True + setOutHandler (const $ return ()) + request (mkRequest GET url) + return rsp diff --git a/source/Graph.hs b/source/Graph.hs new file mode 100644 --- /dev/null +++ b/source/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) = combineMeanStddev mt * 1000 + selectTime MinutesAndSeconds (Just mt) = combineMeanStddev 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/source/Report.hs b/source/Report.hs new file mode 100644 --- /dev/null +++ b/source/Report.hs @@ -0,0 +1,221 @@ +module Report where + +import Control.Arrow +import Control.Monad.Error +import Data.Function +import Data.List +import Data.List.Split +import Data.Maybe +import Data.DateTime( formatDateTime, startOfTime ) +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 +import qualified Data.ByteString.Char8 as BS + +-- ---------------------------------------------------------------------- +-- 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" + +unknownBinary x = + TestBinary { binCommand = x, binVersionString = "unknown" + , binDate = startOfTime, binGHC = "unknown", binVCS = VCSDarcs + , binContext = BS.empty } + +-- | Map an sha1 of darcs binary into the original binary description. +readInfos :: String -> (String -> TestBinary) +readInfos bits = \x -> case lookup x table of + Nothing -> unknownBinary x + Just b -> b + where table' = sortBy order (case reads bits of + [] -> [] + ((x,_):_) -> x) + ids = [ id | (id:_:_) <- group . sort $ map (binCommand . snd) table' ] + fixid n id ((sha, bin):rem) + | binCommand bin == id = (sha, bin { binCommand = id ++ " " ++ show n }) : + fixid (n + 1) id rem + | otherwise = (sha, bin) : fixid n id rem + fixid _ _ [] = [] + table = (foldl (.) id (map (fixid 0) ids)) table' + order (_, x) (_, y) = case compare (binVersion x) (binVersion y) of + EQ -> compare (binDate x) (binDate y) + ord -> ord + +readTimingsForParams :: String -> IO [(Test a, Maybe MemTimeOutput)] +readTimingsForParams pstamp = do + rdir <- resultsDir + let pdir = rdir pstamp <.> "timings" + ifile = rdir pstamp <.> "info" + infos <- (readInfos `fmap` readFile ifile) `catch` \_ -> do + hPutStrLn stderr $ "WARNING: Could read " ++ ifile + return unknownBinary + tfiles <- filter notJunk `fmap` getDirectoryContents pdir + entries <- concat `fmap` mapM parseTimingsFile (map (pdir ) tfiles) + return . map (process infos) . Map.toList . Map.fromListWith (++) . map (second (:[])) $ entries + where + notJunk = not . (`elem` [".",".."]) + +process :: (String -> TestBinary) + -> ((String, String, String), [MemTime]) -> (Test a, Maybe MemTimeOutput) +process infos ((repo, binhash, bm), times) = (key, val) + where + key = Test (Description bm) (mkTr repo) (infos binhash) + 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 $ + [ "Benchmark Results" + , "=====================================================" + , "" + , machine_details + , "" + , "How to read these tables" + , "=====================================================" + , "" + , "NB: times are reported as mean + 1 std deviation" + , "" + , def "?x" "less than 5 runs used" + , def "~x" "less than 20 runs used" + , def "sdev" "std deviation" + , descriptions_of_variants + , "" + , binary_details + , "" + , "Timing Graphs" + , "====================================================" + , "" + , intercalate "\n" (map showG t_graphs) + , "Timings" + , "====================================================" + , "" + , intercalate "\n" (map showT t_tables) + , "Memory Graphs" + , "====================================================" + , "" + , intercalate "\n" (map showG m_graphs) + , "Memory" + , "====================================================" + , "" + , intercalate "\n" (map showT m_tables) + ] + where + tables = repoTables benchmarks results + -- + machine_details = intercalate "\n" $ + map detail [ "Machine description", "Year", "CPU", "Memory", "Hard disk", "Notes" ] + detail k = k ++ "\n *Replace Me*" + -- + 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:: " ++) + binaries = map head . group . sort $ [ bin | (Test _ _ bin, _) <- results ] + -- + binary_details = unlines $ map describe_bin binaries + describe_bin bin = padl 12 (binCommand bin ++ ": ") ++ + binVersionString bin ++ ",\n" ++ (replicate 12 ' ') ++ + (formatDateTime "%Y-%m-%d %H:%M:%S" $ binDate bin) ++ + ", GHC " ++ binGHC bin + padr n x = x ++ pad n x + padl n x = pad n x ++ x + pad n x = take (n - length x) (repeat ' ') + +printCumulativeReport :: Command () +printCumulativeReport = do + ts <- liftIO readAllTimings + mapM_ renderMany ts -- TODO: split this into sections for each param stamp + +-- | For each repository, the benchmarks that we have enough data for +sufficientData :: [(Test a, Maybe MemTimeOutput)] -> [ (String, [String]) ] +sufficientData results = + map (rtRepo &&& missingPoints) tables + where + tables = repoTables benchmarks results + missingPoints t = [ d | (d,mts) <- zip (rtRows t) (rtTable t), all enough (snd mts) ] + -- + enough (Just mt) | mtSampleSize mt >= 20 = True -- TODO: avoid duplication with formatTimeResult + enough _ = False diff --git a/source/Run.hs b/source/Run.hs new file mode 100644 --- /dev/null +++ b/source/Run.hs @@ -0,0 +1,35 @@ +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, [Benchmark a])] -> [TestBinary] -> Command [(Test a, Maybe MemTimeOutput)] +benchMany reposbenches bins = do + fmap concat $ forM reposbenches $ \(r,benches) -> do + res <- sequence + [ do let test = Test bench repo bin + memtime <- run test + return (test, memtime) + | bin <- bins + , repo <- repoAndVariants bin r + , bench <- filter (noSkip r) benches ] + case repoTables benchmarks res of + [] -> echo $ "No benchmarks to run for " ++ trCoreName r + [t] -> echo_n $ TR.render id id id $ tabulateRepo formatTimeResult t + _ -> error "Not expecting more than one table for a repo and its variants" + return res + where + noSkip r b = not (description b `elem` trSkip r) + repoAndVariants bin r = map (r `tweakVia`) (appropriateVariants bin (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/source/Shellish.hs b/source/Shellish.hs new file mode 100644 --- /dev/null +++ b/source/Shellish.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Shellish( cd, pwd, run, (#), withCurrentDirectory, strictGetContents, + shellish, silently, verbosely, Command, sub, echo, echo_n, + which, canonize, resetMemoryUsed, recordMemoryUsed, + memoryUsed, rm_rf, rm_f, whenM, test_e, test_f, test_d, + resetTimeUsed, timeUsed, mv, ls, echo_err, echo_n_err, + mkdir_p, catch_sh, system ) + where + +import Prelude hiding ( catch ) +import Data.List +import System.IO +import System.Directory +import System.Exit +import Control.Exception +import Control.Monad.State +import Control.Monad.Error +import Data.Time.Clock( getCurrentTime, diffUTCTime, UTCTime(..) ) +import Control.Exception ( bracket, evaluate ) +import qualified Data.ByteString.Char8 as B +import System.Process( runInteractiveProcess, waitForProcess ) +import qualified System.IO.UTF8 as UTF8 +import qualified System.Cmd as Cmd + + +-- TODO maxMem is sort of a layering violation here... but who cares. +data St = St { sCode :: Int, sStderr :: B.ByteString , sStdout :: B.ByteString, + sVerbose :: Bool, maxMem :: Int, startTime :: UTCTime } + +type Command a = StateT St IO a + +-- Oh my eyes! Oh noes! Horrible! +catch_sh :: (Exception e) => Command a -> (e -> Command a) -> Command a +catch_sh action handler = do + state <- get + (val, newstate) <- liftIO $ catch (runStateT action state) + (\e -> do runStateT (handler e) state) + put newstate + return val + +cd :: String -> Command () +cd = liftIO . setCurrentDirectory + +mv :: String -> String -> Command () +mv a b = liftIO $ renameFile a b + +ls :: String -> Command [String] +ls dir = liftIO $ (\\ [".", ".."]) `fmap` getDirectoryContents dir + +pwd :: Command String +pwd = liftIO $ getCurrentDirectory + +echo, echo_n, echo_err, echo_n_err :: String -> Command () +echo = liftIO . UTF8.putStrLn +echo_n = liftIO . (>> hFlush System.IO.stdout) . UTF8.putStr +echo_err = liftIO . UTF8.hPutStrLn stderr +echo_n_err = liftIO . (>> hFlush stderr) . UTF8.hPutStr stderr + +mkdir_p :: String -> Command () +mkdir_p = liftIO . createDirectoryIfMissing True + +which :: String -> Command (Maybe String) +which = liftIO . findExecutable + +canonize :: String -> Command String +canonize = liftIO . canonicalizePath + +whenM :: Monad m => m Bool -> m () -> m () +whenM c a = do res <- c + when res a + +test_e :: String -> Command Bool +test_e f = liftIO $ do + dir <- doesDirectoryExist f + file <- doesFileExist f + return $ file || dir + +test_f :: String -> Command Bool +test_f = liftIO . doesFileExist + +test_d :: String -> Command Bool +test_d = liftIO . doesDirectoryExist + +rm_rf :: String -> Command () +rm_rf f = whenM (test_e f) $ liftIO $ removeDirectoryRecursive f + +rm_f :: String -> Command () +rm_f f = whenM (test_e f) $ liftIO $ removeFile f + +system :: String -> Command ExitCode +system = liftIO . Cmd.system + +run :: String -> [String] -> Command String +run cmd args = do + (_,outH,errH,procH) <- liftIO $ runInteractiveProcess cmd args Nothing Nothing + st <- get + res <- liftIO $ B.hGetContents outH + errs <- liftIO $ B.hGetContents errH + ex <- liftIO $ waitForProcess procH + when (sVerbose st) $ do + liftIO $ B.putStr res + liftIO $ B.putStr errs + case ex of + ExitSuccess -> return () + ExitFailure n -> fail $ "command " ++ cmd ++ " " ++ show args + ++ " failed with exit code " ++ show n + put $ st { sCode = 0, sStderr = errs, sStdout = res } + return $ B.unpack res + +(#) :: String -> [String] -> Command String +cmd # args = run cmd args + +silently :: Command a -> Command a +silently a = do + x <- get + put $ x { sVerbose = False } + r <- a + put x + return r + +verbosely :: Command a -> Command a +verbosely a = do + x <- get + put $ x { sVerbose = True } + r <- a + put x + return r + +sub :: Command a -> Command a +sub a = do + -- TODO save environment as well? + dir <- liftIO $ getCurrentDirectory + r <- a `catch_sh` (\(e :: SomeException) -> (liftIO $ setCurrentDirectory dir) >> throw e) + liftIO $ setCurrentDirectory dir + return r + +shellish :: MonadIO m => Command a -> m a +shellish a = do + dir <- liftIO $ getCurrentDirectory + time <- liftIO getCurrentTime + r <- liftIO $ evalStateT a $ empty time + liftIO $ setCurrentDirectory dir + return r + where empty t = St { sCode = 0, sStderr = B.empty, + sStdout = B.empty, sVerbose = True, + maxMem = 0, startTime = t } + +strictGetContents :: Handle -> IO String +strictGetContents h = + do res <- hGetContents h + evaluate (length res) + return res + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory name m = + bracket + (do cwd <- getCurrentDirectory + when (name /= "") (setCurrentDirectory name) + return cwd) + (\oldwd -> setCurrentDirectory oldwd `catch` (\(_ :: SomeException) -> return ())) + (const m) + +recordMemoryUsed :: Int -> Command () +recordMemoryUsed u = do + x <- get + put x { maxMem = maximum [maxMem x, u] } + +resetMemoryUsed :: Command () +resetMemoryUsed = do + x <- get + put x { maxMem = 0 } + +resetTimeUsed :: Command () +resetTimeUsed = do + x <- get + t <- liftIO getCurrentTime + put x { startTime = t } + +memoryUsed :: Command Int +memoryUsed = do x <- get + return $ maxMem x + +timeUsed :: Command Float +timeUsed = do x <- get + t <- liftIO getCurrentTime + return $ realToFrac $ diffUTCTime t (startTime x) diff --git a/source/Standard.hs b/source/Standard.hs new file mode 100644 --- /dev/null +++ b/source/Standard.hs @@ -0,0 +1,117 @@ +module Standard( benchmarks ) where +import Prelude hiding ( catch ) +import Control.Exception +import System.FilePath +import Shellish +import Benchmark hiding ( darcs ) +import Definitions +import Control.Monad( forM_, filterM, when ) +import Control.Monad.Trans( liftIO ) +import qualified Control.Monad.State as MS + +check :: BenchmarkCmd () +check darcs _ = do + cd "repo" + darcs [ "check", "--no-test" ] + return () + +repair :: BenchmarkCmd () +repair darcs _ = do + cd "repo" + darcs [ "repair" ] + return () + +annotate :: BenchmarkCmd () +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 ] + return () + where files = maybe id (:) (trAnnotate tr) [ "Setup.hs", "Setup.lhs" ] + +get :: [String] -> BenchmarkCmd () +get param darcs _ = do + darcs $ "get" : param ++ ["repo", "get"] + return () + +pull :: Int -> BenchmarkCmd () +pull n darcs _ = do + cd "repo" + rm_f "_darcs/patches/unrevert" + darcs [ "obliterate", "--last", show n, "--all" ] + reset -- the benchmark starts here + darcs [ "pull", "--all" ] + return () + +darcs_wh :: [String] -> BenchmarkCmd () +darcs_wh param darcs _ = (darcs ("whatsnew" : param) >> return ()) `catch_sh` handle + where handle (RunFailed _ 1 _) = return () + handle e = throw e + +wh :: BenchmarkCmd () +wh darcs tr = do + cd "repo" + darcs_wh [] darcs tr + return () + +wh_mod :: BenchmarkCmd () +wh_mod darcs tr = do + cd "repo" + files <- filterM test_f =<< ls "." + when (null files) $ fail "no files to modify in repo root!" + forM_ files $ \f -> mv f $ f <.> "__foo__" + darcs_wh [] darcs tr + forM_ files $ \f -> mv (f <.> "__foo__") f + return () + +wh_l :: BenchmarkCmd () +wh_l darcs tr = do + cd "repo" + darcs_wh [ "--look-for-adds" ] darcs tr + return () + +-- | n patches for each file +record :: BenchmarkCmd () +record darcs _ = do + cd "repo" + files <- filterM test_f =<< ls "." + forM_ files $ \f -> liftIO (appendFile f "x") + darcs [ "record", "--author", "bench ", "--all", "-m", "test record", "--no-test"] + darcs [ "obliterate", "--last", "1", "--all" ] + return () + +revert :: BenchmarkCmd () +revert darcs _ = do + cd "repo" + files <- filterM test_f =<< ls "." + forM_ files $ \f -> liftIO (appendFile f "foo") + darcs [ "revert", "--all" ] + return () + +revert_unrevert :: BenchmarkCmd () +revert_unrevert darcs _ = do + cd "repo" + files <- filterM test_f =<< ls "." + forM_ files $ \f -> liftIO (appendFile f (show "foo")) + darcs [ "revert", "--all" ] + darcs [ "unrevert", "--all" ] + darcs [ "revert", "--all" ] + return () + +benchmarks :: [ Benchmark () ] +benchmarks = + [ Idempotent "wh" FastB wh + , Idempotent "wh mod" FastB wh_mod + , Idempotent "wh -l" FastB wh_l + , Idempotent "record" FastB $ record + , Idempotent "revert" FastB revert + , Idempotent "(un)revert" 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 + ] diff --git a/source/TabularRST.hs b/source/TabularRST.hs new file mode 100644 --- /dev/null +++ b/source/TabularRST.hs @@ -0,0 +1,70 @@ +module TabularRST where + +import Data.List (intersperse, transpose) +import Text.Tabular + +-- RST renderer for tabular +-- (being incubated; when this matures, it should become part of tabular) + +-- | for simplicity, we assume that each cell is rendered +-- on a single line +render :: (rh -> String) + -> (ch -> String) + -> (a -> String) + -> Table rh ch a + -> String +render fr fc f (Table rh ch cells) = + unlines $ [ bar DoubleLine + , renderColumns sizes ch2 + , bar DoubleLine + ] ++ + (renderRs $ fmap renderR $ zipHeader [] cells $ fmap fr rh) ++ + [ bar DoubleLine, "" ] -- note the extra blank line + where + bar = concat . renderTHLine sizes ch2 + renderTHLine _ _ NoLine = [] + renderTHLine w h SingleLine = [renderHLine' w '-' h] + renderTHLine w h DoubleLine = [renderHLine' w '=' h] + -- ch2 and cell2 include the row and column labels + ch2 = Group DoubleLine [Header "", fmap fc ch] + cells2 = headerContents ch2 + : zipWith (\h cs -> h : map f cs) rhStrings cells + -- + renderR (cs,h) = renderColumns sizes $ Group DoubleLine + [ Header h + , fmap fst $ zipHeader "" (map f cs) ch] + rhStrings = map fr $ headerContents rh + -- maximum width for each column + sizes = map (maximum . map length) . transpose $ cells2 + renderRs (Header s) = [s] + renderRs (Group p hs) = concat . intersperse sep . map renderRs $ hs + where sep = renderHLine sizes ch2 p + +-- | We stop rendering on the shortest list! +renderColumns :: [Int] -- ^ max width for each column + -> Header String + -> String +renderColumns is h = coreLine + where + coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h + helper = either hsep (uncurry padLeft) + hsep :: Properties -> String + hsep _ = " " + +renderHLine :: [Int] -- ^ width specifications + -> Header String + -> Properties + -> [String] +renderHLine _ _ _ = [] + +renderHLine' :: [Int] -> Char -> Header String -> String +renderHLine' is sep h = coreLine + where + coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h + helper = either vsep dashes + dashes (i,_) = replicate i sep + vsep _ = " " + +padLeft :: Int -> String -> String +padLeft l s = padding ++ s + where padding = replicate (l - length s) ' ' diff --git a/source/main.hs b/source/main.hs new file mode 100644 --- /dev/null +++ b/source/main.hs @@ -0,0 +1,146 @@ +#!/usr/bin/env runhaskell +import Shellish( shellish, rm_rf ) +import Control.Arrow ( first, second ) +import System.Console.CmdArgs +import System.Cmd ( system ) +import System.Exit +import System.Directory +import System.IO +import Control.Monad +import Control.Monad.Trans +import Benchmark +import Config (Config(Get,Run,Dist,Report)) +import Definitions +import qualified Config as C +import Report +import Run +import Standard +import Dist ( createTarball ) +import Download +import Data.List +import Data.Version ( showVersion ) +import Paths_darcs_benchmark +import Text.JSON +import Data.IORef + +help :: String +help = unlines [ "darcs-benchmark " ++ showVersion version ++ ": run standard darcs benchmarks" + , "" + , "Please either specify the repositories and binaries to run on like this:" + , "$ darcs-benchmark run [binary] [/ [repository] [repository]]" + , "" + , "or alternatively, to run on all available repos:" + , "$ darcs-benchmark run [binary]" + , "" + , "You can also create a file called 'config' in the working directory." + , "Put two lines in it, one with list of binaries, one with list of repos:" + , "" + , "binary binary binary" + , "repo repo repo" + , "" + , "(again, if the second line is not there, we run on all available repos)" + , "" + , "Thank you for benchmarking darcs!" ] + +known_repos :: [String] +known_repos = [ "tabular", "tahoe-lafs", "darcs", "ghc-hashed" ] + +download_repos :: [String] -> IO () +download_repos r = forM_ (if null r then known_repos else r) download + +doVMFlush :: FilePath -> IO () +doVMFlush path = do system "sudo sh -c 'echo 3 > /proc/sys/vm/drop_caches'" + system $ path ++ " --version > /dev/null" + return () + +config :: [TestRepo] -> C.Config -> IO ([(TestRepo,[Benchmark ()])], [String]) +config allrepos cfg = do + case cfg of + Get {} -> do + download_repos (C.repos cfg) + exitWith ExitSuccess + 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" + else return [] + let confrepos = if length conf > 1 then (words $ conf !! 1) else [] + confbins = if length conf > 0 then words $ conf !! 0 else [] + (bins,repos) = second (drop 1) $ break (== "/") (C.extra cfg) + userepos = if null repos then confrepos else repos + usebins = if null bins then confbins else bins + 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' + let setParams p = p { pFlush = if C.cold cfg then Just doVMFlush else Nothing } + modifyIORef global (first setParams) + filterTests <- if C.converge cfg + then do pstampPath <- (paramStampPath . fst) `fmap` readIORef global + ts <- readTimingsForParams pstampPath + return $ \r bs -> case lookup (trCoreName r) (sufficientData ts) of + Nothing -> bs + Just xs -> filter (\b -> not (description b `elem` xs)) bs + else return (const id) + when (null usebins) $ do + hPutStrLn stderr "Please specify at least one darcs binary to benchmark" + exitWith (ExitFailure 1) + let finalrepos = if null userepos then allrepos + else filter (\r -> any (matchRepo r) userepos) allrepos + finalbins = usebins + return ( map (\r -> (r, filterTests r usetests)) finalrepos + , finalbins + ) + where + dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x + matchRepo tr x = trName tr == x || dropPrefix "repo." (trPath tr) == x + +testRepoFromDir :: String -> TestRepo +testRepoFromDir d = TestRepo n n d Nothing [toVariant DefaultVariant] [] + where + n = drop (length "repo.") d + +main :: IO () +main = do + cfg <- cmdArgs help C.defaultConfig + allrepos <- do listing <- getDirectoryContents "." + configs <- mapM readC $ + filter ((/='~') . last) $ + filter ("config." `isPrefixOf`) listing + let other = [ testRepoFromDir d | d <- listing + , "repo." `isPrefixOf` d + , d `notElem` map trPath configs ] + return (configs ++ other) + (reposNtests, binaries') <- config allrepos cfg + let repos = map fst reposNtests + unless (null $ repos \\ allrepos) $ do + let name r = intercalate ", " $ map trName r + putStrLn $ "Missing repositories: " ++ name (repos \\ allrepos) + exitWith $ ExitFailure 2 + binaries <- forM binaries' check_vcs + mapM_ appendBinary binaries + when (null repos) $ do + putStrLn $ "Oops, no repositories! Consider doing a darcs-benchmark get." + putStrLn $ "(Alternatively, check that you are in the right directory.)" + exitWith $ ExitFailure 3 + shellish $ do rm_rf "_playground" + -- for setting up variants, we probably want the latest/greatest + -- version of darcs in case the variant involves some new feature + case reverse binaries of + [] -> return () + (b:_) -> setupVariants repos b + res <- benchMany reposNtests binaries + if C.dump cfg + then liftIO $ print res + else renderMany res + where + readC f = + do mj <- (resultToEither . decode) `fmap` readFile f + case mj of + Left e -> fail $ "Could not read " ++ f ++ ": " ++ show e + Right j -> return $ j