{-# OPTIONS_GHC -cpp #-} ----------------------------------------------------------------------------- -- | -- Module : Bench.hs -- Copyright : (c) Don Stewart 2007 -- License : BSD3-style (see LICENSE) -- -- Maintainer : dons@cse.unsw.edu.au -- Stability : unstable -- ----------------------------------------------------------------------------- -- -- The main benchmarking program -- Compiles and runs programs, measures things about them. -- Dumps raw data to .db files, to be later processed by , e.g. -- gen-report.hs -- import System.IO import System.Environment import System.Cmd import System.Directory import Control.Monad import Control.Exception import Text.Printf import Data.Map (Map) import qualified Data.Map as M import Data.List import qualified Data.ByteString as S import System.IO.Unsafe import System.Exit import System.Process #if !defined(mingw32_HOST_OS) import System.Posix.Process import System.Posix.Unistd #else import System.Time #endif import Results -- contains shared datatypes: Results, Error, Version ------------------------------------------------------------------------ #if !defined(mingw32_HOST_OS) get_child_time = do tm <- getProcessTimes dv <- getSysVar ClockTick return (fromIntegral (fromEnum $ childUserTime tm) / (fromIntegral dv)) #else get_child_time = do TOD x y <- getClockTime return (fromInteger x + fromInteger y / 1000000000000) #endif main = do (category:test:title:mk:url:junkf:bins) <- getArgs junk <- S.readFile junkf let make = makeit mk ts <- forM bins $ \bin -> do let abort s = return (bin, Left s) let actual = test ++ "." ++ bin ++ ".actual" expected = test ++ "." ++ "expected" comp = bin ++ ".compile" status = bin ++ ".status" ------------------------------------------------------------------------ -- compile: a <- make $ "compile-" ++ bin if a /= ExitSuccess then do s <- handle (const $ return []) (readFile comp) let ls = filter (not.null) $ lines s ex = filter ("ERROR" `isPrefixOf`) ls abort $ CompileError $ show (if null ls then "" else head ls ++ concat ex ++ last ls) ------------------------------------------------------------------------ -- run else do -- extract binary sizes size <- runall $ "size " ++ test let s = printf "%s %s binary size:\n%s" test bin size writeFile (test ++ "-" ++ bin ++ ".sz") s dirtyCache junk -- does this do anything? dirtyCache junk dirtyCache junk (b,v) <- time $ make $ "run-" ++ bin if b /= ExitSuccess then do v <- handle (const (return "1")) (readFile status) >>= readIO case v of 99 -> abort TimeoutError _ -> do s <- readFile actual let ls = filter (not.null) $ lines s ex = filter ("ERROR" `isPrefixOf`) ls -- could check if "stack overflow" is element, and return better errors abort $ RuntimeError $ show (if null ls then "" else head ls ++ concat ex ++ last ls) ------------------------------------------------------------------------ -- diff else do diff <- run $ "diff -u " ++ expected ++ " " ++ actual if null diff then return (bin, Right v) else abort $ DiffError diff let sorted = sortBy sndEither ts -- dump structure into file. let h = stdout let db = test ++ ".db" let test_url = printf "%s/%s/%s" url category test ------------------------------------------------------------------------ -- write raw data structure -- -- logging results. -- check if there's an existing .db file -- attempt to read it -- merge across any new results here -- write the merged result out. -- old_results <- handle (const $ return []) $ do s <- readFile db let v = read s v `seq` return (results v) -- merge the old results, overwriting any updated in the new list let numbers = M.fromList (old_results ++ sorted) unique_results = M.toList numbers when (not (null old_results)) $ putStrLn $ "Updating results database with " ++ show (length sorted) ++ " new entries." -- write the new set of results to disk. writeFile (test ++ ".db") (show $ Results category test_url test unique_results) ------------------------------------------------------------------------ -- logging only: -- hPrintf h "\nTest: %s (%s)\n" test title hPrintf h "%s\n" test_url let draw (Right best) compiler (Right t) = hPrintf h "%-20s %-4.2f %10s %10s (%3.1f x)\n" compiler t "seconds" "" (t / best) draw _ compiler (Left e) = hPrintf h "%-20s %s\n" compiler (show e) draw _ compiler (Right t) = hPrintf h "%-20s %-4.2f %10s %10s\n" compiler t "seconds" "" mapM_ (uncurry (draw (snd $ head unique_results))) unique_results putChar '\n' system $ "cat *ghc.sz" putChar '\n' system $ "cat *old.sz" -- check for fusion putChar '\n' system $ "grep 'fold/build' ghc-old.compile" system $ "grep STREAM ghc.compile" system $ "grep 'fold/build' ghc.compile" ------------------------------------------------------------------------ sndEither (_,Right a) (_,Right b) = a `compare` b sndEither (_,Left a) (_,Right b) = GT sndEither (_,Right a) (_,Left b) = LT sndEither _ _ = EQ -- -- time a computation -- -- time :: IO t -> IO Double time a = do start <- get_child_time x <- a x `seq` do end <- get_child_time return (x, end - start) ------------------------------------------------------------------------ makeit mk s = system $ printf "%s %s" mk s ------------------------------------------------------------------------ dirtyCache x = evaluate (S.foldl1' (+) x) {-# NOINLINE dirtyCache #-} ------------------------------------------------------------------------ run s = do (ih,oh,eh,pid) <- runInteractiveCommand s hClose ih so <- hGetContents oh se <- hGetContents eh map length [so,se] `seq` return () return $ let s = lines (so ++ se) in if null s then [] else head s runall s = do (ih,oh,eh,pid) <- runInteractiveCommand s hClose ih so <- hGetContents oh se <- hGetContents eh map length [so,se] `seq` return () return $ let s = so ++ se in if null s then [] else s