diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Daniel Seidel + +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 Daniel Seidel 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/SBench.cabal b/SBench.cabal new file mode 100644 --- /dev/null +++ b/SBench.cabal @@ -0,0 +1,75 @@ +Name: SBench + +Version: 0.1 + +Synopsis: A benchmark suite for runtime and heap measurements over + a series of inputs. + +Description: The package provides a framework for heap and runtime measurements + for single Haskell functions. For heap measurements simple programs + are created, compiled with profiling options and run. You can do + either a heap profile or a graph for the maximal heap consumption + of a function over different inputsizes. For runtime measurements + the criterion library is used. + + Measurement data can be stored in a special file format providing + besides the data some meta information about the measurement. + Furthermore measured data can be plotted easily using gnuplot. + In particular, it is possible to compare measurements for different + functions (e.g. different version of a semantically equivalent + function) in one diagram. By using gnuplot for drawing, the + appearance of a diagram is very flexible and can be adjusted + directly to, for example, the style of your paper. + +License: BSD3 + +License-file: LICENSE + +Author: Daniel Seidel + +Maintainer: ds@informatik.uni-bonn.de + +Category: Testing + +Stability: Experimental + +Build-type: Simple + +Extra-source-files: LICENSE + example/Fib.hs + example/NFib.hs + example/Test.hs + +Cabal-version: >=1.2 + +Library + Exposed-modules: + Test.SBench.STerm + Test.SBench.Options + Test.SBench.File.FileOps + Test.SBench.File.Types + Test.SBench.Plot.Gnuplot + Test.SBench.Time.Series.Test + Test.SBench.Space.OptionSet + Test.SBench.Space.Single.ExploreProfile + Test.SBench.Space.Single.Test + Test.SBench.Space.Series.Test + + Build-depends: + base >= 4 && <5, + criterion >= 0.5 && <0.6, + gnuplot >= 0.4.0.1 && <0.5, + hp2any-core, + deepseq, + txt-sushi >= 0.5 && <0.6, + parsec >= 3 && <= 4, + directory >= 1 && <2, + filepath, + haskell98 + + Other-modules: + Test.SBench.File.Parser + Test.SBench.Space.Single.MakeExecutable + Test.SBench.Space.Single.RunExecutable + + Hs-source-dirs: src/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Fib.hs b/example/Fib.hs new file mode 100644 --- /dev/null +++ b/example/Fib.hs @@ -0,0 +1,26 @@ +module Fib where +-- | To find more version how to calculate the Fibonacci sequence, have a look +-- at + +import Data.List + +-- | The algorithms to test + +fib1 :: Int -> Int +fib1 n = {-# SCC "fib1" #-} + let fibs = (0 : 1 : zipWith (+) (fibs) (tail fibs)) in fibs !! n + +fib2 :: Int -> Int +fib2 n = {-# SCC "fib2" #-} + snd . foldl fib' (1, 0) . map (toEnum . fromIntegral) $ unfoldl divs n + where + unfoldl f x = case f x of + Nothing -> [] + Just (u, v) -> unfoldl f v ++ [u] + + divs 0 = Nothing + divs k = Just (uncurry (flip (,)) (k `divMod` 2)) + + fib' (f, g) p + | p = (f*(f+2*g), f^2 + g^2) + | otherwise = (f^2+g^2, g*(2*f-g)) diff --git a/example/NFib.hs b/example/NFib.hs new file mode 100644 --- /dev/null +++ b/example/NFib.hs @@ -0,0 +1,17 @@ +module NFib where + +import Fib +import Test.SBench.STerm ( Algorithm, toAlgorithm, DataGen, toDataGen ) + +-- | convert the algorithm to an 'STerm' via 'toAlgorithm' with the actual term, +-- the module it is in, the name of the term and the cost center annotation as +-- arguments. +-- | Notice that putting these functions into the 'Fib' module will force you to +-- install 'SBench' with profiling options. Therefore, here an extra module is +-- preferable. +nFib1 :: Algorithm (Int -> Int) +nFib1 = toAlgorithm fib1 "Fib" "fib1" "fib1" + +nFib2 :: Algorithm (Int -> Int) +nFib2 = toAlgorithm fib2 "Fib" "fib2" "fib2" + diff --git a/example/Test.hs b/example/Test.hs new file mode 100644 --- /dev/null +++ b/example/Test.hs @@ -0,0 +1,81 @@ +module Main where + +import System ( getArgs ) + +import NFib ( nFib1, nFib2 ) + +import Test.SBench.STerm ( makeIntSeeds, toDataGen, toData, toNamedData ) +import Test.SBench.Time.Series.Test ( nfRuntimeSeries ) +import Test.SBench.Space.Single.Test ( getMemLine ) +import Test.SBench.Space.Series.Test ( maxMemSeries ) +import Test.SBench.Plot.Gnuplot ( series2scaledPlot, series2plot, sbench2scaledPlot, toDiagram, toDiagramWith ) + +import qualified Graphics.Gnuplot.Frame.OptionSet as Opt +import qualified Graphics.Gnuplot.Terminal.PostScript as PS +import qualified Graphics.Gnuplot.Terminal.PNG as PNG + +doRuntimeTests bOpts rOpts = + let seeds = makeIntSeeds 1 10000 10 in + do dat_fib1 <- nfRuntimeSeries + (Just (bOpts, rOpts, "runtime_fib1", "fib1")) + nFib1 + (toDataGen id "" "id") + seeds + dat_fib2 <- nfRuntimeSeries + (Just (bOpts, rOpts, "runtime_fib2", "fib2")) + nFib2 + (toDataGen id "" "id") + seeds + let plt_fib1 = series2scaledPlot ((/(1000 :: Double)) . fromIntegral) (*1000000) "fib1" dat_fib1 + plt_fib2 = series2scaledPlot ((/(1000 :: Double)) . fromIntegral) (*1000000) "fib2" dat_fib2 + frameOpts = [ Opt.title "runtime comparism for Fibunacci number generators" + , Opt.xLabel "number of the Fibunacci number requested (*1000)" + , Opt.yLabel "runtime (microseconds)" + ] + toDiagram "comp_runtime_fib" [PS.color] frameOpts [plt_fib1, plt_fib2] + + +-- | Create a heap profile for a function. +-- fib2 runs to fast to generate a profile, i.e., there is no sample measured, +-- so here only fib1 is measured. +doMemProfile = + let inp = toNamedData 3000000 "(3000000::Int)" in + do dat_fib1 <- getMemLine True ("memline_fib1", "fib1") nFib1 inp + let plt_fib1 = series2scaledPlot id ((/(1024*1024::Double)) . fromIntegral) "fib1" dat_fib1 + frameOpts = [ Opt.title $ "heap consumption when calculating the " + ++ show inp ++ "th Fibonacci number" + , Opt.xLabel "runtime (seconds)" + , Opt.yLabel "heap consumption (MBytes)" + ] + toDiagram "comp_memline_fib" [PS.color] frameOpts [plt_fib1] + +doMaxMemSeries = + let seeds = makeIntSeeds 1 10000 10 in + do dat_fib1 <- maxMemSeries True ("memline_fib1", "fib1") nFib1 (toDataGen id "" "id") seeds + dat_fib2 <- maxMemSeries True ("memline_fib2", "fib2") nFib2 (toDataGen id "" "id") seeds + let plt_fib1 = series2scaledPlot ((/(1000 :: Double)) . fromIntegral) ((/(1024::Double)) . fromIntegral) "fib1" dat_fib1 + plt_fib2 = series2scaledPlot ((/(1000 :: Double)) . fromIntegral) ((/(1024::Double)) . fromIntegral) "fib2" dat_fib2 + frameOpts = [ Opt.title $ "comparism of maximal heap consumption for Fibonacci number generators" + , Opt.xLabel "number of the Fibunacci number requested (*1000)" + , Opt.yLabel "heap consumption (kBytes)" + ] + toDiagram "comp_maxmem_fib" [PS.color] frameOpts [plt_fib1, plt_fib2] + +redoRuntimePlotAsPNG = do + plt_fib1 <- sbench2scaledPlot (/1000) (*1000000) "runtime_fib1" + plt_fib2 <- sbench2scaledPlot (/1000) (*1000000) "runtime_fib2" + let frameOpts = [ Opt.title "runtime comparism for Fibunacci number generators" + , Opt.xLabel "number of the Fibunacci number requested (*1000)" + , Opt.yLabel "runtime (microseconds)" + ] + toDiagramWith (PNG.cons "comp_runtime_fib.png") frameOpts [plt_fib1, plt_fib2] + +main = do + let bOpts = "unknown" + rOpts = "unknown" + print bOpts + print rOpts + doRuntimeTests bOpts rOpts + doMemProfile + doMaxMemSeries + redoRuntimePlotAsPNG diff --git a/src/Test/SBench/File/FileOps.hs b/src/Test/SBench/File/FileOps.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/File/FileOps.hs @@ -0,0 +1,160 @@ +module Test.SBench.File.FileOps ( + criterion2series + , series2sbench + , series2sbench' + , sbench2series + ) where + +import Database.TxtSushi.FlatFile (csvFormat, parseTable) +import System.IO ( FilePath, openFile, hClose, hGetContents, hPutStr, IOMode (..) ) +import System.Directory ( doesFileExist ) +import System.FilePath ( addExtension, dropExtension, takeExtension ) +import Data.List ( findIndex ) +import Test.SBench.File.Types ( MetaInfo(..), Range(..) ) +import Test.SBench.File.Parser ( getWholeFile ) +import Test.SBench.STerm ( Algorithm, DataGen, Data, STerm (..) ) +import Test.SBench.Options ( EvalMod, Title ) + +import Data.List ( foldl' ) + +-- | File format version. +version = "0.1" + +type CriterionFile = FilePath +type SBenchFile = FilePath + + +-- * Get data from Criterion files + +-- | Extract the mean runtimes from a criterion data file. +readMeans :: CriterionFile -> IO [String] +readMeans fin = + do + exists <- doesFileExist fin + if exists + then + do + filecont <- myReadFile fin + let (header : body) = parseTable csvFormat filecont + meanIndex = findIndex ( == "Mean") header + case meanIndex of + Nothing -> error $ "Criterion-File " ++ " is in a wrong format." + Just i -> return $ map (!! i) body + else error $ "File " ++ fin ++ " does not exist." + +-- | Read the mean runtimes of a criterion data file and tuple them with seeds +-- to a seed-runtime series. +criterion2series :: Num a => [a] -> CriterionFile -> IO [(a, Double)] +criterion2series seeds file = do + means <- readMeans file + return $ zip seeds (map read means) + + +-- * Store and read data series from SBench data files + +-- | Store a series of measurements over /different inputs/ in a .sbench file. +-- The SBench file format take some extra information about the measurement. +series2sbench :: (Real a, Real b) => + (String, String) -- ^ (build options, runtime options) used for the measurement. + -> Maybe EvalMod -- ^ Evaluation mode for the input (e.g. as given to criterion for time measurements) + -> Algorithm (c -> d) -- ^ The function tested. + -> DataGen (e -> c) -- ^ The data generator used. + -> Title -- ^ Name the measurement should get when the graph is plotted. + -> SBenchFile -- ^ File the data should be stored in. + -> [(a, b)] -- ^ Data. + -> IO SBenchFile -- ^ The generated data file. +series2sbench (bOpts, eOpts) evMod alg gen title file ser = do + let mi = prepareMetaInfo + fout = (addExtension (dropExtension file) "sbench") + print $ "creating sbench data file " ++ fout ++ "..." + generateFile mi ser fout + return fout + where + generateFile :: (Real a, Real b) => MetaInfo a b -> [(a, b)] -> FilePath -> IO () + generateFile mi ser fout = + myWriteFile fout $ show mi ++ toGNUStyle ser + prepareMetaInfo = + MetaInfo + { header = ["This file was automatically generated by SBench"] + , sbenchVersion = version + , graphRanges = getRanges $ ser + , miGraphTitle = title + , miAlgName = stName alg + , miGenName = Left $ stName gen + , evalMod = evMod + , buildOptions = bOpts + , exeOptions = eOpts + } + getRanges [] = (AutoRange, AutoRange) + getRanges ((x,y):ps) = foldl' adjustRanges (ManRange (x,x), ManRange (y,y)) ps + adjustRanges (r1, r2) (v1, v2) = (adjustRange r1 v1, adjustRange r2 v2) + adjustRange (ManRange (d1, d2)) d = ManRange (min d1 d, max d2 d) + +-- | Store a series of measurements with /a single input/ in a .sbench file. +-- The SBench file format take some extra information about the measurement. +series2sbench' :: (Real a, Real b) => + (String, String) -- ^ (build options, runtime options) used for the measurement. + -> Maybe EvalMod -- ^ Evaluation mode for the input (e.g. as given to criterion for time measurements) + -> Algorithm (c -> d) -- ^ The function tested. + -> Data c -- ^ The data used. + -> Title -- ^ Name the measurement should get when the graph is plotted. + -> SBenchFile -- ^ File the data should be stored in. + -> [(a, b)] -- ^ Data. + -> IO SBenchFile -- ^ The generated data file. +series2sbench' (bOpts, eOpts) evMod alg inp title file ser = do + let mi = prepareMetaInfo + fout = (addExtension (dropExtension file) "sbench") + print $ "creating sbench data file " ++ fout ++ "..." + generateFile mi ser fout + return fout + where + generateFile :: (Real a, Real b) => MetaInfo a b -> [(a, b)] -> FilePath -> IO () + generateFile mi ser fout = + myWriteFile fout $ show mi ++ toGNUStyle ser + prepareMetaInfo = + MetaInfo + { header = ["This file was automatically generated by SBench"] + , sbenchVersion = version + , graphRanges = getRanges $ ser + , miGraphTitle = title + , miAlgName = stName alg + , miGenName = Right $ stName inp + , evalMod = evMod + , buildOptions = bOpts + , exeOptions = eOpts + } + getRanges [] = (AutoRange, AutoRange) + getRanges ((x,y):ps) = foldl' adjustRanges (ManRange (x,x), ManRange (y,y)) ps + adjustRanges (r1, r2) (v1, v2) = (adjustRange r1 v1, adjustRange r2 v2) + adjustRange (ManRange (d1, d2)) d = ManRange (min d1 d, max d2 d) + + +-- | Read a measurment series from a .sbench data file. +-- Additionally to the measurement series a data structure with meta informations is returned. +sbench2series :: FilePath -> IO (MetaInfo Double Double, [(Double, Double)]) +sbench2series file = + let f = if takeExtension file == "sbench" + then file + else addExtension file "sbench" + in getWholeFile f + + +-- * Auxiliar functions + +toGNUStyle :: (Show a, Show b) => [(a, b)] -> String +toGNUStyle = foldr (++) "" . map (\(g, r) -> show g ++ "\t" ++ show r ++ "\n") + +myWriteFile :: FilePath -> String -> IO () +myWriteFile f s = do + hfile <- openFile f WriteMode + hPutStr hfile s + hClose hfile + + +-- strict read version +myReadFile :: FilePath -> IO String +myReadFile f = do + hfile <- openFile f ReadMode + s <- hGetContents hfile + seq (length s) $ hClose hfile + return s diff --git a/src/Test/SBench/File/Parser.hs b/src/Test/SBench/File/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/File/Parser.hs @@ -0,0 +1,246 @@ +-- | Parser for SBench data files. +module Test.SBench.File.Parser + ( getMetaInfo + , getWholeFile + ) where + +import Text.Parsec.String ( Parser(..), parseFromFile) +import Text.Parsec.Error ( ParseError ) +import Text.Parsec.Combinator ( manyTill, many1, sepBy, count ) +import Text.Parsec.Prim ( many, (), (<|>), try ) +import Text.Parsec.Char ( anyChar, spaces, string, newline, digit, char ) +import System.FilePath ( FilePath ) +import Test.SBench.File.Types ( MetaInfo(..), Range(..) ) +import Test.SBench.Options ( EvalMod (..) ) + + +getMetaInfo :: FilePath -> IO (MetaInfo Double Double) +getMetaInfo file = do + emi <- parseFromFile metaInfoParser file + case emi of + Left err -> error $ show err + Right mi -> return mi + +getWholeFile :: FilePath -> IO (MetaInfo Double Double, [(Double,Double)]) +getWholeFile file = do + emi <- parseFromFile wholeFileParser file + case emi of + Left err -> error $ show err + Right mi -> return mi + +wholeFileParser :: Parser (MetaInfo Double Double, [(Double,Double)]) +wholeFileParser = do + mi <- metaInfoParser + dat <- dataParser + return (mi, dat) + +metaInfoParser :: Parser (MetaInfo Double Double) +metaInfoParser = do + hs <- many $ try headerLineParser + v <- versionParser + pt <- graphTitleParser + alg <- algNameParser + gen <- genNameParser + evMod <- evalModParser + prs <- graphRangesParser + bopts <- buildOptsParser + eopts <- exeOptsParser + return MetaInfo { + header = hs + , sbenchVersion = v + , miGraphTitle = pt + , miAlgName = alg + , miGenName = gen + , evalMod = evMod + , graphRanges = prs + , buildOptions = bopts + , exeOptions = eopts + } + +headerLineParser :: Parser String +headerLineParser = do + commentLine "HeaderLineParser: Expected Line to start with '#'.\n" + spaces + string "header: " + manyTill anyChar newline + +versionParser :: Parser String +versionParser = do + commentLine "versionParser: Expected Line to start with '#'.\n" + spaces + string "SBench version:" "expected SBench version number" + spaces + andNewLine (vnumParser "Invalid SBench version number.") + where + vnumParser :: Parser String + vnumParser = do main <- many1 digit + subs <- many subnum + return $ foldl (++) main subs + subnum = do char '.' + ds <- many1 digit + return $ '.' : ds + +testNameParser :: Parser String +testNameParser = do + commentLine "testNameParser: Expected Line to start with '#'.\n" + spaces + string "test name:" "expected test name" + spaces + andNewLine wordParser + +genDimParser :: Parser Int +genDimParser = do + commentLine "genDimParser: Expected Line to start with '#'.\n" + spaces + string "number of generators:" + spaces + snum <- andNewLine $ many1 digit + return ((read snum) :: Int) + +graphTitleParser :: Parser String +graphTitleParser = do + commentLine "graphTitleParser: Expected Line to start with '#'.\n" + spaces + string "graph title:" "expected graph title" + spaces + andNewLine wordParser + +algNameParser :: Parser String +algNameParser = do + commentLine "algNameParser: Expected Line to start with '#'.\n" + spaces + string "tested algorithm: " "expected name of tested algorithm" + spaces + andNewLine wordParser + +genNameParser :: Parser (Either String String) +genNameParser = do + commentLine "genNameParser: Expected Line to start with '#'.\n" + spaces + string "input" + (try inputParser) <|> inputGenParser + where inputParser = do string ": " + spaces + n <- andNewLine wordParser + return (Right n) + inputGenParser = do string " generator: " "expected name of the input generator or input" + spaces + n <- andNewLine wordParser + return (Left n) + +evalModParser :: Parser (Maybe EvalMod) +evalModParser = do + commentLine "evalModParser: Expected Line to start with '#'.\n" + spaces + string "evaluation mode: " "expected evaluation mode" + spaces + andNewLine (evMod <|> return Nothing) + where + evMod = ((string "nf" >> return (Just NF)) <|> (string "whnf" >> return (Just WHNF))) + +buildOptsParser :: Parser String +buildOptsParser = do + commentLine "buildOptsParser: Expected Line to start with '#'.\n" + spaces + string "build options: " "expected build options" + spaces + andNewLine wordParser + +exeOptsParser :: Parser String +exeOptsParser = do + commentLine "exeOptsParser: Expected Line to start with '#'.\n" + spaces + string "execution options: " "expected execution options" + spaces + andNewLine wordParser + +graphRangesParser :: Parser (Range Double, Range Double) +graphRangesParser = do + commentLine "graphRangesParser: Expected Line to start with '#'.\n" + spaces + string "graph ranges:" "expected graph ranges" + spaces + let p = try autoParser <|> manParser + andNewLine $ pairParser p p + where + autoParser :: Parser (Range Double) + autoParser = do string "Auto" + return AutoRange + manParser :: Parser (Range Double) + manParser = do + r <- pairParser doubleParser doubleParser + return $ ManRange r + +pairParser :: Parser a -> Parser b -> Parser (a, b) +pairParser p1 p2 = do + rmAllWhiteParser '(' + c1 <- p1 + rmAllWhiteParser ',' + c2 <- p2 + rmLeadingWhiteParser ')' + return (c1, c2) + +doubleParser :: Parser Double +doubleParser = do + i <- many digit + f <- (char '.' >> many digit) <|> return "0" + e <- do char 'e' + s <- string "+" <|> string "-" <|> return "+" + e <- many1 digit + return $ "e" ++ s ++ e + <|> return "" + return $ (read (i ++ "." ++ f ++ e) :: Double) + +intParser :: Parser Int +intParser = do + i <- many1 digit "expected an integer" + return (read i :: Int) + +axisLabelParser :: Parser [String] +axisLabelParser = do + commentLine "axisLabelParser: Expected Line to start with '#'.\n" + spaces + string "axis labels:" "expected axis labels" + spaces + andNewLine $ listParser wordParser + +rmAllWhiteParser :: Char -> Parser () +rmAllWhiteParser c = spaces >> char c >> spaces + +rmLeadingWhiteParser :: Char -> Parser () +rmLeadingWhiteParser c = spaces >> char c >> return () + + + +listParser :: Parser a -> Parser [a] +listParser p = do + rmAllWhiteParser '[' + ret <- sepBy p (rmAllWhiteParser ',') + rmLeadingWhiteParser ']' + return ret + +wordParser :: Parser String +wordParser = char '"' >> manyTill anyChar (char '"') + +andNewLine :: Parser a -> Parser a +andNewLine p = do + ret <- p + manyTill anyChar newline + return ret + +commentLine :: Parser () +commentLine = many1 (char '#') >> return () + +dataParser :: Parser [(Double, Double)] +dataParser = many $ oneDataLineParser + +oneDataLineParser :: Parser (Double, Double) +oneDataLineParser = do + gens <- spaces >> doubleParser + rt <- andNewLine $ spaces >> doubleParser + return (gens, rt) + + + + + diff --git a/src/Test/SBench/File/Types.hs b/src/Test/SBench/File/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/File/Types.hs @@ -0,0 +1,50 @@ +module Test.SBench.File.Types ( MetaInfo(..), Range(..) ) where + +import Test.SBench.Options ( EvalMod ) + +-- | Metainformation stored in the header of all .sbench files. +-- Part of the 'MetaInfo' entries are usually calculated automatically. +data (Real a, Real b) => MetaInfo a b = MetaInfo + { header :: [String] + , sbenchVersion :: String + , miGraphTitle :: String + , miAlgName :: String + , miGenName :: Either String String -- | 'Left' means an input generator, + -- 'Right' a single input + , evalMod :: Maybe EvalMod + , graphRanges :: (Range a, Range b) + , buildOptions :: String + , exeOptions :: String + } + +instance (Real a, Real b) => Show (MetaInfo a b) where + show = showMetaInfo + +showMetaInfo mi = foldr (\x y -> x ++ "\n" ++ y) "" lines + where + lines = map ("#" ++) lines' + lines' = map ("header: " ++) (header mi) + ++ ["SBench version: " ++ sbenchVersion mi] + ++ ["graph title: " ++ toWord (miGraphTitle mi)] + ++ ["tested algorithm: " ++ toWord (miAlgName mi)] + ++ inputOrInputGen (miGenName mi) + ++ ["evaluation mode: " ++ showEvalMod (evalMod mi)] + ++ ["graph ranges: " ++ showGraphRanges (graphRanges mi)] + ++ ["build options: " ++ toWord (buildOptions mi)] + ++ ["execution options: " ++ toWord (exeOptions mi)] + showGraphRanges = showPairWith showGraphRange showGraphRange + showAxisLabels = showListWith toWord + showListWith p xs = "[" ++ showListWith' p xs ++ "]" + showListWith' p [] = "" + showListWith' p [x] = p x + showListWith' p (x:xs) = p x ++ ", " ++ showListWith' p xs + showPairWith s1 s2 (x, y) = "(" ++ s1 x ++ ", " ++ s2 y ++ ")" + showGraphRange AutoRange = "Auto" + showGraphRange (ManRange p) = show p + toWord s = "\"" ++ s ++ "\"" + showEvalMod (Just evm) = show evm + showEvalMod Nothing = "unknown" + inputOrInputGen (Left gen) = ["input generator: " ++ toWord gen] + inputOrInputGen (Right inp) = ["input: " ++ toWord inp] + +data (Real a) => Range a = AutoRange | ManRange (a, a) diff --git a/src/Test/SBench/Options.hs b/src/Test/SBench/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Options.hs @@ -0,0 +1,94 @@ +module Test.SBench.Options + ( ProfParam (..) -- | re-export from "Profiling.Heap.Process" + , Breakdown (..) -- | re-export from "Profiling.Heap.Process" + , Restriction (..) -- | re-export from "Profiling.Heap.Process" + , Imports + , CompilerOptions (..) + , ProgramArguments (..) + , MemoryOptions (..) + , ProfilingOptions (..) + , Repetitions (..) + , ThreadNum (..) + , MemUnit (..) + , MemSize (..) + , TestOpts (..) + , RuntimeOptions (..) + , EvalMod(..) + , NormalInput + , opts2string + , Title + ) where + +import Profiling.Heap.Process ( ProfParam (..) + , Breakdown (..) + , Restriction (..) + ) + +import Data.List ( foldl' ) + +data TestOpts = TOpts + { cOpts :: CompilerOptions + , rOpts :: RuntimeOptions + , reps :: Maybe Repetitions + , nfInp :: NormalInput + } + +type CompilerOptions = [String] + +data RuntimeOptions = ROpts + { threadNum :: Maybe ThreadNum + , profOpts :: ProfilingOptions + , memOpts :: MemoryOptions + , progArgs :: ProgramArguments + } + +instance Show RuntimeOptions where + show rtopts = + let showProgArgs = opts2string $ progArgs rtopts + showMemOpts = opts2string $ map show $ memOpts rtopts + showThreadNum = case threadNum rtopts of + Nothing -> "" + Just i -> "-N" ++ show i + showProfOpts = opts2string $ map show $ profOpts rtopts + in opts2string [showProgArgs, showMemOpts, showThreadNum, showProfOpts] + +type ThreadNum = Int +type ProfilingOptions = [ProfParam] +type MemoryOptions = [MemSize] + +data MemSize = Heap Int MemUnit + | Stack Int MemUnit + +instance Show MemSize where + show (Heap a m) = "-H" ++ show a ++ show m + show (Stack a m) = "-K" ++ show a ++ show m + +data MemUnit = G | M | K | B + +instance Show MemUnit where + show G = "G" + show M = "M" + show K = "K" + show B = "B" + +type ProgramArguments = [String] + +type Repetitions = Int +type NormalInput = Bool + +data EvalMod = NF | WHNF + +instance Show EvalMod where + show NF = "nf" + show WHNF = "whnf" + +type Imports = [String] + + +opts2string :: [String] -> String +opts2string = maybeTail . foldl' (\x y -> x ++ " " ++ y) "" + where + maybeTail [] = [] + maybeTail (x:xs) = xs + +type Title = String diff --git a/src/Test/SBench/Plot/Gnuplot.hs b/src/Test/SBench/Plot/Gnuplot.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Plot/Gnuplot.hs @@ -0,0 +1,171 @@ +-- | Interface functions to the "gnuplot" package for generating plots. +module Test.SBench.Plot.Gnuplot ( + series2plot + , series2scaledPlot + , series2plotWith + , series2scaledPlotWith + , series2plotWithLinestyle + , series2scaledPlotWithLinestyle + , sbench2plot + , sbench2scaledPlot + , sbench2plotWithLinestyle + , sbench2scaledPlotWithLinestyle + , sbench2plotWith + , sbench2scaledPlotWith + , toDiagram + , toDiagramWith + ) where + +import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D +import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D +import qualified Graphics.Gnuplot.Frame.OptionSet as Opts +import qualified Graphics.Gnuplot.LineSpecification as LineSpec +import qualified Graphics.Gnuplot.Advanced as GPlot ( plot ) +import qualified Graphics.Gnuplot.Frame as Frame +import qualified Graphics.Gnuplot.Terminal.PostScript as PostScript +import qualified Graphics.Gnuplot.Value.Tuple as TVal +import qualified Graphics.Gnuplot.Value.Atom as AVal +import qualified Graphics.Gnuplot.Graph as Graph +import Data.Monoid ( mappend, mempty ) +import System.FilePath ( (<.>) ) +import System ( system ) +import Test.SBench.Options ( Title ) +import Test.SBench.File.FileOps ( sbench2series ) +import Test.SBench.File.Types ( MetaInfo(..) ) + +-- * Plot from a data series + +series2plot :: (TVal.C a, AVal.C a, TVal.C b, AVal.C b) => + Title -- ^ Title of the graph. + -> [(a, b)] -- ^ Data to plot. + -> Plot2D.T a b -- ^ The plot. +series2plot = series2scaledPlot id id + +series2scaledPlot :: (TVal.C c, AVal.C c, TVal.C d, AVal.C d) => + (a -> c) -- ^ scale x-axis + -> (b -> d) -- ^ scale y-axis + -> Title -- ^ Title of the graph. + -> [(a, b)] -- ^ Data to plot. + -> Plot2D.T c d -- ^ The plot. +series2scaledPlot xscaler yscaler t s = + let s' = scaleSeries xscaler yscaler s in + Graph2D.lineSpec (LineSpec.title t $ LineSpec.deflt) `fmap` Plot2D.list Graph2D.lines s' + +series2plotWithLinestyle :: (TVal.C a, AVal.C a, TVal.C b, AVal.C b) => + Int -- ^ Linestyle. See 'gnuplot' manual. + -> Title -- ^ Title of the graph. + -> [(a, b)] -- ^ Data to plot + -> Plot2D.T a b -- ^ the plot. +series2plotWithLinestyle linestyle = series2scaledPlotWithLinestyle linestyle id id + +series2scaledPlotWithLinestyle :: (TVal.C c, AVal.C c, TVal.C d, AVal.C d) => + Int -- ^ Linestyle. See 'gnuplot' manual. + -> (a -> c) -- ^ scale x-axis + -> (b -> d) -- ^ scale y-axis + -> Title -- ^ Title of the graph. + -> [(a, b)] -- ^ Data to plot + -> Plot2D.T c d -- ^ the plot. +series2scaledPlotWithLinestyle linestyle xscaler yscaler title = + series2scaledPlotWith [LineSpec.title title, LineSpec.lineStyle linestyle] xscaler yscaler + +series2plotWith :: (TVal.C a, AVal.C a, TVal.C b, AVal.C b) => + [LineSpec.T -> LineSpec.T] -- ^ Line specification, see "Graphics.Gnuplot.LineSpecification". + -> [(a, b)] -- ^ Data to plot + -> Plot2D.T a b -- ^ the plot. +series2plotWith opts = series2scaledPlotWith opts id id + +series2scaledPlotWith :: (TVal.C c, AVal.C c, TVal.C d, AVal.C d) => + [LineSpec.T -> LineSpec.T] -- ^ Line specification, see "Graphics.Gnuplot.LineSpecification". + -> (a -> c) -- ^ scale x-axis + -> (b -> d) -- ^ scale y-axis + -> [(a, b)] -- ^ Data to plot + -> Plot2D.T c d -- ^ the plot. +series2scaledPlotWith opts xscaler yscaler s = + let s' = scaleSeries xscaler yscaler s in + Graph2D.lineSpec (makeGraphOpts opts) `fmap` Plot2D.list Graph2D.lines s' + + +-- * Plot from a .sbench data file + +sbench2plot :: FilePath -> IO (Plot2D.T Double Double) +sbench2plot = sbench2scaledPlot id id + +sbench2scaledPlot :: (Double -> Double) -- ^ scale x-axis + -> (Double -> Double) -- ^ scale y-axis + -> FilePath -- ^ data file + -> IO (Plot2D.T Double Double) -- ^ produced plot +sbench2scaledPlot xscaler yscaler file = do + (mi, s) <- sbench2series file + return $ series2scaledPlot xscaler yscaler (miGraphTitle mi) s + +sbench2plotWithLinestyle :: Int -- ^ Linestyle. See 'gnuplot' manual. + -> FilePath -- ^ data file + -> IO (Plot2D.T Double Double) -- ^ produced plot +sbench2plotWithLinestyle linestyle = sbench2scaledPlotWithLinestyle linestyle id id + +sbench2scaledPlotWithLinestyle :: Int -- ^ Linestyle. See 'gnuplot' manual. + -> (Double -> Double) -- ^ scale x-axis + -> (Double -> Double) -- ^ scale y-axis + -> FilePath -- ^ data file + -> IO (Plot2D.T Double Double) -- ^ produced plot +sbench2scaledPlotWithLinestyle linestyle xscaler yscaler file = do + (mi, s) <- sbench2series file + return $ series2scaledPlotWith [LineSpec.title (miGraphTitle mi), LineSpec.lineStyle linestyle] xscaler yscaler s + +sbench2plotWith :: [LineSpec.T -> LineSpec.T] -- ^ Line specifications. See "Graphics.Gnuplot.LineSpecification" + -> FilePath -- ^ data file + -> IO (Plot2D.T Double Double) -- ^ produced plot +sbench2plotWith lineOpts = sbench2scaledPlotWith lineOpts id id + +sbench2scaledPlotWith :: [LineSpec.T -> LineSpec.T] -- ^ Line specifications. See "Graphics.Gnuplot.LineSpecification" + -> (Double -> Double) -- ^ scale x-axis + -> (Double -> Double) -- ^ scale y-axis + -> FilePath -- ^ data file + -> IO (Plot2D.T Double Double) -- ^ produced plot +sbench2scaledPlotWith lineOpts xscaler yscaler file = do + (mi, s) <- sbench2series file + return $ series2scaledPlotWith lineOpts xscaler yscaler s + +-- * Combine plots to a diagram + +-- | Produces a diagram with several plots inside. +-- +-- The parameters are as follows +-- [@terminal@] Choose the output terminal. See "Graphics.Gnuplot.Terminal" +-- [@opts@] Frame options, e.g. title. See "Graphics.Gnuplot.Frame.OptionSet" +-- [@plots@] List of plots to be shown in the diagram. +toDiagramWith terminal opts plots = + GPlot.plot terminal gr + where + gr = Frame.cons (makeFrameOpts opts) $ combinePlots plots + +-- | Compared to 'toDiagramWith', the output terminal is fixed to +-- "Graphics.Gnuplot.Terminal.PostScript" and the resulting +-- .eps file is transformed to a .pdf via a call to 'epstopdf'. +-- +-- The parameters are as follows +-- [@name@] Choose the output terminal. See "Graphics.Gnuplot.Terminal" +-- [@topts@] Frame options, e.g. title. See "Graphics.Gnuplot.Frame.OptionSet" +-- [@opts@] List of plots to be shown in the diagram. +-- [@plots@] List of plots to be shown in the diagram. +toDiagram name topts opts plots = + let file = name <.> "eps" + plt = (Frame.cons (makeFrameOpts opts) (combinePlots plots)) + in + GPlot.plot (foldr ($) (PostScript.cons file) topts) plt + >> system ("epstopdf " ++ file) + >> return (name <.> "pdf") + +-- * Auxiliar functions + +--scaleSeries :: (a -> b) -> (c -> d) -> [(a, c)] -> [(b, d)] +scaleSeries xscaler yscaler = map (\(x,y) -> (xscaler x, yscaler y)) + +makeGraphOpts :: [LineSpec.T -> LineSpec.T] -> LineSpec.T +makeGraphOpts = foldr ($) LineSpec.deflt + +makeFrameOpts :: Graph.C graph => [Opts.T graph -> Opts.T graph] -> Opts.T graph +makeFrameOpts = foldr ($) Opts.deflt + +combinePlots :: (TVal.C a, AVal.C a, TVal.C b, AVal.C b) => [Plot2D.T a b] -> Plot2D.T a b +combinePlots = foldr mappend mempty diff --git a/src/Test/SBench/STerm.hs b/src/Test/SBench/STerm.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/STerm.hs @@ -0,0 +1,84 @@ +-- | The provided data type 'STerm' is intended to store a term equipped with +-- its own name and maybe some extra information about its cost center +-- annotation and modules that need to be loaded when evaluating the term. +-- +-- The additional information, provided as strings, is necessary for space +-- measurements where small programs are constructed from the strings and run +-- for heap profiling. + +module Test.SBench.STerm + ( CostCenter + , DataGen + , Algorithm + , Data + , Seed + , Test + , STerm (..) + , toData + , toNamedData + , toDataGen + , toAlgorithm + , (<$>) + , getImports + , makeSeeds + , makeIntSeeds + ) where + +import Data.List ( nub ) + +type CostCenter = String +type ModuleName = String +type TermName = String + +data STerm a = T { stTerm :: a -- ^ The actual term. + , stName :: TermName -- ^ The term as 'String' + , stModules :: [ModuleName] -- ^ The modules used when evaluation the term + , stCC :: [CostCenter] -- ^ cost centers to measure when performing + -- heap profiling. + } + +instance Show (STerm a) where + show t = stName t + +-- Aliases for 'STerm', all suggesting different use. +type Algorithm a = STerm a +type DataGen a = STerm a +type Data a = STerm a +type Seed a = STerm a +type Test a b = Data a -> FilePath -> IO b + + +-- Auxiliar generator functions for 'STerm's. +toAlgorithm :: (a -> b) -> ModuleName -> TermName -> CostCenter -> Algorithm (a -> b) +toAlgorithm alg mn tn cc = T alg (mn ++ "." ++ tn) [mn] [cc] + +toDataGen :: (a -> b) -> ModuleName -> TermName -> Data (a -> b) +toDataGen f "" tn = T f tn [] [] +toDataGen f mn tn = T f (mn ++ "." ++ tn) [mn] [] + +toData :: (Show a) => a -> STerm a +toData a = T a (show a) [] [] + +toNamedData :: (Show a) => a -> TermName -> STerm a +toNamedData a n = T a n [] [] + +makeSeeds :: (Integral a) + => a -- ^ minimal value + -> a -- ^ maximal value + -> a -- ^ number of seeds + -> [Seed a] +makeSeeds min max steps = map toData [min, (min + ((max - min) `div` steps)) .. max] + +-- | Auxiliar version of 'makeSeeds' to prevent defaulting to 'Integer'. +makeIntSeeds :: Int -> Int -> Int -> [Seed Int] +makeIntSeeds = makeSeeds + + +-- | Function application for 'STerm'. +(<$>) :: STerm (a -> b) -> STerm a -> STerm b +(<$>) (T f sf ms1 cc1) (T a sa ms2 cc2) = + T (f a) (sf ++ " " ++ sa) (nub (ms1 ++ ms2)) (nub (cc1 ++ cc2)) + +getImports :: STerm a -> String +getImports = unlines . map ("import qualified " ++) . stModules + diff --git a/src/Test/SBench/Space/OptionSet.hs b/src/Test/SBench/Space/OptionSet.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Space/OptionSet.hs @@ -0,0 +1,73 @@ +module Test.SBench.Space.OptionSet where + +import Test.SBench.Options +import Test.SBench.STerm ( Algorithm, STerm(..) ) + +-- | * Compiler options + +-- | Options always added when compiling for space profiling. +generalCOpts :: CompilerOptions +generalCOpts = + [ "--make" + , "-prof" + ] + +-- | default compiler options additional to 'generalCOpts'. +defltCOpts :: CompilerOptions +defltCOpts = + [ "-auto-all" + , "-caf-all" + , "-O2" + ] + + +-- * Build options + +-- | By default repetitions are calculated automatically +defltRep :: Maybe Repetitions +defltRep = Nothing + +-- | Default profiling options. +defltProfOpts :: ProfilingOptions +defltProfOpts = + [ PPBreakdown BCostCentreStack -- RTS heap prof settings + , PPInterval 0.02 + , PPNameLength 60 + ] + +-- | Default test options, i.e. default options for compiling and running +-- a program for space profiling. +defltTestOpts :: TestOpts +defltTestOpts = TOpts + { cOpts = defltCOpts + , rOpts = ROpts + { threadNum = Nothing + , profOpts = defltProfOpts + , memOpts = [] + , progArgs = [] + } + , reps = Nothing + , nfInp = False + } + +addCC :: Algorithm a -> TestOpts -> TestOpts +addCC alg opts = + opts { + rOpts = (rOpts opts) { + profOpts = PPRestriction RCCStackAny (stCC alg) : (profOpts (rOpts opts)) + } + } + +setRepetitions :: Repetitions -> TestOpts -> TestOpts +setRepetitions rep opts = opts { reps = Just rep } + +autoRepeat :: TestOpts -> TestOpts +autoRepeat opts = opts { reps = Nothing } + +setMemSizes :: [MemSize] -> TestOpts -> TestOpts +setMemSizes ms opts = + opts {rOpts = (rOpts opts) {memOpts = ms } } + +setNfInput :: Bool -> TestOpts -> TestOpts +setNfInput b opts = opts { nfInp = b } + diff --git a/src/Test/SBench/Space/Series/Test.hs b/src/Test/SBench/Space/Series/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Space/Series/Test.hs @@ -0,0 +1,52 @@ +module Test.SBench.Space.Series.Test ( + makeSeries + , maxMemSeries + , maxMemSeriesWith + ) where + +import Test.SBench.Options ( NormalInput, TestOpts(..) ) +import Test.SBench.STerm ( Algorithm, DataGen, Seed, Data, STerm(..), (<$>) ) +import Test.SBench.Space.OptionSet ( setNfInput, addCC, defltTestOpts ) +import Test.SBench.Space.Single.Test ( getMaxMemWith ) +import Test.SBench.Options ( opts2string, Title ) +import Test.SBench.File.FileOps ( series2sbench ) + +import System.FilePath ( FilePath ) +import Control.Monad ( liftM ) + +makeSeries :: (Real c, Real d) => + (TestOpts -> Algorithm (a -> b) -> Data a -> FilePath -> IO d) -- ^ Function for a single test. + -> TestOpts + -> (FilePath, Title) -- ^ File where the result data should be stored and title for the + -- measurement graph (stored as meta information in the .sbench file) + -> Algorithm (a -> b) -- ^ Function to be tested + -> DataGen (c -> a) -- ^ Input data generator. It is fed with the input seeds. + -> [Seed c] -- ^ Input seeds, given to the input data generator to produce an input. + -> IO [(c, d)] -- ^ List of input seed-measurement pairs. +makeSeries fun topts (outf, title) alg gen seeds = + let b = opts2string $ cOpts topts + r = show $ rOpts topts + in do + s <- liftM (zip (map stTerm seeds)) (mapM go seeds) + series2sbench (b, r) Nothing alg gen title outf s >> return s + where + tst = fun topts alg + go i = tst (gen <$> i) (outf ++ stName i) + +-- | The function measures the maximal heap consumption of a given function over a series of different inputs +-- that are produced via an input generator given different seeds. +maxMemSeries :: Real c => + NormalInput -- ^ Shall input data first be normalized? (Boolean value) + -> (FilePath, Title) -- ^ Output data file (will get extension .sbench) and title for the + -- graph of the data stored as meta information. + -> Algorithm (a -> b) -- ^ Function to benchmark + -> DataGen (c -> a) -- ^ Input data generator. It is fed with the input seeds. + -> [Seed c] -- ^ Input seeds, given to the input data generator to produce an input. + -> IO [(c, Integer)] -- ^ List of input seed-maximal heap consumption pairs. +maxMemSeries nfinp ft alg = maxMemSeriesWith (setNfInput nfinp $ addCC alg $ defltTestOpts) ft alg + +-- | The function acts similar to 'maxMemSeries', but instead of only 'NormalInput', 'TestOpts' can be set manually +-- via the first parameter. +maxMemSeriesWith :: Real c => TestOpts -> (FilePath, Title) -> Algorithm (a -> b) -> DataGen (c -> a) -> [Seed c] -> IO [(c, Integer)] +maxMemSeriesWith topts ft alg gen seeds = + makeSeries getMaxMemWith topts ft alg gen seeds diff --git a/src/Test/SBench/Space/Single/ExploreProfile.hs b/src/Test/SBench/Space/Single/ExploreProfile.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Space/Single/ExploreProfile.hs @@ -0,0 +1,29 @@ +module Test.SBench.Space.Single.ExploreProfile + ( getMaxMem + , getMemLine + ) +where + +import Profiling.Heap.Read ( readProfile ) +import Profiling.Heap.Types ( Profile(..), ProfileQuery(..), ProfileSample) + +getMaxMem :: FilePath -> IO Integer +getMaxMem fp = do + prof <- myReadProfile fp + return $ (fromIntegral (maxCost prof) :: Integer) + +getMemLine :: FilePath -> IO [(Double, Integer)] +getMemLine fp = do + prof <- myReadProfile fp + let s = samples prof + return $ map (\(t, xs) -> (t, getCost xs)) s + +myReadProfile :: FilePath -> IO Profile +myReadProfile fp = do + mprof <- readProfile fp + case mprof of + Nothing -> error $ "could not read " ++ fp + Just prof -> return $ prof + +getCost :: ProfileSample -> Integer +getCost = sum . map (fromIntegral . snd) diff --git a/src/Test/SBench/Space/Single/MakeExecutable.hs b/src/Test/SBench/Space/Single/MakeExecutable.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Space/Single/MakeExecutable.hs @@ -0,0 +1,99 @@ +module Test.SBench.Space.Single.MakeExecutable + ( make + , makeWith + ) + where + +import System.FilePath ( FilePath, addExtension ) +import System ( system ) +import System.IO ( writeFile ) +import Data.Maybe ( fromMaybe ) +import Control.Monad ( liftM2 ) + +import Test.SBench.Options ( + opts2string + , Repetitions + , CompilerOptions + , TestOpts (..) + , Imports + , NormalInput + ) + +import Test.SBench.STerm ( Algorithm, Data, Seed, STerm(..), getImports ) +import Test.SBench.Space.OptionSet ( generalCOpts ) + +import Criterion.Measurement ( time ) + +make :: TestOpts -> Algorithm (a -> b) -> Data a -> FilePath -> IO FilePath +make topts = makeWith (nfInp topts) (reps topts) (cOpts topts) + +makeWith :: NormalInput -> Maybe Repetitions -> CompilerOptions -> Algorithm (a -> b) -> Data a -> + FilePath -> IO FilePath +makeWith nfinp rep copts f a out = + let source = addExtension out "hs" + strcopts = opts2string $ generalCOpts ++ copts + autoGen = calcRepetitions nfinp copts f a + in do + print $ "The repetitions: " ++ show rep + print $ "Input normalized: " ++ show nfinp + rep' <- case rep of { Nothing -> autoGen; Just r -> return r } + writeFile (addExtension out "hs") (makeContent nfinp rep' f a) + print $ "running: ghc " ++ strcopts ++ " -o " ++ out ++ " " ++ source + system $ "ghc " ++ strcopts ++ " -o " ++ out ++ " " ++ source + return out + +-- | Find a reasonable number of repetitions of the function to measure, such that +-- the overall runtime is long enough to get enough heap samples. +-- The function is far from perfect and may need a rewrite. +calcRepetitions :: NormalInput -> CompilerOptions -> Algorithm (a -> b) -> Data a -> IO Int +calcRepetitions nfinp = calcRepetitions' nfinp 10 + +calcRepetitions' :: NormalInput -> Int -> CompilerOptions -> Algorithm (a -> b) -> Data a -> IO Int +calcRepetitions' nfinp rep copts f a = + do + writeFile "rep_check.hs" (makeContent nfinp rep f a) + print $ "Calculating reasonable number of repetitions trying with " ++ show rep ++ " ..." + system $ "ghc " ++ opts2string ("--make" : copts) ++ " -o rep_check rep_check.hs" + print $ "start executing rep_check ..." + system "chmod +x rep_check" + (t, _) <- time $ system "./rep_check" + print $ "... finish executing rep_check" + print $ "Time was " ++ show t ++ " seconds." + if t > 0.001 + then + do + let reps' = truncate $ 1 * fromIntegral rep / t + 1 + reps = max reps' 100 + print $ "Testing with " ++ show reps ++ " repetitions (expecting at least 1s runtime without profiling, but quarantee at least 100 runs)" + return reps + else calcRepetitions' nfinp (10 * rep) copts f a + + +-- * auxiliar functions to build the program file +makeContent :: NormalInput -> Int -> Algorithm (a -> b) -> Data a -> String +makeContent nfinp rep f a = + header + ++ imports + ++ "\n" + ++ makeMain nfinp rep f a + where + imports = (imports2string defltImport) ++ getImports f ++ getImports a + makeMain nfinp rep f a = + "main = \n" + ++ " let dat = " ++ stName a ++ "\n" + ++ " dat' = if " ++ show nfinp ++ " then deepseq dat dat else dat \n" + ++ " res = map " + ++ stName f ++ " as \n" + ++ " as = take " ++ show rep ++ " (repeat dat') in \n" + ++ " deepseq res (print \"Done.\")" + + + +header :: String +header = "module Main where \n" + + +defltImport = [ "Control.DeepSeq ( deepseq )" ] + +imports2string :: Imports -> String +imports2string xs = unlines $ map ("import " ++) xs diff --git a/src/Test/SBench/Space/Single/RunExecutable.hs b/src/Test/SBench/Space/Single/RunExecutable.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Space/Single/RunExecutable.hs @@ -0,0 +1,44 @@ +module Test.SBench.Space.Single.RunExecutable + ( run + , runWith + ) + where + +import System.FilePath ( FilePath, addExtension, isRelative ) +import System ( system ) + +import Test.SBench.Options ( + TestOpts (..) + , opts2string + , ProfParam (..) + , Breakdown (..) + , Restriction (..) + , ProfilingOptions + , MemoryOptions + , RuntimeOptions (..) + , ThreadNum + , ProgramArguments + ) + +run :: TestOpts -> FilePath -> IO FilePath +run topts = runWith + (get progArgs) + (get threadNum) + (get memOpts) + (get profOpts) + where get opts = opts $ rOpts topts + +runWith :: ProgramArguments -> Maybe ThreadNum -> MemoryOptions -> + ProfilingOptions -> FilePath -> IO FilePath +runWith pargs threads mopts popts exe = do + let call = opts2string + [ (if isRelative exe then "./" else "") ++ exe + , opts2string pargs + , "+RTS" + , case threads of { Nothing -> ""; Just t -> "-N" ++ show t} + , opts2string (map show mopts) + , opts2string (map show popts) + ] + print $ "call the following program:\n" ++ call ++ "\n" + system call + return $ addExtension exe "hp" diff --git a/src/Test/SBench/Space/Single/Test.hs b/src/Test/SBench/Space/Single/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Space/Single/Test.hs @@ -0,0 +1,63 @@ +module Test.SBench.Space.Single.Test + ( getProfile + , getMaxMem + , getMaxMemWith + , getMemLine + , getMemLineWith + ) + where + +import System.FilePath ( FilePath ) + +import Test.SBench.Space.Single.MakeExecutable ( make ) +import Test.SBench.Space.Single.RunExecutable ( run ) +import qualified Test.SBench.Space.Single.ExploreProfile as Explore ( getMaxMem, getMemLine ) +import Test.SBench.Options ( TestOpts(..), NormalInput, MemSize(..), MemUnit(..), Title, opts2string, EvalMod(..) ) +import Test.SBench.STerm ( Algorithm(..), Data ) +import Test.SBench.Space.OptionSet ( setRepetitions, addCC, defltTestOpts, setNfInput, setMemSizes ) +import Test.SBench.File.FileOps ( series2sbench' ) + + +-- | Create only the heap profile. +getProfile :: TestOpts -> Algorithm (a -> b) -> Data a + -> FilePath -> IO FilePath +getProfile topts alg arg file = make topts alg arg file >>= run topts + + +-- | Get the maximal heap occupied by the algorithm. +-- Since the algorithms comes with a cost center annotation this is used to +-- explore what heap consumption should be measured (here: all heap directly +-- or indirectly used by the given algorithm). +getMaxMem :: NormalInput -- ^ Shall input be normalized first? (Boolean value) + -> Algorithm (a -> b) -- ^ The algorithm to test + -> Data a -- ^ The test input + -> FilePath -- ^ File the program generated for measurements is stored to. + -- More precise: the files, i.e. source code, executable, + -- heap profile, intermediate files during build + -> IO Integer -- ^ Maximal heap used. +getMaxMem nfinp alg = + getMaxMemWith (setNfInput nfinp $ setMemSizes [Stack 500 M] $ setRepetitions 1 $ addCC alg $ defltTestOpts) alg + +-- | As 'getMaxMem', but 'TestOpts' can be set by the user. +getMaxMemWith :: TestOpts -> Algorithm (a -> b) -> Data a -> FilePath -> IO Integer +getMaxMemWith topts alg arg file = getProfile topts alg arg file >>= Explore.getMaxMem + + +-- | The function generates a heap profile, returns the heapconsumption over time as series and +-- also stores the series as an .sbench file. +getMemLine :: NormalInput -- ^ Shall input be normalized first? (Boolean value) + -> (FilePath, Title) -- ^ Name of the generated .sbench file and all + -- intermediate files (e.g. .hs, .hp) + -> Algorithm (a -> b) -- ^ The algorithm to test + -> Data a -- ^ The test input + -> IO [(Double, Integer)] +getMemLine nfinp store alg = + getMemLineWith (setNfInput nfinp $ setMemSizes [Stack 500 M] $ setRepetitions 1 $ addCC alg $ defltTestOpts) store alg + +-- As 'getMemLine', but 'TestOpts' can be set by the user. +getMemLineWith :: TestOpts -> (FilePath, Title) -> Algorithm (a -> b) -> Data a -> IO [(Double, Integer)] +getMemLineWith topts (file, title) alg arg = do + s <- getProfile topts alg arg file >>= Explore.getMemLine + series2sbench' (opts2string (cOpts topts), show (rOpts topts)) (Just (if (nfInp topts) then NF else WHNF)) alg arg title file s + return s + diff --git a/src/Test/SBench/Time/Series/Test.hs b/src/Test/SBench/Time/Series/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test/SBench/Time/Series/Test.hs @@ -0,0 +1,96 @@ +-- | Functions for runtime tests are provided. They are basically a wrapper to +-- a call to the criterion function "Criterion.Main.defaultMainWith". +-- The measurement data (usually stored in temp.csv) is than postprocessed +-- by extracting only the mean runtime for each run and tupling it with the +-- respective input seed. +-- Results are then returned as list of tuples and optionally stored in a +-- .sbench file (see "Test.File.FileOps"). + +module Test.SBench.Time.Series.Test ( + runtimeSeries + , runtimeSeriesWith + , nfRuntimeSeries + , whnfRuntimeSeries + , scaleRt + ) where + +import Criterion.Main ( defaultMainWith, bgroup, bench, nf, whnf ) +import Criterion.Config ( Config(..), defaultConfig ) +import Data.Monoid ( Last(..) ) +import System.FilePath ( (<.>), dropExtension ) +import qualified Control.DeepSeq ( NFData, deepseq ) + +import Test.SBench.STerm ( Algorithm, DataGen, Seed, STerm (..), (<$>) ) +import Test.SBench.Options ( EvalMod (..), Title ) +import Test.SBench.File.FileOps ( criterion2series, series2sbench ) + +type BuildOptions = String +type ExeOptions = String + +scaleRt :: Double -> [(Int, Double)] -> [(Int, Double)] +scaleRt f = map (\(x,y) -> (x,f*y)) + +defltCriterionFile = "temp" <.> "csv" + +-- | Most general function to perform runtime measurements for a series of inputs. +runtimeSeriesWith :: (Control.DeepSeq.NFData b, Real c) => + Config -- ^ see "Criterion.Config.Config" + -> EvalMod -- ^ Evaluation level of the input before starting the measurement. + -- Either weak head normal form ('WHNF') or normal form ('NF') + -> Maybe (BuildOptions, ExeOptions, FilePath, Title) + -- ^ Choose, whether you want to create a .sbench file and if give + -- meta information about build options, execution options as well + -- as the file name for the .sbench file and the title for the + -- measurements that should be stored as meta information. + -> Algorithm (a -> b) -- ^ The function that is to be tested. + -> DataGen (c -> a) -- ^ The input data generator + -> [Seed c] -- ^ Seeds to the input data generator. For each seed + -- a measurement is performed. A list of seeds might + -- be generated via "Test.SBench.Auxiliar.Datagen.makeGens" + -> IO [(c, Double)] -- ^ series of the measurements as seed-runtime pairs. +runtimeSeriesWith cfg evalMod sbfile alg gen seeds = do + print "enter criterion benchmarking .." + t <- defaultMainWith cfg (return ()) benches + print $ "finished criterion benchmarking with " ++ show t + s <- criterion2series (map stTerm seeds) file + case sbfile of + Nothing -> return s + Just (b,e,f,t) -> series2sbench (b, e) (Just evalMod) alg gen t f s + >> return s + where + file = case cfgSummaryFile cfg of + Last (Just f) -> f + _ -> defltCriterionFile + benches = [ bgroup (dropExtension file) $ map (toBench gen) seeds ] + toBench gen seed = let inp = gen <$> seed in bench (stName inp) $ efun (stTerm alg) (stTerm inp) + efun = case evalMod of + NF -> nf + WHNF -> whnf + +-- | As 'runtimeSeriesWith', but "Criterion.Config.Config" is set to a default. +runtimeSeries :: (Control.DeepSeq.NFData b, Real c) => + EvalMod + -> Maybe (BuildOptions, ExeOptions, FilePath, Title) + -> Algorithm (a -> b) + -> DataGen (c -> a) + -> [Seed c] + -> IO [(c, Double)] +runtimeSeries = runtimeSeriesWith defaultConfig {cfgSummaryFile = Last $ Just $ defltCriterionFile } + + +nfRuntimeSeries :: (Control.DeepSeq.NFData b, Real c) => + Maybe (BuildOptions, ExeOptions, FilePath, Title) + -> Algorithm (a -> b) + -> DataGen (c -> a) + -> [Seed c] + -> IO [(c, Double)] +nfRuntimeSeries = runtimeSeries NF + +whnfRuntimeSeries :: (Control.DeepSeq.NFData b, Real c) => + Maybe (BuildOptions, ExeOptions, FilePath, Title) + -> Algorithm (a -> b) + -> DataGen (c -> a) + -> [Seed c] + -> IO [(c, Double)] +whnfRuntimeSeries = runtimeSeries WHNF +