diff --git a/FindBench.hs b/FindBench.hs new file mode 100644 --- /dev/null +++ b/FindBench.hs @@ -0,0 +1,174 @@ +module FindBench(findLocalBenchmarks) where +--module Main where + +import Control.Exception +import Control.Monad (filterM, when, liftM) +import Data.List +import System.Directory +import System.FilePath +import System.IO + +{- +-- for standalone testing +main = do + findLocalBenchmarks "benchmarks" +-} + +benchmarksModule = ["Fibon", "Benchmarks"] +benchmarksInstanceModule = "Fibon.Instance" + +findLocalBenchmarks :: FilePath -> IO () +findLocalBenchmarks baseDir = do + let searchPath = join ([pathSeparator]) (baseDir : benchmarksModule) + putStr $ "Looking for benchmarks in "++searchPath + groups <- sort `liftM` bmGroups searchPath + bms <- bmInstances searchPath groups + let allBms = (sort . concat) bms + qualifiedBms = + concat $ zipWith (\g bs -> map ((,)g) (sort bs)) groups bms + outFile = searchPath ++ ".hs" + when (null groups) printNoBenchmarksWarning + putStrLn $ "... found ("++ (show.length$ allBms)++")" + putStrLn $ " writing benchmark manifest to "++outFile + createDirectoryIfMissing True (baseDir "Fibon") + h <- openFile outFile WriteMode + hPutStrLn h moduleHeader + hPutStrLn h $ moduleImports (join "." benchmarksModule) qualifiedBms + hPutStrLn h "" + hPutStrLn h $ benchDataDecl allBms + hPutStrLn h "" + hPutStrLn h $ groupDataDecl groups + hPutStrLn h "" + hPutStrLn h $ allBenchmarksDecl allBms + hPutStrLn h "" + hPutStrLn h $ benchGroupDecl qualifiedBms + hPutStrLn h "" + hPutStrLn h $ benchInstanceDecl qualifiedBms + hPutStrLn h "" + hPutStrLn h $ benchPathDecl qualifiedBms + hClose h + +bmGroups :: FilePath -> IO [FilePath] +bmGroups baseDir = do + dirs <- try (getDirectoryContents baseDir) :: IO (Either IOError [FilePath]) + case dirs of + Left _ -> return [] + Right ds -> removeBadEntries baseDir ds + +bmInstances :: FilePath -> [FilePath] -> IO [[String]] +bmInstances baseDir groups = do + let paths = map (baseDir ) groups + bms <- mapM getDirectoryContents paths + mapM (\(p, bm) -> removeBadEntries p bm) (zip paths bms) + +removeDotFiles :: [FilePath] -> [FilePath] +removeDotFiles = filter (\d -> not ("." `isPrefixOf` d)) + +removeBadEntries :: FilePath -> [FilePath] -> IO [FilePath] +removeBadEntries baseDir dirs = do + let paths = map (baseDir ) dirs + noFiles <- filterM (\d -> doesDirectoryExist (baseDir d)) dirs + let noUnderscores = filter (\d -> not ("_" `isPrefixOf` d)) noFiles + return (removeDotFiles noUnderscores) + +moduleHeader :: String +moduleHeader = join "\n" [ + "module "++modName++" (", + " FibonBenchmark(..)", + " , FibonGroup(..)", + " , allBenchmarks", + " , benchGroup", + " , benchInstance", + " , benchPath", + ")", + "where", + "import Fibon.InputSize", + "import Fibon.BenchmarkInstance", + "import System.FilePath" + ] + where + modName = join "." benchmarksModule + +moduleImports :: String -> [(String, String)] -> String +moduleImports baseMod bms = join "\n" imports + where + imports = map importStmt bms + importStmt (g,bm) = + "import qualified " + ++baseMod++"."++g++"."++bm++"."++benchmarksInstanceModule + ++" as "++(importAs g bm) + +importAs :: String -> String -> String +importAs _grp modu = modu ++ "_bm" + +groupName :: String -> String +groupName g = g + +benchDataDecl :: [String] -> String +benchDataDecl bms = "data FibonBenchmark = " ++ datas bms ++ derivings + where derivings = "\n deriving(Read, Show, Eq, Ord, Enum)" + datas [] = "NoBenchmarksFound" + datas bms = "\n " ++ (join ("\n | ") bms) + +groupDataDecl :: [String] -> String +groupDataDecl grps = "data FibonGroup = " ++ datas grps ++ derivings + where derivings = "\n deriving(Read, Show, Eq, Ord, Enum)" + datas [] = "NoGroupsFound" + datas grps = "\n "++ (join ("\n | ") (map groupName grps)) + +allBenchmarksDecl :: [String] -> String +allBenchmarksDecl bms = + "allBenchmarks :: [FibonBenchmark]\n"++ + "allBenchmarks = [\n "++ + (join ("\n , ") bms) ++ + "\n ]" + +benchGroupDecl :: [(String, String)] -> String +benchGroupDecl [] = benchGroupTypeDecl ++ "benchGroup = "++ emptyError +benchGroupDecl qBms = benchGroupTypeDecl ++ (join ("\n") $ map defn qBms) + where + defn (g,bm) = "benchGroup " ++ bm ++ " = " ++ (groupName g) + +benchGroupTypeDecl :: String +benchGroupTypeDecl = "benchGroup :: FibonBenchmark -> FibonGroup\n" + +benchInstanceDecl :: [(String, String)] -> String +benchInstanceDecl [] = benchInstanceTypeDecl ++ "benchInstance = "++ emptyError +benchInstanceDecl qBms = benchInstanceTypeDecl ++ (join ("\n") $ map defn qBms) + where + defn (g,bm) = + "benchInstance " ++ bm ++ " = " ++ (importAs g bm) ++ ".mkInstance" + +benchInstanceTypeDecl :: String +benchInstanceTypeDecl = + "benchInstance :: FibonBenchmark -> InputSize -> BenchmarkInstance\n" + +benchPathDecl :: [(String, String)] -> String +benchPathDecl [] = benchPathTypeDecl ++ "benchPath = " ++ emptyError +benchPathDecl qBms = benchPathTypeDecl ++ (join ("\n") $ map defn qBms) + where + defn (g,bm) = "benchPath " ++ bm ++ " = " ++ s g ++ " " ++ s bm + s x = "\"" ++ x ++"\"" + +benchPathTypeDecl :: String +benchPathTypeDecl = "benchPath :: FibonBenchmark -> FilePath\n" + +join :: String -> [String] -> String +join s ss = concat (intersperse s ss) + +emptyError :: String +emptyError = "error \"No benchmarks found. Need to re-run cabal config step\"" + +printNoBenchmarksWarning :: IO () +printNoBenchmarksWarning = do + putStrLn "\n" + putStrLn banner + putStrLn $cap("! No benchmarks found.") + putStrLn $cap("! You will not be able to run collect results with fibon-run") + putStrLn banner + putStrLn "" + where + banner = line++"WARNING"++line + line = take 30 (repeat '-') + cap s = s ++ take ((length banner) - (length s) - 1) (repeat ' ') ++ "!" + diff --git a/FindConfig.hs b/FindConfig.hs new file mode 100644 --- /dev/null +++ b/FindConfig.hs @@ -0,0 +1,38 @@ +module FindConfig(findLocalConfigs, localConfigsFileName) where +import Data.List +import System.Directory +import System.FilePath +import System.IO + +findLocalConfigs :: FilePath -> IO () +findLocalConfigs cDir = do + fs <- getDirectoryContents cDir + putStr "\nLooking for local configuration modules... " + let modNames = map dropExtension $ filter (".hs" `isSuffixOf`) fs + let imports = map importStmt $ modNames + let modules = map importAs $ modNames + putStrLn $ "found ("++ (show.length$ modNames)++")" + writeToFile (localConfigsFileName cDir) (imports ++ [modulesList modules]) + where + importStmt m = "import qualified "++m++" as " ++importAs m + writeToFile fName contents = do + h <- openFile fName WriteMode + putStrLn $ " writing config manifest to " ++ fName + --putStrLn $ unlines contents + hPutStr h (unlines contents) + hClose h + +modulesList :: [String] -> String +modulesList mods = typ ++ lst + where + typ = "localConfigs :: [RunConfig]\n" + lst = "localConfigs = [" ++ (join ", " cfgs) ++ "]" + cfgs = map (++".config") mods + join s = concat . intersperse s + +importAs :: String -> String +importAs modName = modName++"_Config" + +localConfigsFileName :: FilePath -> FilePath +localConfigsFileName baseDir = baseDir "LocalConfigs.txt" + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright David M Peixotto 2010 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of David M Peixotto nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,133 @@ +Fibon in a Flash +=================================================================== + $ git clone git://github.com/dmpots/fibon.git + $ cd fibon + $ git submodule update --init benchmarks + $ cabal configure && cabal build + $ ./dist/build/fibon-run/fibon-run + +Introduction +=================================================================== +Fibon is a set of tools for running and analysing benchmarks in +Haskell. Most importantly, it includes a set of default benchmarks +taken from the [Hackage][1] open source repository. + +Benchmarks +------------------ +Fibon makes it easy to use either the fibon benchmarks or your own +set of benchmarks. Benchmarks are stored in the +`benchmarks/Fibon/Benchmarks` directory. This directory is setup as +a [git submodule][2] which means you can easily grab the standard +suite or use a suite kept under your own source control. + +Benchmark Groups +------------------ +Benchamarks named and organized into groups based on the filesystem +organization. For example, a benchmark in the directory +`benchmarks/Fibon/Benchmarks/Hackage/Agum` will have the name `Agum` +an be in the benchmark group `Hackage`. + +Executables +------------------ +The fibon package builds three tools + 1. `fibon-run` - runs the benchmarks + 2. `fibon-analyze` - analyzes the results of a run + 2. `fibon-init` - utilty used when adding new benchmarks + +Size and Tune +------------------ +Fibon benchmarks can be run with two different input sizes: `Test` and +`Ref`. The `Test` size is useful to make sure that a benchmark can +run successsfully, but will not give meaningful timings. + +Fibon benchmarks can be run under two different tune settings (e.g. +compiler optimization settings). The `Base` and `Peak` settings can +be configured anyway you want to make the desired comparison. + +Directory Structure +-------------------- +Source directories + ./benchmarks -- benchmark code + ./config -- config files + ./lib -- common files used by several executables + ./tools -- source code for executables + +Working directories + ./log -- logging output from benchmark runs + ./run -- working directory for benchmark runs + +Getting the Benchmarks +=================================================================== +The benchmarks are kept in a separate repository as a [git +submodule][2]. You can get the fibon benchmarks by updating the +submodule from within your fibon working directory + + $ git submodule update --init benchmarks + +This will checkout the benchmarks from the fibon-benchmarks +repository and place them in your working copy. + +Running Benchmarks +=================================================================== +The available benchmarks and configurations are discovered when the +fibon package is configured. Benchmarks are searched for in the +`benchmarks/Fibon/Benchmarks` directory and configuration files are +searched for in the `config` directory. If a configuration file or +benchmark is added, you will need to re-run `cabal configure` to +make them available to the fibon-run tool. + +Configuration +--------------- +Fibon comes with a default configuration. The default configuration +will run all benchmarks with the `Base` setting of `-O0` and a +`Peak` setting of `-O2` on the `Ref` size. A configuration file can +be used to specify more complicated configurations. + +You can get some example configuration by doing + $ git submodule update --init config + +This will checkout a repository of config files. Note that currently +these files contain some user and machine-specific configurations, +but should be a useful starting point. + +You can also selectively run benchmarks, groups, sizes, and tune +settings as described below. + +Running +--------------- +Benchamarks are run with the `fibon-run` tool. Running `fibon-run` +with no arguments will use the default config file. An alternate +config file can be specified with the `-c` flag. Also, you can give +a list of benchmarks or groups to run on the command line. Use +`--help` to see a full list of options. + +Running the benchmarks will produce some logging to standard out and +create four output files in the `log` directory. + + 1. `*.LOG` - the full log of the run + 1. `*.SUMMARY` - the mean runtimes of each benchmark + 1. `*.RESULTS` - the full results (passed to `fibon-analyse`) + +Analyzing Benchmark Results +=================================================================== +Benchmarks can be analyzed by the `fibon-analyse` tool. + + $ fibon-analyse log/000.default.RESULTS + +Adding New Benchmarks +=================================================================== +TODO + +Benchmark Notes +=================================================================== +Ghc610 + ChameneosRedux + Does not work with -O0. Gets "thread blocked indefinitely" + exception + + Mandelbrot + The Test size gives different result, but the Ref size is ok. + Think it is just some kind of floating point wibbles. + +[1]: http://hackage.haskell.org +[2]: http://www.kernel.org/pub/software/scm/git/docs/user-manual.html#submodules diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,34 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +import Distribution.PackageDescription +import Control.Monad +import System.Directory +import FindBench +import FindConfig + +main = defaultMainWithHooks simpleUserHooks { + preConf = createConfDir + , postConf = writeLocalConf + , postClean = deleteLocalConf} + +createConfDir _ _ = do + e <- doesDirectoryExist configDir + unless e (createDirectory configDir) + return emptyHookedBuildInfo + +writeLocalConf _ _ _ _ = do + findLocalConfigs configDir + findLocalBenchmarks benchmarkDir + +deleteLocalConf _ _ _ _ = do + deleteIfExists (localConfigsFileName configDir) + +deleteIfExists :: FilePath -> IO () +deleteIfExists f = do + e <- doesFileExist f + when e (removeFile f) + + +configDir, benchmarkDir :: FilePath +configDir = "config" +benchmarkDir = "benchmarks" diff --git a/fibon.cabal b/fibon.cabal new file mode 100644 --- /dev/null +++ b/fibon.cabal @@ -0,0 +1,127 @@ +-- The name of the package. +Name: fibon +Version: 0.1.0 +Synopsis: A reworking of the classic nofib benchmark suite +Description: + Fibon is a set of tools for running and analyzing benchmark programs. + The fibon package contains the tools for benchmarking, but not the + benchmarks themselves. The package will build, but will not have any + benchmarks to run. A set of benchmarks can be found at + + http://github.com/dmpots/fibon-benchmarks + + Installing the cabal package will get you the following tools + + * fibon - runs the benchmarks + * fibon-analyse - analyses the results of a benchmark run + * fibon-init - generate a benchmark description from a cabal file + + See http://github.com/dmpots/fibon/wiki for more details +License: BSD3 +License-file: LICENSE +Author: David M Peixotto +Maintainer: dmp@rice.edu +Stability: Experimental +Category: Benchmarking +Homepage: http://github.com/dmpots/fibon/wiki +Bug-reports: http://github.com/dmpots/fibon/issues +Build-type: Custom +Cabal-version: >=1.8 + +Extra-source-files: README + FindBench.hs + FindConfig.hs + lib/Fibon/BenchmarkInstance.hs + lib/Fibon/ConfigMonad.hs + lib/Fibon/FlagConfig.hs + lib/Fibon/InputSize.hs + lib/Fibon/Result.hs + lib/Fibon/Timeout.hs + tools/fibon-analyse/Fibon/Analyse/AnalysisRoutines.hs + tools/fibon-analyse/Fibon/Analyse/Analysis.hs + tools/fibon-analyse/Fibon/Analyse/CommandLine.hs + tools/fibon-analyse/Fibon/Analyse/ExtraStats/GhcStats.hs + tools/fibon-analyse/Fibon/Analyse/ExtraStats.hs + tools/fibon-analyse/Fibon/Analyse/Main.hs + tools/fibon-analyse/Fibon/Analyse/Metrics.hs + tools/fibon-analyse/Fibon/Analyse/Output.hs + tools/fibon-analyse/Fibon/Analyse/Parse.hs + tools/fibon-analyse/Fibon/Analyse/Result.hs + tools/fibon-analyse/Fibon/Analyse/Tables.hs + tools/fibon-init/Main.hs + tools/fibon-run/Fibon/Run/Actions.hs + tools/fibon-run/Fibon/Run/BenchmarkBundle.hs + tools/fibon-run/Fibon/Run/BenchmarkRunner.hs + tools/fibon-run/Fibon/Run/CommandLine.hs + tools/fibon-run/Fibon/Run/Config/Default.hs + tools/fibon-run/Fibon/Run/Config/Local.hs + tools/fibon-run/Fibon/Run/Config.hs + tools/fibon-run/Fibon/Run/Log.hs + tools/fibon-run/Fibon/Run/Main.hs + tools/fibon-run/Fibon/Run/Manifest.hs + tools/fibon-run/Fibon/Run/SysTools.hs + +source-repository head + type: git + location: git://github.com/dmpots/fibon.git + +source-repository this + type: git + location: git://github.com/dmpots/fibon.git + tag: v0.1.0 + +Flag analyse + description: Build the fibon-analyse program + default: True + +Executable fibon-run + main-is: Fibon/Run/Main.hs + ghc-options: -Wall -threaded + include-dirs: config + hs-source-dirs: tools/fibon-run + lib + benchmarks + config + build-depends: base >= 4 && < 5 + , containers + , mtl == 1.1.* + , directory == 1.0.* + , filepath == 1.1.* + , hslogger == 1.0.* + , process == 1.0.* + , time == 1.1.* + , old-locale == 1.0.* + , statistics == 0.6.* + , vector == 0.6.* +-- other-modules: Fibon.Benchmarks + +Executable fibon-init + main-is: Main.hs + ghc-options: -Wall + hs-source-dirs: tools/fibon-init + build-depends: base >= 4 && < 5 + , filepath == 1.1.* + , directory == 1.0.* + , Cabal == 1.8.* + +Executable fibon-analyse + if (flag(analyse)) + buildable: True + else + buildable: False + main-is: Fibon/Analyse/Main.hs + ghc-options: -Wall + hs-source-dirs: tools/fibon-analyse, lib + if (flag(analyse)) + build-depends: base >= 4 && < 5 + , containers + , mtl == 1.1.* + , filepath == 1.1.* + , bytestring == 0.9.* + , text == 0.8.* + , tabular == 0.2.* + , vector == 0.6.* + , statistics == 0.6.* + extensions: CPP + + diff --git a/lib/Fibon/BenchmarkInstance.hs b/lib/Fibon/BenchmarkInstance.hs new file mode 100644 --- /dev/null +++ b/lib/Fibon/BenchmarkInstance.hs @@ -0,0 +1,32 @@ +module Fibon.BenchmarkInstance( + BenchmarkInstance(..) + , OutputDestination(..) + , ValidationOption(..) + , OutputDescription + , Fibon.FlagConfig.FlagConfig(..) + , Fibon.InputSize.InputSize(..) +) +where +import Fibon.FlagConfig +import Fibon.InputSize + +data OutputDestination = + OutputFile String + | Stdout + | Stderr + deriving(Eq, Show, Ord) + +data ValidationOption = + Diff {expectedOutput :: FilePath} + | Exists + deriving(Eq, Show, Ord) + +type OutputDescription = (OutputDestination, ValidationOption) + +data BenchmarkInstance = BenchmarkInstance { + flagConfig :: FlagConfig + , stdinInput :: Maybe FilePath + , output :: [OutputDescription] + , exeName :: String + } deriving (Show) + diff --git a/lib/Fibon/ConfigMonad.hs b/lib/Fibon/ConfigMonad.hs new file mode 100644 --- /dev/null +++ b/lib/Fibon/ConfigMonad.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Fibon.ConfigMonad ( + FlagParameter(..) + , FlagConfig(..) + , Configuration + , ConfigState(..) + , ConfigMonad + , done + , append + , replace + , setTimeout + , runWithInitialFlags + , collectExtraStatsFrom + , noExtraStats + , useGhcDir + , useGhcInPlaceDir +) +where + +import Control.Monad.State +import qualified Data.Map as Map +import Fibon.FlagConfig +import Fibon.Timeout +import System.FilePath + +data FlagParameter = + ConfigureFlags + | BuildFlags + | RunFlags + deriving (Show, Eq, Ord, Enum) + +newtype GenConfigMonad a = CM { + configState :: (State (ConfigState ConfigMap) a) + } + deriving (Monad) + +data ConfigState a = ConfigState { + flags :: a + , limit :: Timeout + , extraStatsFile :: Maybe FilePath + } +type ConfigMap = Map.Map FlagParameter [String] +type ConfigMonad = GenConfigMonad () +type Configuration = ConfigState FlagConfig + +done :: ConfigMonad +done = CM (return ()) + +replace :: FlagParameter -> String -> ConfigMonad +replace p f = do + CM $ modify $ (\c -> c {flags = Map.insert p [f] (flags c)}) + +append :: FlagParameter -> String -> ConfigMonad +append p f = do + CM $ modify $ (\c -> c {flags = Map.insertWith (flip (++)) p as (flags c)}) + where as = words f + +setTimeout :: Timeout -> ConfigMonad +setTimeout t = do + CM $ modify $ (\c -> c {limit = t}) + +collectExtraStatsFrom :: FilePath -> ConfigMonad +collectExtraStatsFrom f = do + CM $ modify $ (\c -> c {extraStatsFile = Just f}) + +noExtraStats :: ConfigMonad +noExtraStats = do + CM $ modify $ (\c -> c {extraStatsFile = Nothing}) + +useGhcDir :: FilePath -> ConfigMonad +useGhcDir dir = do + append ConfigureFlags $ "--with-ghc="++(dir "ghc") + append ConfigureFlags $ "--with-ghc-pkg="++(dir "ghc-pkg") + +useGhcInPlaceDir :: FilePath -> ConfigMonad +useGhcInPlaceDir dir = do + append ConfigureFlags $ "--with-ghc="++(dir "ghc-stage2") + append ConfigureFlags $ "--with-ghc-pkg="++(dir "ghc-pkg") + +runWithInitialFlags :: FlagConfig -> ConfigMonad -> Configuration +runWithInitialFlags fc cm = toConfig finalState + where + startState = ConfigState { + flags = fromFlagConfig fc + , limit = Infinity + , extraStatsFile = Nothing + } + finalState = execState (configState cm) startState + +toConfig :: (ConfigState ConfigMap) -> Configuration +toConfig state = state { + flags = + FlagConfig { + configureFlags = Map.findWithDefault [] ConfigureFlags configMap + , buildFlags = Map.findWithDefault [] BuildFlags configMap + , runFlags = Map.findWithDefault [] RunFlags configMap + } + } + where + configMap = flags state + +fromFlagConfig :: FlagConfig -> ConfigMap +fromFlagConfig fc = + Map.insert ConfigureFlags (configureFlags fc) $ + Map.insert BuildFlags (buildFlags fc) $ + Map.insert RunFlags (runFlags fc) $ + Map.empty diff --git a/lib/Fibon/FlagConfig.hs b/lib/Fibon/FlagConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Fibon/FlagConfig.hs @@ -0,0 +1,10 @@ +module Fibon.FlagConfig ( + FlagConfig(..) +) +where + +data FlagConfig = FlagConfig { + configureFlags :: [String] + , buildFlags :: [String] + , runFlags :: [String] + } deriving (Show, Eq, Ord) diff --git a/lib/Fibon/InputSize.hs b/lib/Fibon/InputSize.hs new file mode 100644 --- /dev/null +++ b/lib/Fibon/InputSize.hs @@ -0,0 +1,10 @@ +module Fibon.InputSize( + InputSize(..) +) +where + +data InputSize = + Test + | Ref + deriving(Eq, Read, Show, Ord, Enum) + diff --git a/lib/Fibon/Result.hs b/lib/Fibon/Result.hs new file mode 100644 --- /dev/null +++ b/lib/Fibon/Result.hs @@ -0,0 +1,41 @@ +module Fibon.Result ( + FibonResult(..) + , RunData(..) + , BuildData(..) + , RunSummary(..) + , RunDetail(..) + , ExtraStats +) +where + +data FibonResult = FibonResult { + benchName :: String + , buildData :: BuildData + , runData :: RunData + } deriving(Read, Show) + +data BuildData = BuildData { + buildTime :: Double -- ^ Time to build the program + , buildSize :: String -- ^ Size of the program + } + deriving(Read, Show) + +data RunData = RunData { + summary :: RunSummary + , details :: [RunDetail] + } deriving(Read, Show) + +data RunSummary = RunSummary { + meanTime :: Double + , stdDevTime :: Double + , statsSummary :: ExtraStats + } + deriving (Read, Show) + +data RunDetail = RunDetail {runTime :: Double, runStats :: ExtraStats} + deriving (Read, Show) + +--type ExtraStats = [(String, String)] +type ExtraStats = String + + diff --git a/lib/Fibon/Timeout.hs b/lib/Fibon/Timeout.hs new file mode 100644 --- /dev/null +++ b/lib/Fibon/Timeout.hs @@ -0,0 +1,19 @@ +module Fibon.Timeout( + Timeout(..) + , timeoutToMicroSeconds +) +where + +data Timeout = + Infinity + | Limit {hours :: Int, mins :: Int, secs :: Int} + +timeoutToMicroSeconds :: Timeout -> Maybe Int +timeoutToMicroSeconds Infinity = Nothing +timeoutToMicroSeconds (Limit h m s) = Just $ + (hoursToMicroSeconds h) + (minsToMicroSeconds m) + (secsToMicroSeconds s) + where + hoursToMicroSeconds = (* (36 * 10 ^ (8::Int))) + minsToMicroSeconds = (* (6 * 10 ^ (7::Int))) + secsToMicroSeconds = (* (1 * 10 ^ (6::Int))) + diff --git a/tools/fibon-analyse/Fibon/Analyse/Analysis.hs b/tools/fibon-analyse/Fibon/Analyse/Analysis.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/Analysis.hs @@ -0,0 +1,225 @@ +module Fibon.Analyse.Analysis ( + Analysis(..) + , runAnalysis + , computeRows + , Normalize(..) + , NormMethod +) +where +import Data.List +import Data.Maybe +import qualified Data.Map as M +import Control.Monad.Error +import Fibon.Result +import Fibon.Analyse.AnalysisRoutines +import Fibon.Analyse.Parse +import Fibon.Analyse.Result +import Fibon.Analyse.Metrics +import Fibon.Analyse.Tables +import Statistics.Sample +import qualified Data.Vector.Unboxed as V + +runAnalysis :: Analysis a -> FilePath -> IO (Maybe [ResultColumn a]) +runAnalysis analysis file = do + fibonResults <- parseFibonResults file + case fibonResults of + Nothing -> return Nothing + Just rs -> do x <- createResultColumns analysis rs + return (Just x) + +createResultColumns :: Analysis a + -> M.Map ResultLabel [FibonResult] + -> IO [ResultColumn a] +createResultColumns analysis fibonResults = + mapM (analyseResults analysis) (M.toList fibonResults) + + +analyseResults :: Analysis a + -> (ResultLabel, [FibonResult]) + -> IO (ResultColumn a) +analyseResults analysis (resultName, fibonResults) = do + ars <- mapM (analyseResult analysis) fibonResults + return $ ResultColumn resultName (resMap ars) + where + resMap ars = foldr create M.empty (zip ars fibonResults) + create (ar,fr) m = M.insert (benchNameOnly fr) ar m + benchNameOnly fr = takeWhile (/= '-') (benchName fr) + +analyseResult :: + Analysis a + -> FibonResult + -> IO (AnalyseResult a) -- ^ final result +analyseResult analysis fibonR = do + fibonS <- (fibonAnalysis analysis) fibonR + extraS <- case mbExtras of + Nothing -> return Nothing + Just [] -> return Nothing + Just es -> return . Just =<< (extraAnalysis analysis) es + return (AnalyseResult fibonS extraS) + where + mbExtras = sequence $ map (extraP.runStats) (details.runData $ fibonR) + extraP = extraParser analysis + + +-- | Functions for normalizing and computing summaries of results +-- +-- +type RowData = (RowName, [PerfData]) +type RowName = String +type TableError = String +type PerfMonad = Either TableError +type NormMethod a = ResultColumn a -> Normalize a + +data Normalize a = + NormPercent (ResultColumn a) + | NormRatio (ResultColumn a) + | NormNone (ResultColumn a) -- ^ For uniform normalization use + +computeRows :: [(Normalize a, ResultColumn a)] + -> [BenchName] + -> TableSpec a + -> Either TableError ([RowData], [RowData]) +computeRows resultColumns benchs colSpecs = do + rows <- mapM (computeOneRow resultColumns colSpecs) benchs + let colData = transpose $ map snd rows + doSumm how = mapM (summarize how) colData + minRow <- doSumm Min + meanRow <- doSumm GeoMean + arithRow <- doSumm ArithMean + maxRow <- doSumm Max + let sumRows = [ + ("min", minRow) + , ("geomean", meanRow) + , ("arithmean", arithRow) + , ("max", maxRow) + ] + return (rows, sumRows) + +computeOneRow :: [(Normalize a, ResultColumn a)] + -> [ColSpec a] + -> BenchName + -> PerfMonad RowData +computeOneRow resultColumns colSpecs bench = do + row <- mapM (\spec -> + mapM (computeOneColumn bench spec) resultColumns + ) colSpecs + return (bench, concat row) + +computeOneColumn :: BenchName + -> ColSpec a + -> (Normalize a, ResultColumn a) + -> PerfMonad PerfData +computeOneColumn bench (ColSpec _ metric) (normType, resultColumn) = + maybe (return NoResult) doNormalize (getRawPerf resultColumn) + where + doNormalize peak = + case normType of + NormPercent base -> normToBase base normalizePercent + NormRatio base -> normToBase base normalizeRatio + NormNone _ -> return (mkRaw peak) + where + mkRaw = Basic . Raw + mkNorm = Basic . Norm + normToBase base normFun = maybe (return NoResult) + (\b -> mkNorm `liftM` normFun b peak) + (getRawPerf base) + getRawPerf rc = perf $ fmap metric ((M.lookup bench . results) rc) + +type NormFun a =(a -> Double) -> a -> a -> NormPerf +normalizePercent :: RawPerf -> RawPerf -> PerfMonad NormPerf +normalizePercent = normalize normP + +normalizeRatio :: RawPerf -> RawPerf -> PerfMonad NormPerf +normalizeRatio = normalize normR + +normalize :: NormFun RawPerf + -> RawPerf + -> RawPerf + -> PerfMonad NormPerf +normalize n base@(RawTime _) peak@(RawTime _) = + return(n rawPerfToDouble base peak) +normalize n base@(RawSize _) peak@(RawSize _) = + return(n rawPerfToDouble base peak) +normalize _ _ _ = throwError "Can not normalize a size by time" + +normP :: NormFun a +normP = norm Percent (\base peak -> (peak / base) * 100) + +normR :: NormFun a +normR = norm Ratio (\base peak -> (base / peak)) + +-- TODO: use the intervals to compute the resulting interval +norm :: (Estimate Double -> NormPerf) -- ^ NormPerf constructor + -> (Double -> Double -> Double) -- ^ Normalizing function + -> (a -> Double) -- ^ Conversion to double + -> a -> a -- ^ Values to normalize + -> NormPerf +norm c f toDouble base peak = + c (mkPointEstimate mkStddev (f (toDouble base) (toDouble peak))) + where mkStddev = fromIntegral :: Int -> Double + +summarize :: Summary -> [PerfData] -> PerfMonad PerfData +summarize how perfData = + case (normData, rawData) of + ([], []) -> return NoResult + (nd, []) -> summarizeNorm how nd + ([], rd) -> summarizeRaw how rd + _ -> throwError "Mixed raw and norm results in column" + where + normData = getData (\p -> case p of Basic (Norm n) -> Just n ; _ -> Nothing) + rawData = getData (\p -> case p of Basic (Raw r) -> Just r ; _ -> Nothing) + getData f = (catMaybes . map f) perfData + +summarizeRaw :: Summary -> [RawPerf] -> PerfMonad PerfData +summarizeRaw how rawPerfs = + case (isTime rawPerfs, isSize rawPerfs) of + (True, _) -> summarizeRaw' how ExecTime RawTime rawPerfs + (_, True) -> summarizeRaw' how (MemSize . round) RawSize rawPerfs + _ -> throwError "Can only summarize column with time or size" + where + isTime = all (\r -> case r of RawTime _ -> True; RawSize _ -> False) + isSize = all (\r -> case r of RawSize _ -> True; RawTime _ -> False) + +summarizeRaw' :: Summary -- ^ what kind of summary + -> (Double -> a) -- ^ rounding function + -> (Estimate a -> RawPerf) -- ^ RawPerf constructor + -> [RawPerf] -- ^ Performance numbers to summary + -> PerfMonad PerfData +summarizeRaw' how roundFun makeRaw rawPerfs = + return $ Summary how (Raw (makeRaw (fmap roundFun (computeSummary how vec)))) + where + vec = V.fromList (map rawPerfToDouble rawPerfs) + +summarizeNorm :: Summary -> [NormPerf] -> PerfMonad PerfData +summarizeNorm how normPerfs = + case (isPercent normPerfs, isRatio normPerfs) of + (True, _) -> summarizeNorm' how Percent normPerfs + (_, True) -> summarizeNorm' how Ratio normPerfs + _ -> throwError "Can only summarize column with percent or ratio" + where + isPercent = all (\r -> case r of Percent _ -> True; Ratio _ -> False) + isRatio = all (\r -> case r of Percent _ -> False; Ratio _ -> True) + +summarizeNorm' :: Summary + -> (Estimate Double -> NormPerf) + -> [NormPerf] + -> PerfMonad PerfData +summarizeNorm' how makeNorm normPerfs = + return $ Summary how (Norm (makeNorm (computeSummary how vec))) + where + vec = V.fromList (map normPerfToDouble normPerfs) + +computeSummary :: Summary -> Sample -> Estimate Double +computeSummary summaryType vec = + Estimate { + ePoint = sumF summaryType vec + , eStddev = stdDev vec -- TODO: this is wrong stddev for geoMean + , eSize = V.length vec + , eCI = Nothing + } + where + sumF ArithMean = mean + sumF GeoMean = geometricMean + sumF Max = V.maximum + sumF Min = V.minimum + diff --git a/tools/fibon-analyse/Fibon/Analyse/AnalysisRoutines.hs b/tools/fibon-analyse/Fibon/Analyse/AnalysisRoutines.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/AnalysisRoutines.hs @@ -0,0 +1,41 @@ +module Fibon.Analyse.AnalysisRoutines( + noAnalysis + , ghcStatsAnalysis + , Analysis(..) +) +where + +import Fibon.Result +import Fibon.Analyse.Result +import Fibon.Analyse.Metrics +import Fibon.Analyse.ExtraStats + +data Analysis a = Analysis { + fibonAnalysis :: (FibonResult -> IO FibonStats)-- ^ RunData analyser + , extraParser :: (String -> Maybe a) -- ^ extraStats parser + , extraAnalysis :: ([a] -> IO a) -- ^ extraStats analyser + } + +noAnalysis :: Analysis a +noAnalysis = Analysis { + fibonAnalysis = return . getStats + , extraParser = const Nothing + , extraAnalysis = return . head + } + where + getStats fr = FibonStats { + compileTime = Single $ ExecTime ((buildTime . buildData) fr) + , binarySize = Single $ MemSize 0 + , wallTime = Single $ ExecTime ((meanTime . summary . runData) fr) + } + +ghcStatsAnalysis :: Analysis GhcStats +ghcStatsAnalysis = noAnalysis { + extraParser = parseGhcStats + } + +--makeAnalysis :: Analysis a -> (String -> Maybe b) -> Analysis b + + + + diff --git a/tools/fibon-analyse/Fibon/Analyse/CommandLine.hs b/tools/fibon-analyse/Fibon/Analyse/CommandLine.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/CommandLine.hs @@ -0,0 +1,80 @@ +module Fibon.Analyse.CommandLine ( + Opt(..) + , NormalizeBy(..) + , parseCommandLine +) +where +import Fibon.Analyse.Output(OutputFormat(..)) +import System.Console.GetOpt + +data Opt = Opt { + optHelpMsg :: Maybe String + , optOutputFormat :: OutputFormat + , optNormalizeBy :: NormalizeBy + } + +type UsageError = String +type MbOpt = Either UsageError Opt +data NormalizeBy = ByPercent | ByRatio | ByNone + +defaultOpts :: Opt +defaultOpts = Opt { + optHelpMsg = Nothing + , optOutputFormat = AsciiArt + , optNormalizeBy = ByPercent + } + +parseCommandLine :: [String] -> Either UsageError (Opt, [FilePath]) +parseCommandLine args = + case getOpt Permute options args of + (opts, files, []) -> either Left (\o -> Right (o, files)) (parseOpts opts) + (_, _, errs) -> Left (concat errs ++ usage) + +parseOpts :: [OptionParser] -> MbOpt +parseOpts = foldl (flip id) (Right defaultOpts) + +type OptionParser = MbOpt -> MbOpt +options :: [OptDescr OptionParser] +options = [ + Option ['h'] ["help"] + (NoArg $ flip process (\o -> Right $ o {optHelpMsg = Just usage})) + "print a help message" + , + Option ['t'] ["table"] + (ReqArg (\a mbOpt -> process mbOpt (\o -> + case a of + "ascii" -> setFormat AsciiArt o + "latex" -> setFormat Latex o + "csv" -> setFormat Csv o + _ -> Left $ "Invalid table format: "++a)) "OutputFormat") + "table format [ascii, latex, raw]" + , + Option ['r'] ["raw"] + (ReqArg (\a mbOpt -> process mbOpt (\o -> + let noNorm = o {optNormalizeBy = ByNone} in + case a of + "\\t" -> setFormat (SimpleText "\t") noNorm + _ -> setFormat (SimpleText a) noNorm)) + "sep") + "raw data with seperator" + , + Option ['n'] ["normalize"] + (ReqArg (\a mbOpt -> process mbOpt (\o -> + case a of + "percent" -> setNorm ByPercent o + "ratio" -> setNorm ByRatio o + "none" -> setNorm ByNone o + _ -> Left $ "Invalid normalization: "++a)) "NormBy") + "normalize results by [percent, speedup, none]" + ] + where + setFormat fmt o = Right $ o {optOutputFormat = fmt} + setNorm norm o = Right $ o {optNormalizeBy = norm} + +process :: MbOpt -> (Opt -> MbOpt) -> MbOpt +process = flip (either Left) + +usage :: String +usage = usageInfo header options + where header = "Usage: fibon-analyse [OPTION...] [RESULTFILE...]" + diff --git a/tools/fibon-analyse/Fibon/Analyse/ExtraStats.hs b/tools/fibon-analyse/Fibon/Analyse/ExtraStats.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/ExtraStats.hs @@ -0,0 +1,10 @@ +module Fibon.Analyse.ExtraStats( + GhcStats.GhcStats(..) + , parseGhcStats +) +where +import Fibon.Analyse.ExtraStats.GhcStats as GhcStats + +parseGhcStats :: String -> Maybe GhcStats +parseGhcStats = GhcStats.parseMachineReadableStats + diff --git a/tools/fibon-analyse/Fibon/Analyse/ExtraStats/GhcStats.hs b/tools/fibon-analyse/Fibon/Analyse/ExtraStats/GhcStats.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/ExtraStats/GhcStats.hs @@ -0,0 +1,34 @@ +module Fibon.Analyse.ExtraStats.GhcStats( + GhcStats(..) + , parseMachineReadableStats +) +where + +import Fibon.Analyse.Metrics + +data GhcStats = GhcStats { + bytesAllocated :: Measurement MemSize + , numGCs :: Measurement MemSize + , averageBytesUsed :: Measurement MemSize + , maxBytesUsed :: Measurement MemSize + , numByteUsageSamples :: Measurement MemSize + , peakMegabytesAllocated :: Measurement MemSize + , initCPUSeconds :: Measurement ExecTime + , initWallSeconds :: Measurement ExecTime + , mutatorCPUSeconds :: Measurement ExecTime + , mutatorWallSeconds :: Measurement ExecTime + , gcCPUSeconds :: Measurement ExecTime + , gcWallSeconds :: Measurement ExecTime + + -- derived metrics + , ghcCpuTime :: Measurement ExecTime + , ghcWallTime :: Measurement ExecTime + } + deriving (Read, Show) + + + +parseMachineReadableStats :: String -> Maybe GhcStats +parseMachineReadableStats _ = Nothing + + diff --git a/tools/fibon-analyse/Fibon/Analyse/Main.hs b/tools/fibon-analyse/Fibon/Analyse/Main.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/Main.hs @@ -0,0 +1,37 @@ +module Main (main) where +import Fibon.Analyse.AnalysisRoutines +import Fibon.Analyse.Analysis +import Fibon.Analyse.CommandLine +import Fibon.Analyse.Output +import Fibon.Analyse.Result +import Fibon.Analyse.Tables +import System.Environment +import System.Exit + +main :: IO () +main = do + (opts, files) <- getCommandLine + mbResults <- mapM (\f -> runAnalysis noAnalysis f) files + case concat `fmap` sequence mbResults of + Nothing -> putStrLn "Error Parsing Results" + Just rs -> do + let fmt = optOutputFormat opts + let norm = getNormFun opts + putStrLn $ renderSummaryTable rs norm fmt basicTable + putStrLn $ renderTables rs norm fmt basicTable + + +getCommandLine :: IO (Opt, [FilePath]) +getCommandLine = do + args <- getArgs + case parseCommandLine args of + Left err -> putStrLn err >> exitFailure + Right (Opt {optHelpMsg = Just msg}, _) -> putStrLn msg >> exitSuccess + Right opts -> return opts + +getNormFun :: Opt -> (ResultColumn a -> Normalize a) +getNormFun o = + case optNormalizeBy o of + ByPercent -> NormPercent + ByRatio -> NormRatio + ByNone -> NormNone diff --git a/tools/fibon-analyse/Fibon/Analyse/Metrics.hs b/tools/fibon-analyse/Fibon/Analyse/Metrics.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/Metrics.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving#-} +module Fibon.Analyse.Metrics ( + MemSize(..) + , ExecTime(..) + , Estimate(..) + , ConfidenceInterval(..) + , Measurement(..) + , Metric(..) + , PerfData(..) + , pprPerfData + , RawPerf(..) + , NormPerf(..) + , BasicPerf(..) + , Summary(..) + , mkPointEstimate + , rawPerfToDouble + , normPerfToDouble +) +where + +import Data.Word +import Text.Printf + +newtype MemSize = MemSize {fromMemSize :: Word64} + deriving(Eq, Num, Read, Show) +newtype ExecTime = ExecTime {fromExecTime :: Double} + deriving(Eq, Num, Read, Show) + +data Estimate a = Estimate { + ePoint :: !a + , eStddev :: !a + , eSize :: !Int + , eCI :: Maybe (ConfidenceInterval a) + } + deriving (Read, Show) + +data ConfidenceInterval a = ConfidenceInterval { + eLowerBound :: !a + , eUpperBound :: !a + , eConfidenceLevel :: !Double +} + deriving (Read, Show) + +instance Functor Estimate where + fmap f e = e { + ePoint = f (ePoint e) + , eStddev = f (eStddev e) + , eCI = maybe Nothing (Just . fmap f) (eCI e) + } + +instance Functor ConfidenceInterval where + fmap f c = c { + eLowerBound = f (eLowerBound c) + , eUpperBound = f (eUpperBound c) + } + +data Measurement a = + Single a + | Interval (Estimate a) + deriving (Read, Show) + +mkPointEstimate :: (Num b) => (b -> a) -> a -> Estimate a +mkPointEstimate mkA a = Estimate { + ePoint = a + , eStddev = mkA 0 + , eSize = 1 + , eCI = Nothing + } + +class Metric a where + perf :: a -> Maybe RawPerf + +instance Metric (Measurement ExecTime) where + perf (Single m) = Just (RawTime (mkPointEstimate ExecTime m)) + perf (Interval e) = Just (RawTime e) + +instance Metric (Measurement MemSize) where + perf (Single m) = Just (RawSize (mkPointEstimate MemSize m)) + perf (Interval e) = Just (RawSize e) + +instance Metric a => Metric (Maybe a) where + --perf = fmap perf + perf Nothing = Nothing + perf (Just x) = perf x + +data PerfData = + NoResult + | Basic BasicPerf + | Summary Summary BasicPerf + deriving(Read, Show) + +data BasicPerf = + Raw RawPerf + | Norm NormPerf + deriving(Read, Show) + +data RawPerf = + RawTime (Estimate ExecTime) + | RawSize (Estimate MemSize) + deriving(Read, Show) + +data NormPerf = + Percent (Estimate Double) -- ^ (ref / base) * 100 + | Ratio (Estimate Double) -- ^ (base / ref) + deriving(Read, Show) + +data Summary = + Min + | GeoMean + | ArithMean + | Max + deriving(Read, Show) + +pprPerfData :: Bool -> PerfData -> String +pprPerfData _ NoResult = "--" +pprPerfData u (Basic b) = pprBasicPerf u b +pprPerfData u (Summary _ s) = pprBasicPerf u s + +pprBasicPerf :: Bool -> BasicPerf -> String +pprBasicPerf u (Raw r) = pprRawPerf u r +pprBasicPerf u (Norm n) = pprNormPerf u n + +pprNormPerf :: Bool -> NormPerf -> String +pprNormPerf u (Percent d) = + printf "%0.2f%s" ((ePoint d) - 100) (pprUnit u "%") +pprNormPerf _ (Ratio d) = + printf "%0.2f" (ePoint d) + +pprRawPerf :: Bool -> RawPerf -> String +pprRawPerf u (RawTime t) = + printf "%0.2f%s" ((fromExecTime . ePoint) t) (pprUnit u "s") +pprRawPerf u (RawSize s) = + printf "%0d%s" + (round (fromIntegral ((fromMemSize . ePoint) s) / 1000 :: Double)::Word64) + (pprUnit u "k") +{- +pprRawPerf u (RawTimeInterval e) = printf "%0.2f%s" + ((fromExecTime . ePoint) e) + (pprPlusMinus e fromExecTime) + (pprUnit u "s") +pprRawPerf u (RawSizeInterval e) = printf "%d%s%s" + ((fromMemSize . ePoint) e) + (pprPlusMinus e fromMemSize) + (pprUnit u "k") + +pprPlusMinus :: Real b => Estimate a -> (a -> b) -> String +pprPlusMinus e f = printf "%c%0.2d" (chr 0xB1) ((realToFrac spread)::Double) + where spread = abs ((f . ePoint) e) - ((f . eLowerBound) e) +pprSummaryPerf :: Bool -> SummaryPerf -> String +pprSummaryPerf u (GeoMean n) = pprBasicPerf u n +pprSummaryPerf u (ArithMean r) = pprBasicPerf u r +-} + +pprUnit :: Bool -> String -> String +pprUnit True s = s +pprUnit _ _ = "" + +rawPerfToDouble :: RawPerf -> Double +rawPerfToDouble (RawTime t) = (fromExecTime . ePoint) t +rawPerfToDouble (RawSize s) = (fromIntegral . fromMemSize . ePoint) s + +normPerfToDouble :: NormPerf -> Double +normPerfToDouble (Percent p) = ePoint p +normPerfToDouble (Ratio r) = ePoint r + diff --git a/tools/fibon-analyse/Fibon/Analyse/Output.hs b/tools/fibon-analyse/Fibon/Analyse/Output.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/Output.hs @@ -0,0 +1,113 @@ +module Fibon.Analyse.Output ( + OutputFormat(..) + , renderTables + , renderSummaryTable +) +where + +import qualified Data.Map as M +import Fibon.Analyse.Analysis +import Fibon.Analyse.Metrics +import Fibon.Analyse.Result +import Fibon.Analyse.Tables +import Text.Tabular +import Text.Printf +import qualified Text.Tabular.AsciiArt as Ascii +import qualified Text.Tabular.Csv as Csv +import qualified Text.Tabular.Latex as Latex +import qualified Text.Tabular.SimpleText as Simple + +data OutputFormat = + AsciiArt + | SimpleText {separator :: String} + | Latex + | Csv + +-- | Render a series of tables based on the 'TableSpec' +-- A table is rendered for each column in the 'TableSpec'. The data for the +-- columns are taken from the list of 'ResultColumn' passed to the function. +renderTables :: [ResultColumn a] -> NormMethod a -> OutputFormat -> [ColSpec a] -> String +renderTables [] _ _fmt _spec = "" +renderTables rs@(baseline:compares) normMethod fmt tableSpec = + unlines $ map render tableSpec + where + render colSpec = + renderTable (cName colSpec) colNames columns fmt [colSpec] + columns = baselineCol : compareCols + baselineCol = (NormNone baseline, baseline) + compareCols = [(normMethod baseline, c) | c <- compares] + colNames = map resultLabel rs + + +-- | Render a summary table comparing the "base" to a "peak" result. +-- The table is rendered with a column of "peak" data for each column listed +-- in the 'TableSpec'. +renderSummaryTable::[ResultColumn a] -> NormMethod a -> OutputFormat -> TableSpec a -> String +renderSummaryTable [base, peak] normMethod fmt tableSpec = + renderTable "Fibon Summary" colNames columns fmt tableSpec + where + columns = [(normMethod base, peak)] + colNames = map cName tableSpec +renderSummaryTable _ _ _ _ = "" + +-- | Renders a table. The number of columns is +-- length (tableData) * length (TableSpec). +renderTable :: String -- ^ Table name + -> [String] -- ^ Column names + -> [(Normalize a, ResultColumn a)] -- ^ Table data + -> OutputFormat -- ^ Output format + -> TableSpec a -- ^ Table description + -> String +renderTable _ _ [] _ _ = "" +renderTable tableName columnNames rs@(aResult:_) fmt tableSpec = + render table + where + render t = + tableName ++ errMsg ++ "\n" ++ + renderAs fmt (printf fmtString) id (renderPerfData fmt) tab + where tab = (Table rowHeader colHeader t) + (errMsg, dataRowLabels, summaryRowLabels, table) = + case computeRows rs benchNames tableSpec of + Left err -> (err, [],[],[[]]) + Right rows -> unzipRows rows + unzipRows (dataRows, summRows) = + let (dl,dr) = unzip dataRows + (sl,sr) = unzip summRows + in + (noErrorMsg, dl,sl, dr ++ sr) + rowLabels = dataRowLabels ++ summaryRowLabels + rowHeader = Group SingleLine [ + (Group NoLine dataRowNames),(Group NoLine summaryRowNames) + ] + colHeader = Group NoLine colNames + dataRowNames = map Header dataRowLabels + summaryRowNames = map Header summaryRowLabels + colNames = map Header columnNames + benchNames = M.keys (results . snd $ aResult) + fmtString = "%"++(show . maximum $ map length rowLabels)++"s" + noErrorMsg = "" + + +renderPerfData :: OutputFormat -> (PerfData -> String) +renderPerfData = pprPerfData . includeUnits + +type RenderFun rh ch td = (rh -> String) -- ^ Row header renderer + -> (ch -> String) -- ^ Col header renderer + -> (td -> String) -- ^ Data renderer + -> Table rh ch td -- ^ Table data + -> String -- ^ Rendered table +renderAs :: OutputFormat -> RenderFun rh ch td +renderAs AsciiArt = Ascii.render +renderAs Latex = Latex.render +renderAs Csv = Csv.render +renderAs (SimpleText sep) = Simple.render sep + + +-- | Don't print units for outputs which are intended to be inputs to +-- other analysis programs (like R or Excel) +includeUnits :: OutputFormat -> Bool +includeUnits (SimpleText _) = False +includeUnits Csv = False +includeUnits Latex = False +includeUnits _ = True + diff --git a/tools/fibon-analyse/Fibon/Analyse/Parse.hs b/tools/fibon-analyse/Fibon/Analyse/Parse.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/Parse.hs @@ -0,0 +1,43 @@ +module Fibon.Analyse.Parse( + GhcStats(..) + , parseFibonResults +) +where + +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Fibon.Result +import Fibon.Analyse.ExtraStats +import Fibon.Analyse.Result +import System.FilePath + + +parseFibonResults :: FilePath -- ^ input file + -> IO (Maybe (M.Map ResultLabel [FibonResult])) -- ^ Result +parseFibonResults file = do + input <- T.readFile file + case runParser input of + Nothing -> return Nothing + Just [] -> return Nothing + Just rs -> return (Just $ M.mapKeys addFileSource (groupResults rs)) + where + baseName = takeBaseName file + addFileSource s = baseName ++ s + + runParser :: T.Text -> Maybe [FibonResult] + runParser text = sequence (map parseLine (T.lines text)) + + parseLine :: T.Text -> Maybe FibonResult + parseLine line = + case reads (T.unpack line) of + [(r, _)] -> Just r + _ -> Nothing + +groupResults :: [FibonResult] -> M.Map ResultLabel [FibonResult] +groupResults = foldr grouper M.empty + where + grouper r = M.insertWith (++) (benchType r) [r] + benchType r = dropWhile (/= '-') (benchName r) + + diff --git a/tools/fibon-analyse/Fibon/Analyse/Result.hs b/tools/fibon-analyse/Fibon/Analyse/Result.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/Result.hs @@ -0,0 +1,34 @@ +module Fibon.Analyse.Result( + FibonStats(..) + , AnalyseResult(..) + , BenchName + , ResultLabel + , ResultColumn(..) +) +where + +import qualified Data.Map as M +import Fibon.Analyse.Metrics + +type BenchName = String +type ResultLabel = String + +data ResultColumn a = ResultColumn { + resultLabel :: ResultLabel + , results :: M.Map BenchName (AnalyseResult a) + } + deriving (Read, Show) + +data AnalyseResult a = AnalyseResult { + fibonStats :: FibonStats + , extraStats :: Maybe a + } + deriving (Read, Show) + +data FibonStats = FibonStats { + compileTime :: Measurement ExecTime + , binarySize :: Measurement MemSize + , wallTime :: Measurement ExecTime + } + deriving (Read, Show) + diff --git a/tools/fibon-analyse/Fibon/Analyse/Tables.hs b/tools/fibon-analyse/Fibon/Analyse/Tables.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-analyse/Fibon/Analyse/Tables.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Fibon.Analyse.Tables ( + basicTable + , ghcStatsSummaryTable + , ColSpec(..) + , TableSpec +) +where + +import Fibon.Analyse.ExtraStats +import Fibon.Analyse.Metrics +import Fibon.Analyse.Result + +basicTable :: TableSpec a +basicTable = [ + ColSpec "RunTime" (onFibonStats wallTime) + , ColSpec "Size" (onFibonStats binarySize) + , ColSpec "CompileTime" (onFibonStats compileTime) + ] + +ghcStatsSummaryTable :: TableSpec GhcStats +ghcStatsSummaryTable = [ + ColSpec "Size" (onFibonStats binarySize) + , ColSpec "Allocs" (onExtraStats bytesAllocated) + , ColSpec "Runtime" (onExtraStats ghcCpuTime) + , ColSpec "Elapsed" (onExtraStats ghcWallTime) + , ColSpec "TotalMem" (onExtraStats maxBytesUsed) + ] + +-- Idea borrowed graciously from nofib-analyse +data ColSpec a = + forall b . Metric b => + ColSpec { + cName :: String -- ^ Short name (for column heading) + , cMetric :: (AnalyseResult a -> Maybe b) -- ^ How to get the result + } + +type TableSpec a = [ColSpec a] + +onExtraStats :: (a -> b) -> AnalyseResult a -> Maybe b +onExtraStats f = fmap f . extraStats + +onFibonStats :: (FibonStats -> b) -> AnalyseResult a -> Maybe b +onFibonStats f = Just . f . fibonStats diff --git a/tools/fibon-init/Main.hs b/tools/fibon-init/Main.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-init/Main.hs @@ -0,0 +1,131 @@ +-- Utility for adding the Fibon directory for a new benchmark +module Main (main) where + +import Control.Monad +import Data.Char as Char +import Data.List + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.Parse +import Distribution.Verbosity + +import System.Directory +import System.Exit +import System.FilePath +import System.IO + +main :: IO () +main = do + cf <- findCabalFile + pkg <- parsePackage cf + createDirectoryStructure + writeInstanceFile pkg + +findCabalFile :: IO String +findCabalFile = do + cwd <- getCurrentDirectory + files <- getDirectoryContents cwd + let cabalfiles = filter (".cabal" `isSuffixOf`) files + case cabalfiles of + [f] -> return f + [] -> do + putStrLn "Error: no cabal files found in current directory" + exitFailure + _ -> do + putStrLn "Error: multiple cabal files found in current directory" + exitFailure + +parsePackage :: FilePath -> IO PackageDescription +parsePackage cabalFile = do + gps <- (readPackageDescription silent) cabalFile + return $ flattenPackageDescription gps + +getName :: PackageDescription -> String +getName pkg = upCase $ toS $ (packageName . package) pkg + where + toS (PackageName p) = p + +upCase :: String -> String +upCase [] = [] +upCase (x:xs) = Char.toUpper x : xs + +createDirectoryStructure :: IO () +createDirectoryStructure = do + safeCreateDir "Fibon" + safeCreateDir $ "Fibon" "data" + safeCreateDir $ "Fibon" "data" "test" + safeCreateDir $ "Fibon" "data" "test" "input" + safeCreateDir $ "Fibon" "data" "test" "output" + safeCreateDir $ "Fibon" "data" "ref" + safeCreateDir $ "Fibon" "data" "ref" "input" + safeCreateDir $ "Fibon" "data" "ref" "output" + +safeCreateDir :: FilePath -> IO () +safeCreateDir path = do + exists <- doesDirectoryExist path + unless exists (createDirectory path) + +writeInstanceFile :: PackageDescription -> IO () +writeInstanceFile pkg = do + exists <- doesFileExist outFile + when exists (putStrLn "Error: Instance.hs already exists" >> exitFailure) + cwd <- getCurrentDirectory + let bName = getName pkg + gName = getGrpName cwd + eName = getExeName pkg + h <- openFile outFile WriteMode + hPutStrLn h (template gName bName eName) + hClose h + putStrLn $ "Wrote instance file to "++outFile + where + outFile = "Fibon" "Instance.hs" + + +getGrpName :: FilePath -> String +getGrpName path = + case dirs of + (_:_:_) -> upCase $ (head . drop 1 . reverse) dirs + _ -> "Unknown" + where dirs = splitDirectories path + +getExeName :: PackageDescription -> String +getExeName pkg = + case executables pkg of + (e:_) -> exeName e + _ -> "Unknown" + + +template :: String -> String -> String -> String +template grpName bmName exName = unlines [ + "{-# OPTIONS_GHC -fno-warn-missing-signatures #-}", + "module "++modName++"(", + " mkInstance", + ")", + "where", + "import Fibon.BenchmarkInstance", + "", + "sharedConfig = BenchmarkInstance {", + " flagConfig = FlagConfig {", + " configureFlags = []", + " , buildFlags = []", + " , runFlags = []", + " }", + " , stdinInput = Nothing", + " , output = [(Stdout, Diff "++(show expectedOut)++")]", + " , exeName = "++(show exName), + " }", + "flgCfg = flagConfig sharedConfig", + "", + "mkInstance Test = sharedConfig {", + " flagConfig = flgCfg", + " }", + "mkInstance Ref = sharedConfig {", + " flagConfig = flgCfg", + " }" + ] + where + modName = "Fibon.Benchmarks."++grpName++"."++bmName++".Fibon.Instance" + expectedOut = exName ++ ".stdout.expected" + diff --git a/tools/fibon-run/Fibon/Run/Actions.hs b/tools/fibon-run/Fibon/Run/Actions.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/Actions.hs @@ -0,0 +1,243 @@ +module Fibon.Run.Actions ( + runBundle + , buildBundle + , sanityCheckBundle + , FibonError + , Action(..) + , ActionRunner +) +where + +import Data.List +import Data.Maybe +import Data.Time.Clock.POSIX +import Fibon.BenchmarkInstance +import Fibon.Result +import Fibon.Run.BenchmarkBundle +import Fibon.Run.BenchmarkRunner as Runner +import qualified Fibon.Run.Log as Log +import qualified Fibon.Run.SysTools as SysTools +import Control.Monad.Error +import Control.Monad.Reader +import System.Directory +import System.Exit +import System.FilePath +import System.Process + +type FibonRunMonad = ErrorT FibonError (ReaderT BenchmarkBundle IO) + +data Action = + Sanity + | Build + | Run + deriving (Read, Show, Eq, Ord, Enum) + +type ActionRunner a = (BenchmarkBundle -> IO (Either FibonError a)) + +data ActionResult = + SanityComplete + | BuildComplete BuildData + | RunComplete RunData + deriving(Show) + +data FibonError = + BuildError String + | SanityError String + | RunError String + | OtherError String -- ^ For general IO exceptions + deriving (Show) +instance Error FibonError where + strMsg = OtherError + +sanityCheckBundle :: BenchmarkBundle -> IO (Either FibonError ()) +sanityCheckBundle bb = runFibonMonad bb $ do + SanityComplete <- runAction Sanity + return () + +buildBundle :: BenchmarkBundle -> IO (Either FibonError BuildData) +buildBundle bb = runFibonMonad bb $ do + SanityComplete <- runAction Sanity + BuildComplete br <- runAction Build + return br + +runBundle :: BenchmarkBundle -> IO (Either FibonError FibonResult) +runBundle bb = runFibonMonad bb $ do + SanityComplete <- runAction Sanity + BuildComplete br <- runAction Build + RunComplete rr <- runAction Run + return $ FibonResult (bundleName bb) br rr + +runFibonMonad :: BenchmarkBundle + -> ErrorT FibonError (ReaderT BenchmarkBundle IO) a + -> IO (Either FibonError a) +runFibonMonad bb a = runReaderT (runErrorT a) bb + +runAction :: Action -> FibonRunMonad ActionResult +runAction Sanity = do + io $ Log.notice " Checking..." + sanityCheck + return SanityComplete +runAction Build = do + io $ Log.notice " Building..." + prepConfigure + runConfigure + r <- runBuild + return $ BuildComplete r +runAction Run = do + io $ Log.notice " Running..." + prepRun + r <- runRun + return $ RunComplete r + +sanityCheck :: FibonRunMonad () +sanityCheck = do + bb <- ask + let bmPath = pathToBench bb + io $ Log.info ("Checking for directory:\n"++bmPath) + bdExists <- io $ doesDirectoryExist bmPath + unless bdExists (throwError $ pathDoesNotExist bmPath) + io $ Log.info ("Checking for cabal file in:\n"++bmPath) + dirContents <- io $ getDirectoryContents bmPath + let cabalFile = find (".cabal" `isSuffixOf`) dirContents + case cabalFile of + Just f -> do io $ Log.info ("Found cabal file: "++f) + checkForExpectedOutFiles + Nothing -> throwError cabalFileDoesNotExist + where + pathDoesNotExist bmP = SanityError("Directory:\n"++bmP++" does not exist") + cabalFileDoesNotExist = SanityError "Can not find cabal file" + +checkForExpectedOutFiles :: FibonRunMonad () +checkForExpectedOutFiles = do + bb <- ask + io $ Log.info "Checking for diff files" + let expectedOut = (output . benchDetails) bb + fs = diffFiles expectedOut + missingFiles <- io $ filterM (missing bb) fs + case missingFiles of + [] -> return () + ms -> throwError $ SanityError("Missing expected output files: "++show ms) + where + missing bb f = do + Log.info $ "Checking for expected output file: " ++ f + e1 <- doesFileExist $ (pathToAllOutputFiles bb) f + e2 <- doesFileExist $ (pathToSizeOutputFiles bb) f + return (not e1 && not e2) + diffFiles = + catMaybes . map (\o -> case o of (_, Diff f) -> Just f ; _ -> Nothing) + +prepConfigure :: FibonRunMonad () +prepConfigure = do + bb <- ask + let ud = (workDir bb) (unique bb) + udExists <- io $ doesDirectoryExist ud + unless udExists (io $ createDirectory ud) + +runConfigure :: FibonRunMonad () +runConfigure = do + _ <- runCabalCommand "configure" configureFlags + return () + +runBuild :: FibonRunMonad BuildData +runBuild = do + time <- runCabalCommand "build" buildFlags + size <- runSizeCommand + return $ BuildData {buildTime = time, buildSize = size} + +prepRun :: FibonRunMonad () +prepRun = do + mapM_ copyFiles [ + pathToSizeInputFiles + , pathToAllInputFiles + , pathToSizeOutputFiles + , pathToAllOutputFiles + ] + +runRun :: FibonRunMonad RunData +runRun = do + bb <- ask + res <- io $ Runner.run bb + io $ Log.info (show res) + case res of + Success s d -> return $ RunData {summary = s, details = d} + Failure msg -> throwError $ RunError (summarize msg) + where + summarize = concat . intersperse "\n" . map simplify + simplify (MissingOutput f) = "Missing output file: "++f + simplify (DiffError _ )= "Output differs from expected." + simplify (Timeout )= "Timeout" + +copyFiles :: (BenchmarkBundle -> FilePath) + -> FibonRunMonad () +copyFiles pathSelector = do + bb <- ask + let srcPath = pathSelector bb + dstPath = pathToExeBuildDir bb + cp f = do + io $ copyFile (srcPath baseName) (dstPath baseName) + where baseName = snd (splitFileName f) + dExists <- io $ doesDirectoryExist srcPath + if not dExists + then do return () + else do + io $ Log.info ("Copying files\n from: "++srcPath++"\n to: "++dstPath) + files <- io $ getDirectoryContents srcPath + let realFiles = filter (\f -> f /= "." && f /= "..") files + io $ Log.info ("Copying files: "++(show realFiles)) + mapM_ cp realFiles + return () + +runCabalCommand :: String + -> (FlagConfig -> [String]) + -> FibonRunMonad Double +runCabalCommand cmd flagsSelector = do + bb <- ask + let fullArgs = ourArgs ++ userArgs + userArgs = (flagsSelector . fullFlags) bb + ourArgs = [cmd, "--builddir="++(pathToCabalWorkDir bb)] + (_, time) <- timeInDir (pathToBench bb) $ exec SysTools.cabal fullArgs + return time + +runSizeCommand :: FibonRunMonad String +runSizeCommand = do + bb <- ask + exec (SysTools.size) [(pathToExe bb)] + + +timeInDir :: FilePath -> FibonRunMonad a -> FibonRunMonad (a, Double) +timeInDir fp action = do + dir <- io $ getCurrentDirectory + io $ setCurrentDirectory fp + start <- io $ getTime + r <- action + end <- io $ getTime + io $ setCurrentDirectory dir + let !delta = end - start + return (r, delta) + +io :: IO a -> FibonRunMonad a +io = liftIO + +exec :: FilePath -> [String] -> FibonRunMonad String +exec cmd args = do + (exit, out, err) <- io $ readProcessWithExitCode cmd args [] + io $ Log.info ("COMMAND: "++fullCommand) + io $ Log.info ("STDOUT: \n"++out) + io $ Log.info ("STDERR: \n"++err) + case exit of + ExitSuccess -> return out + ExitFailure _ -> throwError $ BuildError msg + where + msg = "Failed running command: " ++ fullCommand + fullCommand = cmd ++ stringify args + + +joinWith :: a -> [[a]] -> [a] +joinWith a = concatMap (a:) + +stringify :: [String] -> String +stringify = joinWith ' ' + +getTime :: IO Double +getTime = (fromRational . toRational) `fmap` getPOSIXTime + diff --git a/tools/fibon-run/Fibon/Run/BenchmarkBundle.hs b/tools/fibon-run/Fibon/Run/BenchmarkBundle.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/BenchmarkBundle.hs @@ -0,0 +1,168 @@ +module Fibon.Run.BenchmarkBundle ( + BenchmarkBundle(..) + , mkBundle + , bundleName + , pathToBench + , pathToCabalWorkDir + , pathToExeBuildDir + , pathToExe + , pathToSizeInputFiles + , pathToSizeOutputFiles + , pathToAllInputFiles + , pathToAllOutputFiles + , pathToSizeDataFiles + , pathToStdoutFile + , pathToStderrFile + , pathToExeRunDir + , pathToStdinFile + , prettyRunCommand + , bundleProcessSpec +) +where + +import Data.Char +import Data.List +import Fibon.Benchmarks +import Fibon.BenchmarkInstance +import Fibon.Timeout +import Fibon.Run.Config +import System.FilePath +import System.IO +import System.Process +import System.Info + + +data BenchmarkBundle = BenchmarkBundle { + benchmark :: FibonBenchmark + , workDir :: FilePath + , benchDir :: FilePath + , unique :: String + , iters :: Int + , tuneSetting :: TuneSetting + , inputSize :: InputSize + , fullFlags :: FlagConfig + , benchDetails :: BenchmarkInstance + , timeout :: Maybe Int + , extraStats :: Maybe FilePath + } deriving (Show) + +mkBundle :: RunConfig + -> FibonBenchmark + -> FilePath -- ^ working directory + -> FilePath -- ^ benchmarks directory + -> String -- ^ unique id + -> InputSize + -> TuneSetting + -> BenchmarkBundle +mkBundle rc bm wd bmsDir uniq size tune = + BenchmarkBundle { + benchmark = bm + , workDir = wd + , benchDir = bmsDir + , unique = uniq + , iters = (iterations rc) + , tuneSetting = tune + , inputSize = size + , fullFlags = flags configuration + , benchDetails = benchInstance bm size + , timeout = timeoutToMicroSeconds (limit configuration) + , extraStats = (extraStatsFile configuration) + } + where + configuration = mkConfig rc bm size tune + +bundleName :: BenchmarkBundle -> String +bundleName bb = concat $ intersperse "-" + [(show $ benchmark bb), (show $ inputSize bb), (show $ tuneSetting bb)] + +pathToBench :: BenchmarkBundle -> FilePath +pathToBench bb = (benchDir bb) ((benchPath . benchmark) bb) + +pathToCabalWorkDir :: BenchmarkBundle -> FilePath +pathToCabalWorkDir bb = (workDir bb) (unique bb) (bundleName bb) + +pathToExeBuildDir :: BenchmarkBundle -> FilePath +pathToExeBuildDir bb = + (pathToCabalWorkDir bb) "build" (exeName.benchDetails $ bb) + +pathToExeRunDir :: BenchmarkBundle -> FilePath +pathToExeRunDir = pathToExeBuildDir + +pathToExe :: BenchmarkBundle -> FilePath +pathToExe bb = (pathToExeBuildDir bb) (exeName.benchDetails $ bb)++ext + where ext = if System.Info.os == "mingw32" then ".exe" else "" + +pathToSizeInputFiles :: BenchmarkBundle -> FilePath +pathToSizeInputFiles = pathToSizeDataFiles "input" + +pathToSizeOutputFiles :: BenchmarkBundle -> FilePath +pathToSizeOutputFiles = pathToSizeDataFiles "output" + +pathToAllInputFiles :: BenchmarkBundle -> FilePath +pathToAllInputFiles = pathToAllDataFiles "input" + +pathToAllOutputFiles :: BenchmarkBundle -> FilePath +pathToAllOutputFiles = pathToAllDataFiles "output" + +pathToSizeDataFiles :: FilePath -> BenchmarkBundle -> FilePath +pathToSizeDataFiles subDir bb = pathToDataFiles size subDir bb + where + size = (map toLower $ show $ inputSize bb) + +pathToAllDataFiles :: FilePath -> BenchmarkBundle -> FilePath +pathToAllDataFiles = pathToDataFiles "all" + +pathToDataFiles :: FilePath -> FilePath -> BenchmarkBundle -> FilePath +pathToDataFiles size subDir bb = + (pathToBench bb) "Fibon" "data" size subDir + +pathToStdoutFile :: BenchmarkBundle -> FilePath +pathToStdoutFile = pathToStdioFile "stdout" + +pathToStderrFile :: BenchmarkBundle -> FilePath +pathToStderrFile = pathToStdioFile "stderr" + +pathToStdioFile :: String -> BenchmarkBundle -> FilePath +pathToStdioFile name bb = + (pathToExeRunDir bb) (exeName.benchDetails $ bb) ++"."++name++".actual" + +pathToStdinFile :: BenchmarkBundle -> FilePath -> FilePath +pathToStdinFile bb inFile = (pathToExeRunDir bb) inFile + +benchExeAndArgs :: BenchmarkBundle -> (String, [String]) +benchExeAndArgs bb = (exe, fullArgs) + where + exe = pathToExe bb + fullArgs = (runFlags . fullFlags) bb + +prettyRunCommand :: BenchmarkBundle -> String +prettyRunCommand bb = cmd + where + cmd = exe ++ (concatMap (' ':) fullArgs) + fullArgs = args ++ stdioArgs + (exe,args) = benchExeAndArgs bb + stdioArgs = [stdIn, stdOut, stdErr] + stdIn = case (stdinInput.benchDetails $ bb) of + Nothing -> "" + Just f -> " < " ++ pathToStdinFile bb f + stdOut = " > " ++ (pathToStdoutFile bb) + stdErr = " 2> " ++ (pathToStderrFile bb) + +bundleProcessSpec :: BenchmarkBundle -> IO CreateProcess +bundleProcessSpec bb = do + stdIn <- + case (stdinInput.benchDetails $ bb) of + Nothing -> do return CreatePipe + Just f -> do h <- openFile (pathToStdinFile bb f) ReadMode + return (UseHandle h) + out <- openFile (pathToStdoutFile bb) WriteMode + err <- openFile (pathToStderrFile bb) WriteMode + return $ (proc exe args) { + cwd = Just (pathToExeRunDir bb) + , std_in = stdIn + , std_out = UseHandle out + , std_err = UseHandle err + } + where + (exe, args) = benchExeAndArgs bb + diff --git a/tools/fibon-run/Fibon/Run/BenchmarkRunner.hs b/tools/fibon-run/Fibon/Run/BenchmarkRunner.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/BenchmarkRunner.hs @@ -0,0 +1,209 @@ +module Fibon.Run.BenchmarkRunner ( + RunResult(..) + , RunFailure(..) + , Fibon.Run.BenchmarkRunner.run +) +where + +import Control.Concurrent +import Control.Monad +import Control.Exception +import Data.Time.Clock +import Data.Maybe +import qualified Data.Vector.Unboxed as Vector +import Fibon.BenchmarkInstance +import Fibon.Result +import Fibon.Run.BenchmarkBundle +import Fibon.Run.Log as Log +import qualified Fibon.Run.SysTools as SysTools +import Statistics.Sample +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Process +import Text.Printf + +data RunResult = + Success {runSummary :: RunSummary, runDetails :: [RunDetail]} + | Failure [RunFailure] + deriving (Read, Show) + +data RunFailure = + MissingOutput FilePath + | DiffError String + | Timeout + deriving (Read, Show) + +run :: BenchmarkBundle -> IO RunResult +run bb = do + let bmk = (bundleName bb) + pwd = (pathToExeBuildDir bb) + cmd = (prettyRunCommand bb) + Log.info $ "Running Benchmark " + Log.info $ " BMK: " ++ bmk + Log.info $ " PWD: " ++ pwd + Log.info $ " CMD: " ++ cmd + Log.info $ printf "\n@%s|%s|%s" bmk pwd cmd + runDirect bb + +{- +-- Move this to analysis time +analyze :: Sample -> ExtraStats -> Int -> Double -> IO RunSummary +analyze times ghcStats numResamples ci = do + let ests = [mean, stdDev] + res <- withSystemRandom $ \gen -> + resample gen ests numResamples times :: IO [Resample] + let [em,es] = bootstrapBCA ci times ests res + let runData = RunSummary { + timeSummary = + TimeMeasurement { + meanTime = estPoint em + , meanTimeLB = estLowerBound em + , meanTimeUB = estUpperBound em + , meanStddev = estPoint es + , meanStddevUB = estLowerBound es + , meanStddevLB = estUpperBound es + , confidence = ci + } + , statsSummary = ghcStats + } + return runData +-} + +checkResult :: BenchmarkBundle -> IO (Maybe [RunFailure]) +checkResult bb = do + rs <- mapM (checkOutput bb) (output . benchDetails $ bb) + let errs = filter isJust rs + case errs of + [] -> return $ Nothing + es -> return $ Just (catMaybes es) + +checkOutput :: BenchmarkBundle -> OutputDescription -> IO (Maybe RunFailure) +checkOutput bb (o, Exists) = do + let f = (destinationToRealFile bb o) + e <- doesFileExist f + if e then return Nothing + else return $ Just $ MissingOutput ("File "++f++" does not exist") +checkOutput bb (o, Diff diffFile) = do + e1 <- checkOutput bb (o, Exists) + e2 <- checkOutput bb (d, Exists) + e3 <- runDiff f1 f2 + return $ msum [e1, e2, e3] + where + d = OutputFile diffFile + f1 = (destinationToRealFile bb o) + f2 = (destinationToRealFile bb d) + +runDiff :: FilePath -> FilePath -> IO (Maybe RunFailure) +runDiff f1 f2 = do + Log.info $ "Diffing files: "++f1++" "++f2 + (r, o, _) <- readProcessWithExitCode (SysTools.diff) [f1, f2] "" + if r == ExitSuccess then Log.info "No diff error" >> + return Nothing + else Log.info "Diff error" >> + (return $ Just $ DiffError o) + +destinationToRealFile :: BenchmarkBundle -> OutputDestination -> FilePath +destinationToRealFile bb (OutputFile f) = (pathToExeRunDir bb) f +destinationToRealFile bb Stdout = (pathToStdoutFile bb) +destinationToRealFile bb Stderr = (pathToStderrFile bb) + +readExtraStats :: BenchmarkBundle -> IO ExtraStats +readExtraStats bb = do + let mbStatsFile = extraStats bb + statsFile = fromJust mbStatsFile + logReadE :: IOException -> IO ExtraStats + logReadE e = + Log.warn ("Error reading stats file: "++statsFile++"\n "++show e) + >> return [] + --logParseE = + -- Log.warn ("Error parsing stats file: "++statsFile) >> return [] + case mbStatsFile of + Nothing -> return [] + Just f -> do + handle logReadE $ + bracket (openFile ((pathToExeRunDir bb) f) ReadMode) + (hClose) + (\h -> hGetContents h >>= \s -> length s `seq` return s) + --stats <- hGetContents h + -- drop header line in machine readable stats + --let body = (unlines . drop 1 . lines) stats + --case reads body of + -- [(p, _)] -> return p + -- _ -> logParseE) + +type RunStepResult = IO (Either [RunFailure] RunDetail) + +runDirect :: BenchmarkBundle -> IO RunResult +runDirect bb = do + mbDetails <- go count [] + case mbDetails of + Left e -> return $ Failure e + Right ds -> return $ Success (summarize ds) ds + where + go 0 ds = return $ Right (reverse ds) + go n ds = do + res <- runB bb + case res of + Right d -> go (n-1) (d:ds) + Left e -> return $ Left e + runB = maybe runBenchmarkWithoutTimeout runBenchmarkWithTimeout limit + limit = timeout bb + count = (iters bb) + +summarize :: [RunDetail] -> RunSummary +summarize ds = RunSummary { + meanTime = mean times + , stdDevTime = stdDev times + , statsSummary = stats + } + where + times = (Vector.fromList $ map runTime ds) + stats = concatMap runStats ds + +type TimeoutLength = Int +runBenchmarkWithTimeout :: TimeoutLength -> BenchmarkBundle -> RunStepResult +runBenchmarkWithTimeout us bb = do + resMVar <- newEmptyMVar + pidMVar <- newEmptyMVar + tid1 <- forkIO $ (putMVar resMVar . Just) =<< timeBenchmarkExe bb (Just pidMVar) + _ <- forkIO $ threadDelay us >> putMVar resMVar Nothing + res <- takeMVar resMVar + case res of + Nothing -> do + Log.info $ "benchmark timed out after "++(show us)++" us" + -- try to kill the subprocess + pid <- tryTakeMVar pidMVar + maybe pass terminateProcess pid + -- kill the haskell thread + killThread tid1 + return $ Left [Timeout] + Just runDetail -> do + maybe (Right runDetail) Left `liftM` checkResult bb + +runBenchmarkWithoutTimeout :: BenchmarkBundle -> RunStepResult +runBenchmarkWithoutTimeout bb = do + runDetail <- timeBenchmarkExe bb Nothing + maybe (Right runDetail) Left `liftM` checkResult bb + +timeBenchmarkExe :: BenchmarkBundle -- benchmark to run + -> Maybe (MVar ProcessHandle) -- in case we need to kill it + -> IO RunDetail +timeBenchmarkExe bb pidMVar = do + p <- bundleProcessSpec bb + start <- getCurrentTime + (_, _, _, pid) <- createProcess p + maybe pass (flip putMVar pid) pidMVar + _ <- waitForProcess pid + end <- getCurrentTime + mapM_ closeStdIO [std_in p, std_out p, std_err p] + stats <- readExtraStats bb + return $ RunDetail (realToFrac (diffUTCTime end start)) stats + +closeStdIO :: StdStream -> IO () +closeStdIO (UseHandle h) = hClose h +closeStdIO _ = return () + +pass :: IO () +pass = return() diff --git a/tools/fibon-run/Fibon/Run/CommandLine.hs b/tools/fibon-run/Fibon/Run/CommandLine.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/CommandLine.hs @@ -0,0 +1,157 @@ +module Fibon.Run.CommandLine ( + Opt(..) + , UsageError + , parseCommandLine +) +where + +import Data.Maybe +import Data.List +import Fibon.Run.Actions +import Fibon.Run.Config +import Fibon.Run.Manifest +import System.Console.GetOpt + +type UsageError = String +data Opt = Opt { + optConfig :: ConfigId + , optHelpMsg :: Maybe String + , optBenchmarks :: Maybe [BenchmarkRunSelection] + , optTuneSetting :: Maybe TuneSetting + , optSizeSetting :: Maybe InputSize + , optIterations :: Maybe Int + , optAction :: Action + } + +defaultOpts :: Opt +defaultOpts = Opt { + optConfig = "default" + , optBenchmarks = Nothing + , optHelpMsg = Nothing + , optTuneSetting = Nothing + , optSizeSetting = Nothing + , optIterations = Nothing + , optAction = Run + } + + +parseCommandLine :: [String] -> Either UsageError Opt +parseCommandLine args = + case getOpt Permute options args of + (o, bms, []) -> + let (oErrs, opts) = parseOpts o + (bErrs, bs) = parseBenchs bms + in + case (oErrs, bErrs) of + (Just oe, Just be) -> Left $ oe ++ be + (Just oe, Nothing) -> Left $ oe + (Nothing, Just be) -> Left $ be + (Nothing, Nothing) -> Right $ opts {optBenchmarks = bs} + (_,_,errs) -> Left (concat errs ++ usage) + + +parseOpts :: [OptionParser] -> (Maybe UsageError, Opt) +parseOpts = foldl (flip id) (Nothing, defaultOpts) + +parseBenchs :: [String] -> (Maybe UsageError, Maybe [BenchmarkRunSelection]) +parseBenchs bms = (errors, benchs) + where + bmParses = map mbParse bms :: [Maybe FibonBenchmark] + grParses = map mbParse bms :: [Maybe FibonGroup] + parses = zipWith oneOrTheOther bmParses grParses + errors = foldl collectErrors Nothing (zip bms parses) + benchs = case catMaybes parses of [] -> Nothing; bs -> Just bs + + oneOrTheOther (Just b) _ = Just $ RunSingle b + oneOrTheOther _ (Just g) = Just $ RunGroup g + oneOrTheOther _ _ = Nothing + + collectErrors errs (bm, parse) = + mbAddError errs parse ("Unknown benchmark: "++bm) + + +type OptionParser = ((Maybe UsageError, Opt) -> (Maybe UsageError, Opt)) +options :: [OptDescr OptionParser] +options = [ + Option ['h'] ["help"] + (NoArg (\(e, opt) -> (e, opt {optHelpMsg = Just usage}))) + "print a help message" + , + Option ['c'] ["config"] + (ReqArg (\c (e, opt) -> (e, opt {optConfig = c})) "ConfigId") + "default config settings" + , + Option ['t'] ["tune"] + (ReqArg (\t (e, opt) -> + let tune = mbParse t + errs = mbAddError e tune ("Unknown tune setting: "++t) + in + (errs, opt {optTuneSetting = tune})) "TuneSetting" + ) + "override tune setting" + , + Option ['s'] ["size"] + (ReqArg (\s (e, opt) -> + let size = mbParse s + errs = mbAddError e size ("Unknown size setting: "++s) + in + (errs, opt {optSizeSetting = size})) "InputSize" + ) + "override size setting" + , + Option ['i'] ["iters"] + (ReqArg (\i (e, opt) -> + let iter = mbParse i + errs = mbAddError e iter ("Invalid iter setting: "++i) + in + (errs, opt {optIterations = iter})) "Int" + ) + "override number of iterations" + , + Option ['m'] ["manifest"] + (NoArg (\(e, opt) -> (e, opt {optHelpMsg = Just manifest}))) + "print manifest of configs and benchmarks" + , + Option ['a'] ["action"] + (ReqArg (\a (e, opt) -> + let act = mbParse a + errs = mbAddError e act ("Invalid action setting: "++a) + in + (errs, opt {optAction = fromMaybe (optAction opt) act})) "Action" + ) + "override default action" + ] + +usage :: String +usage = usageInfo header options + where header = "Usage: fibon-run [OPTION...] [BENCHMARKS...]" + +mbAddError :: Maybe UsageError -> Maybe a -> UsageError -> Maybe UsageError +mbAddError e p msg = + case p of + Just _success -> e + Nothing -> case e of + Just errs -> Just (errs ++ "\n" ++ msg) + Nothing -> Just msg + +mbParse :: (Read a) => String -> Maybe a +mbParse s = + case reads s of + [(a, "")] -> Just a + _ -> Nothing + +manifest :: String +manifest = + "Configurations(" ++ nConfigs ++ ")\n " ++ configs ++ "\n" ++ + "Benchmarks(" ++ nBenchs ++ ")\n " ++ bms ++ "\n" ++ + "Groups(" ++ nGroups ++ ")\n " ++ grps + where + nConfigs = formatN configManifest + nBenchs = formatN benchmarkManifest + nGroups = formatN groupManifest + configs = format configId configManifest + bms = format show benchmarkManifest + grps = format show groupManifest + format f = concat . intersperse "\n " . map f + formatN = show . length + diff --git a/tools/fibon-run/Fibon/Run/Config.hs b/tools/fibon-run/Fibon/Run/Config.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/Config.hs @@ -0,0 +1,84 @@ +module Fibon.Run.Config ( + Fibon.ConfigMonad.append + , Fibon.ConfigMonad.setTimeout + , Fibon.ConfigMonad.done + , Fibon.ConfigMonad.collectExtraStatsFrom + , Fibon.ConfigMonad.noExtraStats + , Fibon.ConfigMonad.useGhcDir + , Fibon.ConfigMonad.useGhcInPlaceDir + , Fibon.Timeout.Timeout(..) + , Fibon.ConfigMonad.FlagParameter(..) + , Fibon.ConfigMonad.Configuration + , Fibon.ConfigMonad.ConfigState(..) + , Fibon.Benchmarks.FibonGroup(..) + , Fibon.Benchmarks.FibonBenchmark(..) + , Fibon.Benchmarks.allBenchmarks + , Fibon.InputSize.InputSize(..) + , RunConfig(..) + , TuneSetting(..) + , TuneSelection(..) + , BenchmarkRunSelection(..) + , BenchmarkConfigSelection(..) + , ConfigBuilder + , ConfigId + , mkConfig +) +where +import Fibon.Benchmarks +import Fibon.BenchmarkInstance +import Fibon.InputSize +import Fibon.ConfigMonad +import Fibon.Timeout + +data RunConfig = RunConfig { + configId :: ConfigId + , sizeList :: [InputSize] + , tuneList :: [TuneSetting] + , runList :: [BenchmarkRunSelection] + , iterations :: Int + , configBuilder :: ConfigBuilder + } + +type ConfigId = String +type ConfigBuilder = TuneSelection -> BenchmarkConfigSelection -> ConfigMonad + +data TuneSetting = + Base + | Peak + deriving(Eq, Read, Show, Ord, Enum) + +data TuneSelection = + ConfigTune TuneSetting + | ConfigTuneDefault + deriving(Show, Eq, Ord) + +data BenchmarkRunSelection = + RunGroup FibonGroup + | RunSingle FibonBenchmark + deriving(Show, Eq, Ord) + +data BenchmarkConfigSelection = + ConfigBenchGroup FibonGroup + | ConfigBench FibonBenchmark + | ConfigBenchDefault + deriving(Show, Eq, Ord) + +mkConfig :: RunConfig + -> FibonBenchmark + -> InputSize + -> TuneSetting + -> Configuration +mkConfig rc bm size tune = runWithInitialFlags benchFlags configM + where + configM = mapM_ (uncurry builder) [ + (ConfigTuneDefault, ConfigBenchDefault) + , (ConfigTune tune , ConfigBenchDefault) + , (ConfigTuneDefault, ConfigBenchGroup group) + , (ConfigTune tune , ConfigBenchGroup group) + , (ConfigTuneDefault, ConfigBench bm) + , (ConfigTune tune , ConfigBench bm) + ] + builder = configBuilder rc + group = benchGroup bm + benchFlags = flagConfig $ benchInstance bm size + diff --git a/tools/fibon-run/Fibon/Run/Config/Default.hs b/tools/fibon-run/Fibon/Run/Config/Default.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/Config/Default.hs @@ -0,0 +1,25 @@ +module Fibon.Run.Config.Default ( + config +) +where +import Fibon.Run.Config + +config :: RunConfig +config = RunConfig { + configId = "default" + , runList = map RunSingle allBenchmarks + , sizeList = [Ref] + , tuneList = [Base, Peak] + , iterations = 10 + , configBuilder = build + } + +build :: ConfigBuilder +build (ConfigTune Base) ConfigBenchDefault = do + append ConfigureFlags "--disable-optimization" + +build (ConfigTune Peak) ConfigBenchDefault = do + append ConfigureFlags "--enable-optimization=2" + +build _ _ = do + done diff --git a/tools/fibon-run/Fibon/Run/Config/Local.hs b/tools/fibon-run/Fibon/Run/Config/Local.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/Config/Local.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} +module Fibon.Run.Config.Local( + configs +) +where + +import Fibon.Run.Config + +-- This includes the conifg module imports and defines the localConfigs list +#include "LocalConfigs.txt" + +configs :: [RunConfig] +configs = localConfigs + diff --git a/tools/fibon-run/Fibon/Run/Log.hs b/tools/fibon-run/Fibon/Run/Log.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/Log.hs @@ -0,0 +1,60 @@ +module Fibon.Run.Log ( + debug + , info + , notice + , warn + , Fibon.Run.Log.error + , setupLogger + , result + , summary +) +where + +import Control.Monad +import System.Directory +import System.IO +import System.Log.Logger +import System.Log.Handler.Simple +import Text.Printf +import System.FilePath + + +fibonLog :: String +fibonLog = "Fibon" + +resultLog :: String +resultLog = "Fibon.Result" + +summaryLog :: String +summaryLog = "Fibon.Summary" + +setupLogger :: FilePath -> FilePath -> String -> IO (FilePath, FilePath, FilePath) +setupLogger logDir outDir runId = do + let logFileName = printf "%s.LOG" runId + logPath = logDir logFileName + resultPath = outDir (printf "%s.RESULTS" runId) + summaryPath = outDir (printf "%s.SUMMARY" runId) + ldExists <- doesDirectoryExist logDir + unless ldExists (createDirectory logDir) + h <- openFile logPath WriteMode + ch <- streamHandler stdout NOTICE + fh <- verboseStreamHandler h DEBUG + rh <- fileHandler resultPath DEBUG + sh <- fileHandler summaryPath DEBUG + updateGlobalLogger rootLoggerName (setLevel DEBUG . setHandlers [ch,fh]) + updateGlobalLogger resultLog (setLevel DEBUG . setHandlers [rh]) + updateGlobalLogger summaryLog (setLevel DEBUG . setHandlers [sh]) + return (logPath, resultPath, summaryPath) + +debug, info, notice, warn, error :: String -> IO () +debug = debugM fibonLog +info = infoM fibonLog +notice = noticeM fibonLog +warn = warningM fibonLog +error = errorM fibonLog + +result :: String -> IO () +result = infoM resultLog + +summary :: String -> IO () +summary = infoM summaryLog diff --git a/tools/fibon-run/Fibon/Run/Main.hs b/tools/fibon-run/Fibon/Run/Main.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/Main.hs @@ -0,0 +1,177 @@ +module Main ( + main +) +where +import Control.Monad +import Control.Exception +import Data.Char +import Data.List +import Data.Time.Clock +import Data.Time.Format +import Data.Time.LocalTime +import Fibon.Benchmarks +import Fibon.Result +import Fibon.Run.Actions +import Fibon.Run.CommandLine +import Fibon.Run.Config +import Fibon.Run.Manifest +import Fibon.Run.BenchmarkBundle +import qualified Fibon.Run.Log as Log +import System.Directory +import System.Exit +import System.Environment +import System.FilePath +import System.Locale +import Text.Printf + + +main :: IO () +main = do + opts <- parseArgsOrDie + currentDir <- getCurrentDirectory + initConfig <- selectConfig (optConfig opts) + let runConfig = mergeConfigOpts initConfig opts + workingDir = currentDir "run" + benchRoot = currentDir "benchmarks/Fibon/Benchmarks" + logPath = currentDir "log" + action = optAction opts + uniq <- chooseUniqueName workingDir (configId runConfig) + (logFile, outFile, summaryFile) <- Log.setupLogger logPath logPath uniq + startTime <- timeStamp + Log.notice ("Starting Run at " ++ startTime) + Log.notice ("Logging output to " ++ logFile) + Log.notice ("Logging result to " ++ outFile) + Log.notice ("Logging summary to " ++ summaryFile) + mapM_ (runAndReport action) (makeBundles runConfig workingDir benchRoot uniq) + endTime <- timeStamp + Log.notice ("Finished Run at " ++ endTime) + Log.notice ("Logged output to " ++ logFile) + Log.notice ("Logged result to " ++ outFile) + Log.notice ("Logged summary to " ++ summaryFile) + +parseArgsOrDie :: IO Opt +parseArgsOrDie = do + args <- getArgs + case parseCommandLine args of + Left msg -> putStrLn msg >> exitFailure + Right opts -> do + case optHelpMsg opts of + Just msg -> putStrLn msg >> exitSuccess + Nothing -> return opts + +runAndReport :: Action -> BenchmarkBundle -> IO () +runAndReport action bundle = do + Log.notice $ "Benchmark: "++ (bundleName bundle)++ " action="++(show action) + case action of + Sanity -> run sanityCheckBundle (const $ return ()) + Build -> run buildBundle (\(BuildData time _size) -> do + Log.info (printf "Build completed in %0.2f seconds" time) + ) + Run -> run runBundle (\fr@(FibonResult n _bd rd) -> do + -- Log.notice (show rr) + Log.result(show fr) + Log.summary(printf "%s %.4f" n ((meanTime . summary) rd)) + ) + return () + where + run :: Show a => ActionRunner a -> (a -> IO ()) -> IO () + run = runAndLogErrors bundle + +runAndLogErrors :: Show a + => BenchmarkBundle + -> ActionRunner a + -> (a -> IO ()) + -> IO () +runAndLogErrors bundle act cont = do + result <- try (act bundle) + -- result could fail from an IOError, or from a failure in the RunMonad + case result of + Left ioe -> logError (show (ioe :: IOError)) + Right res -> + case res of + Left e -> logError (show e) >> return () + Right r -> cont r + where + name = bundleName bundle + logError s = do Log.warn $ "Error running: " ++ name + Log.warn $ " =====> " ++ s + +selectConfig :: ConfigId -> IO RunConfig +selectConfig configName = + case find ((== configName) . configId) configManifest of + Just c -> do return c + Nothing -> do + Log.error $ "Unknown config: " ++ configName + Log.error $ "Available configs:\n " ++ configNames + exitFailure + where configNames = concat (intersperse "\n " $ map configId configManifest) + +makeBundles :: RunConfig + -> FilePath -- ^ Working directory + -> FilePath -- ^ Benchmark base path + -> String -- ^ Unique Id + -> [BenchmarkBundle] +makeBundles rc workingDir benchRoot uniq = map bundle bms + where + bundle (bm, size, tune) = + mkBundle rc bm workingDir benchRoot uniq size tune + bms = sort + [(bm, size, tune) | + size <- (sizeList rc), + bm <- expandBenchList $ runList rc, + tune <- (tuneList rc)] + +expandBenchList :: [BenchmarkRunSelection] -> [FibonBenchmark] +expandBenchList = concatMap expand + where + expand (RunSingle b) = [b] + expand (RunGroup g) = filter (\b -> benchGroup b == g) allBenchmarks + +chooseUniqueName :: FilePath -> String -> IO String +chooseUniqueName workingDir configName = do + wdExists <- doesDirectoryExist workingDir + unless wdExists (createDirectory workingDir) + dirs <- getDirectoryContents workingDir + let numbered = filter (\x -> length x > 0) $ map (takeWhile isDigit) dirs + case numbered of + [] -> return $ format (0 :: Int) + _ -> return $ (format . (+1) . read . last . sort) numbered + where + format :: Int -> String + format d = printf "%03d.%s" d configName + +timeStamp :: IO String +timeStamp = do + tz <- getCurrentTimeZone + t <- getCurrentTime + return $ formatTime defaultTimeLocale "%F %T" (utcToLocalTime tz t) + +mergeConfigOpts :: RunConfig -> Opt -> RunConfig +mergeConfigOpts rc opt = rc { + tuneList = maybe (tuneList rc) (:[]) (optTuneSetting opt) + , sizeList = maybe (sizeList rc) (:[]) (optSizeSetting opt) + , runList = maybe (runList rc) id (optBenchmarks opt) + , iterations = maybe (iterations rc) id (optIterations opt) + } + +{- +dumpConfig :: RunConfig -> IO () +dumpConfig rc = do + --putStrLn $ show $ map (uncurry benchInstance) $ sort bms + putStrLn $ show bms + mapM_ (dumpInstance rc) bms + where + bms = sort + [(bm, size, tune) | + size <- (sizeList rc), + bm <- expandBenchList $ runList rc, + tune <- (tuneList rc)] + +dumpInstance :: RunConfig -> (FibonBenchmark, InputSize, TuneSetting)->IO () +dumpInstance rc inst@(bm, size, tune) = do + putStrLn (take 68 $ repeat '-') + putStrLn (show inst) + putStrLn (take 68 $ repeat '-') + putStrLn (show $ mkFlagConfig rc bm size tune) + +-} diff --git a/tools/fibon-run/Fibon/Run/Manifest.hs b/tools/fibon-run/Fibon/Run/Manifest.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/Manifest.hs @@ -0,0 +1,21 @@ +module Fibon.Run.Manifest ( + configManifest + , groupManifest + , benchmarkManifest +) +where + +import Data.List +import Fibon.Benchmarks +import Fibon.Run.Config +import Fibon.Run.Config.Default as Default +import Fibon.Run.Config.Local as Local + +configManifest :: [RunConfig] +configManifest = Default.config : Local.configs + +groupManifest :: [FibonGroup] +groupManifest = (nub . sort . map benchGroup) benchmarkManifest + +benchmarkManifest :: [FibonBenchmark] +benchmarkManifest = allBenchmarks diff --git a/tools/fibon-run/Fibon/Run/SysTools.hs b/tools/fibon-run/Fibon/Run/SysTools.hs new file mode 100644 --- /dev/null +++ b/tools/fibon-run/Fibon/Run/SysTools.hs @@ -0,0 +1,15 @@ +module Fibon.Run.SysTools ( + size + , cabal + , diff +) +where + +size :: String +size = "size" + +cabal :: String +cabal = "cabal" + +diff :: String +diff = "diff"