...
  View open merge request
Commits (20)
variables:
DOCKER_REV: 2b69e99de97bd5bf1fbdbf45852231c3dcb602b6
DOCKER_REV: ba119705df5222fe74208a85019cb980e2c4318f
validate:
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
validate-hadrian:
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV"
tags:
- x86_64-linux
before_script:
- git clean -xdf
- sudo apt install -y time
- ghc --version
- cabal --version
script:
- make clean
- GHC=/opt/ghc/$GHC_VERSION/bin/ghc
- $GHC --version
- cabal update
- make boot mode=fast
- "make mode=fast NoFibRuns=1 2>&1 | tee log"
- "nofib-analyse/nofib-analyse log"
- |
# The following checks that `make distclean` removes any files reported
# by `git clean -fxd`
make distclean
files=$(git clean -nxd | cut -d" " -f3 | sed "/log/d")
if ! [ -z $files ]
then
echo "The following files weren't cleaned:\n$files"
exit 1
fi
- cabal new-run nofib-run -- -o out -w $GHC
- mkdir -p results
- $GHC --info > results/compiler-info
- cp _make/out/*.results.tsv results
artifacts:
paths:
- results
[submodule "tabular"]
path = tabular
url = https://github.com/bgamari/tabular
packages: shake tabular
-- source-repository-package
-- type: git
-- location: https://github.com/bgamari/tabular
-- tag: 204b01f63dec6bf0e0aba2862c71e77b2ec3909b
TOP = ../..
include $(TOP)/mk/boilerplate.mk
SRC_DEPS = old-time
SRC_DEPS = old-time array
# kLongLivedTreeDepth = 17 :: Int
# kArraySize = 500000 :: Int
......
This source diff could not be displayed because it is too large. You can view the blob instead.
TOP = ../..
include $(TOP)/mk/boilerplate.mk
SRC_DEPS = array
FAST_OPTS = 100000
NORM_OPTS = 300000
SLOW_OPTS = 600000
SRC_DEPS = array
include $(TOP)/mk/target.mk
......@@ -35,6 +35,8 @@ instance Applicative Pure where
instance Monad Pure where
Pure x >>= k = k x
return = Pure
instance MonadFail Pure where
fail s = error s
instance MonadEval Pure where
......@@ -313,6 +315,8 @@ instance Monad Abs where
AbsState r s' -> runAbs (k r) s'
AbsFail m -> AbsFail m)
return = pure
instance MonadFail Abs where
fail s = Abs (\ n -> AbsFail s)
instance MonadEval Abs where
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module CachegrindParse where
import Data.Maybe
import qualified Data.Map as M
newtype EventName = EventName { getEventName :: String }
deriving (Show, Eq, Ord)
parse :: FilePath -> IO (M.Map EventName Integer)
parse fname = parse' <$> readFile fname
parse' :: String -> M.Map EventName Integer
parse' content =
M.fromList $ zip summary events
where
events = case mapMaybe isEventList $ lines content of
[] -> error "No event list found"
[x] -> x
_ -> error "More than one event list found"
summary = case mapMaybe isSummaryList $ lines content of
[] -> error "No event summary found"
[x] -> x
_ -> error "More than one event summary found"
isEventList :: String -> Maybe [Integer]
isEventList line
| "summary:" : rest <- words line = Just $ map read rest
| otherwise = Nothing
isSummaryList :: String -> Maybe [EventName]
isSummaryList line
| "events:" : rest <- words line = Just $ map EventName rest
| otherwise = Nothing
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Debug.Trace
import Data.Align (Align, alignWith)
import Data.Maybe
import Data.These
import Data.Char
import Data.List (intercalate, group)
import Data.Foldable
import Numeric
import qualified Data.Sequence as Seq
import qualified Data.Tree as Tree
import Data.Tree (Tree)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import System.Directory
import System.FilePath
import Text.Tabular
import qualified Text.Tabular.AsciiArt as AsciiArt
import qualified Text.Tabular.Csv as Csv
import qualified Text.Tabular.Latex as Latex
import Options.Applicative as O
import System.Console.ANSI.Codes as ANSI
import qualified Measurements as Ms
import Measurements (Measurements, Label)
import LabelMatch
data Mode = RelativeMode | AbsoluteMode
args :: Parser (Mode, OutputDest, OutputFormat, OutputOptions, [FilePath])
args =
(,,,,)
<$> flag RelativeMode AbsoluteMode (long "absolute" <> short 'a' <> help "show absolute metrics")
<*> outputDest
<*> formatOption
<*> outputOptions
<*> some (argument str (metavar "FILE" <> help "results.json file"))
where
formatOption :: Parser OutputFormat
formatOption = option (str >>= parse) (long "format" <> short 'f' <> help "Output format (one of markdown, ascii, csv, latex)" <> O.value FmtAsciiArt)
where
parse "markdown" = pure FmtMarkdown
parse "ascii" = pure FmtAsciiArt
parse "csv" = pure FmtCsv
parse "latex" = pure FmtLatex
parse _ = fail "Unknown --format"
outputDest :: Parser OutputDest
outputDest =
option (ToSingleFile <$> str) (long "output" <> short 'o' <> help "write output to single file")
<|> option (ToManyFiles <$> str) (long "output-dir" <> short 'O' <> help "write output to many files, one per table")
<|> pure ToStdout
outputOptions :: Parser OutputOptions
outputOptions =
OutputOptions
<$> switch (long "fancy-chars" <> short 'f' <> help "Use proper typography")
<*> switch (long "color" <> short 'c' <> help "Enable color output")
renderGitLabMarkdown :: (rh -> String) -> (ch -> String) -> (a -> String) -> Table rh ch a -> String
renderGitLabMarkdown renderRow renderCol renderCell (Table rows cols cells) =
unlines $ [header, headerSep] ++ cells'
where
prepend x = (x :)
joinCols xs = "| " ++ intercalate " | " xs ++ " |"
header = joinCols $ prepend "" $ map renderRow (headerContents rows)
headerSep = joinCols $ map (const " -------- ") header
emphasize x = "*"++x++"*"
cells' = zipWith (\rh row -> joinCols
$ prepend (emphasize $ renderRow rh)
$ map renderCell row
) (headerContents rows) cells
data OutputFormat = FmtMarkdown | FmtAsciiArt | FmtCsv | FmtLatex
render :: OutputFormat
-> (rh -> String) -> (ch -> String) -> (a -> String)
-> Table rh ch a
-> String
render FmtMarkdown = renderGitLabMarkdown
render FmtAsciiArt = AsciiArt.render
render FmtCsv = Csv.render
render FmtLatex = Latex.render
-- | Pick out the interesting part of a set of filenames for use as a friendly
-- name. Essentially we just break up all paths into their components and drop
-- all components common to all.
friendlyNameFiles :: [FilePath] -> M.Map MetricFile FilePath
friendlyNameFiles files =
M.fromList
[ (MetricFile $ joinPath $ toList name, path)
| (path, name) <- M.toList friendlyNames
]
where
friendlyNames :: M.Map FilePath (Seq.Seq String)
friendlyNames =
fmap (fmap snd . Seq.filter (not . fst) . Seq.zip isCommon) splitPaths
where
isCommon :: Seq.Seq Bool
isCommon = Seq.fromList $ fmap isCommonComp [0..maximum $ fmap length splitPaths]
splitPaths :: M.Map FilePath (Seq.Seq String)
splitPaths = M.fromList [ (f, Seq.fromList $ splitPath f) | f <- files ]
isCommonComp :: Int -> Bool
isCommonComp n = allEqual $ M.elems $ fmap (Seq.!? n) splitPaths
allEqual :: Eq a => [a] -> Bool
allEqual xs = length (group xs) == 1
mapColHeader :: (ch -> ch') -> Table rh ch a -> Table rh ch' a
mapColHeader f (Table rh ch xs) = Table rh (fmap f ch) xs
mapRowHeader :: (rh -> rh') -> Table rh ch a -> Table rh' ch a
mapRowHeader f (Table rh ch xs) = Table (fmap f rh) ch xs
mapTable :: (a -> b) -> Table rh ch a -> Table rh ch b
mapTable f (Table rh ch xs) = Table rh ch (map (map f) xs)
mapSemiTable :: (a -> b) -> SemiTable h a -> SemiTable h b
mapSemiTable f (SemiTable h xs) = SemiTable h (map f xs)
data OutputOptions = OutputOptions { fancyChars, color :: Bool }
simpleOutput :: OutputOptions
simpleOutput = OutputOptions False False
class ToRowLabel a where toRowLabel :: a -> String
instance ToRowLabel String where toRowLabel = id
instance ToRowLabel Label where toRowLabel = T.unpack . Ms.encodeLabel
instance (ToRowLabel a, ToRowLabel b) => ToRowLabel (a,b) where
toRowLabel (a,b) = toRowLabel a ++ " // " ++ toRowLabel b
withColor :: OutputOptions -> ANSI.Color -> ShowS -> ShowS
withColor opts c s
| color opts =
showString start . s . showString end
| otherwise = s
where
start = ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid c]
end = ANSI.setSGRCode [ANSI.Reset]
showGFloat' :: RealFloat a => OutputOptions -> Maybe Int -> a -> ShowS
showGFloat' opts prec x = prettySign opts x . showGFloat prec (abs x)
prettySign :: (Ord a, Num a) => OutputOptions -> a -> ShowS
prettySign opts x
| x < 0 = if fancyChars opts then showChar '−' else showChar '-'
| x > 0 = showChar '+'
| otherwise = id
-- | The presentation name of a metric file.
newtype MetricFile = MetricFile { metricFileFriendlyName :: String }
deriving (Ord, Eq, Show)
-- | Where to write output?
data OutputDest = ToStdout | ToSingleFile FilePath | ToManyFiles FilePath
initializeOutputDest :: OutputDest -> IO ()
initializeOutputDest ToStdout = return ()
initializeOutputDest (ToSingleFile path) = writeFile path "" -- truncate
initializeOutputDest (ToManyFiles path) = createDirectoryIfMissing False path
writeTable :: OutputDest
-> String -- ^ table title
-> String -- ^ contents
-> IO ()
writeTable (ToManyFiles dir) title contents =
writeFile (dir </> fname) contents
where
fname = map sanitize title
sanitize ' ' = '-'
sanitize x = toLower x
writeTable dest title contents =
write $ unlines
[ ""
, "# " <> title
, ""
, contents
]
where
write = case dest of
ToStdout -> putStrLn
ToSingleFile path -> appendFile path
main :: IO ()
main = do
(mode, outputDest, fmt, opts, files) <- execParser $ info (helper <*> args) mempty
initializeOutputDest outputDest
let filesWithFriendlyNames :: M.Map MetricFile FilePath
filesWithFriendlyNames = friendlyNameFiles files
-- Yuck. Figure out friendly name of reference set
[ref] = [ name
| (name, fname) <- M.toList filesWithFriendlyNames
, fname == head files
]
mtrees <- mapM Ms.readFile filesWithFriendlyNames
:: IO (M.Map MetricFile (Measurements Double))
let mtrees' :: M.Map MetricFile (M.Map Label (MeanStddev Double))
mtrees' = fmap (Ms.toMap (fromJust . meanStdErr)) mtrees
let aligned :: M.Map Label (M.Map MetricFile (MeanStddev Double))
aligned = alignMany mtrees'
let tabulate :: forall rh. (Ord rh, ToRowLabel rh) => String -> LabelMatcher rh -> IO ()
tabulate heading pred = writeTable outputDest heading contents
where
xs :: M.Map rh (M.Map MetricFile (MeanStddev Double))
xs = M.fromList
$ mapMaybe (\(k,v) -> (\k' -> (k',v)) <$> match pred k)
$ M.toList aligned
contents
| null xs = "## no samples"
| otherwise =
case mode of
RelativeMode ->
let showRel = maybe "∙" (showRelative (showGFloat' opts (Just 3)) (showPercent opts))
relChg = toRelativeChange ref (fmap (fmap msMean) xs)
cols :: [SemiTable Column Cell]
cols =
[ absoluteCol xs ref, stderrCol xs ref ] ++
concat
[ [ relativeCol xs ref metricFile
, stderrCol xs metricFile
]
| metricFile <- M.keys mtrees
, metricFile /= ref
]
table :: Table rh Column Cell
table = foldl' (^|^) (baseTable xs) cols
in render fmt id (runShowS . showColumn) id
$ mapRowHeader toRowLabel (mapTable (runShowS . showCell opts) table)
+====+
mapSemiTable (maybe "" (\x -> showsPctChange opts x "")) (geomMeanRow relChg)
AbsoluteMode ->
let cols :: [SemiTable Column Cell]
cols = concat
[ [ absoluteCol xs metricFile
, stderrCol xs metricFile
]
| metricFile <- M.keys mtrees
]
table :: Table rh Column Cell
table = foldl' (^|^) (baseTable xs) cols
in render fmt toRowLabel (runShowS . showColumn) (runShowS . showCell opts) table
-- compile-time metrics
tabulate "compiler allocations" $ objectCompilerRtsStats <* "bytes allocated"
tabulate "compiler mutator time" $ objectCompilerRtsStats <* "mutator_cpu_seconds"
tabulate "compiler GC time" $ objectCompilerRtsStats <* "GC_cpu_seconds"
tabulate "executable size" $ testName <* "executable size"
-- run-time metrics
tabulate "bytes allocated" $ runRtsStats <* "bytes allocated"
tabulate "mutator time" $ runRtsStats <* ("mutator_cpu_seconds" <|> "mut_cpu_seconds")
tabulate "GC time" $ runRtsStats <* "GC_cpu_seconds"
-- cachegrind
tabulate "instructions" $ cachegrindStats <* "Ir"
tabulate "LLC cache misses" $ cachegrindStats <* "DLmr"
tabulate "L1 cache misses" $ cachegrindStats <* "D1mr"
tabulate "perf cache-misses" $ perfStats <* ("cache-misses" <|> "cache-misses:u")
tabulate "perf instructions" $ perfStats <* ("instructions" <|> "instructions:u")
tabulate "perf cycles" $ perfStats <* ("cycles" <|> "cycles:u")
alignMany :: (Align f, Ord k) => M.Map k (f a) -> f (M.Map k a)
alignMany mtrees =
foldl1 (alignWith (mergeThese M.union))
[ fmap (M.singleton k) mtree
| (k, mtree) <- M.toList mtrees
]
type TestName = String
type ModuleName = String
testName :: LabelMatcher TestName
testName = wildcard
objectCompilerRtsStats :: LabelMatcher (TestName, ModuleName)
objectCompilerRtsStats = (,) <$> testName <* "objects" <*> wildcard <* "rts stats"
runRtsStats :: LabelMatcher TestName
runRtsStats = testName <* "run" <* "rts stats"
cachegrindStats :: LabelMatcher TestName
cachegrindStats = testName <* "run" <* "cachegrind"
perfStats :: LabelMatcher TestName
perfStats = testName <* "run" <* "perf"
data Column = AbsoluteCol MetricFile
| RelativeCol MetricFile
| StderrCol MetricFile
deriving (Show)
showColumn :: Column -> ShowS
showColumn (AbsoluteCol mf) = showString $ metricFileFriendlyName mf
showColumn (RelativeCol mf) = showString (metricFileFriendlyName mf) . showString " (rel)"
showColumn (StderrCol mf) = showString "std. err." --showString (metricFileFriendlyName mf) . showString " (\\sigma)"
data Cell = CellPctChange (ValueBaseline Double)
| CellMissing
| CellAbsolute Double
| CellStderrRel (MeanStddev Double)
deriving (Show)
showCell :: OutputOptions -> Cell -> ShowS
showCell opts (CellPctChange vb) = showString $ showPercent opts vb
showCell opts CellMissing = showChar '∙'
showCell opts (CellAbsolute x) = showGFloat' opts (Just 3) x
showCell opts (CellStderrRel ms) = showGFloat (Just 1) (msStddev ms / msMean ms * 100) . showChar '%'
baseTable :: M.Map rh (M.Map MetricFile (MeanStddev Double))
-> Table rh Column Cell
baseTable mtrees =
Table (Group NoLine $ map Header rowLbls) (Group NoLine []) ([] <$ rowLbls)
where rowLbls = M.keys mtrees
absoluteCol :: M.Map lbl (M.Map MetricFile (MeanStddev Double))
-> MetricFile
-> SemiTable Column Cell
absoluteCol mtrees metricFile =
col (AbsoluteCol metricFile)
[ maybe CellMissing (CellAbsolute . msMean) $ M.lookup metricFile xs
| (_metric, xs) <- M.toList mtrees
]
relativeCol :: M.Map lbl (M.Map MetricFile (MeanStddev Double))
-> MetricFile -- ^ reference
-> MetricFile
-> SemiTable Column Cell
relativeCol mtrees refFile metricFile =
col (RelativeCol metricFile)
[ fromMaybe CellMissing $ do
baseline <- msMean <$> M.lookup refFile xs
value <- msMean <$> M.lookup metricFile xs
return $ CellPctChange $ ValueBaseline baseline value
| (metric, xs) <- M.toList mtrees
]
stderrCol :: M.Map lbl (M.Map MetricFile (MeanStddev Double))
-> MetricFile
-> SemiTable Column Cell
stderrCol mtrees metricFile =
col (StderrCol metricFile)
[ maybe CellMissing CellStderrRel $ M.lookup metricFile xs
| (_metric, xs) <- M.toList mtrees
]
data ValueBaseline a = ValueBaseline { baseline, value :: a }
deriving (Show)
showBoth :: (RealFloat a, Show a) => ValueBaseline a -> String
showBoth (ValueBaseline ref val) = show (ref, val)
newtype PctChange a = PctChange a
deriving (Show)
showsPctChange :: (Ord a, RealFloat a) => OutputOptions -> PctChange a -> ShowS
showsPctChange opts (PctChange percent) =
withColor opts color $ prettySign opts rel . showFFloat (Just 2) (abs rel) . showChar '%'
where
rel = percent - 100
color
| rel < 0 = Green
| rel > 0 = Red
| otherwise = White
toPctChange :: RealFloat a => ValueBaseline a -> PctChange a
toPctChange (ValueBaseline ref val) = PctChange ((val / ref) * 100)
showPercent :: (RealFloat a, Show a) => OutputOptions -> ValueBaseline a -> String
showPercent opts x = showsPctChange opts (toPctChange x) ""
data Relative a = Reference a
| Relative (ValueBaseline a)
| NoReference
showRelative :: (Ord a, RealFloat a, Show a)
=> (a -> ShowS) -> (ValueBaseline a -> String) -> Relative a -> String
showRelative showRef _showRel (Reference n) = showRef n ""
showRelative _showRef showRel (Relative vb) = showRel vb
showRelative _showRef _showRel NoReference = "no ref"
toRelativeChange :: (Ord r, Ord c, RealFrac a)
=> c
-> M.Map r (M.Map c a)
-> M.Map r (M.Map c (Relative a))
toRelativeChange ref xs = fmap f xs
where
f ys
| Just y0 <- M.lookup ref ys =
M.mapWithKey (\k y -> if k == ref then Reference y0 else Relative (ValueBaseline y0 y)) ys
| otherwise = fmap (const NoReference) ys
transpose :: (Ord r, Ord c)
=> M.Map r (M.Map c a)
-> M.Map c (M.Map r a)
transpose xs = M.fromListWith (<>)
[ (c, M.singleton r x)
| (r, cs) <- M.toList xs
, (c, x) <- M.toList cs
]
mean :: (Functor f, Foldable f, RealFloat a)
=> f a -> Maybe a
mean xs
| null xs = Nothing
| otherwise = Just $ (sum xs) / realToFrac (length xs)
data MeanStddev a = MeanStddev { msMean, msStddev :: a }
deriving (Show)
meanStddev :: (Functor f, Foldable f, RealFloat a)
=> f a -> Maybe (MeanStddev a)
meanStddev xs = do
mu <- mean xs
sigma <- fmap sqrt $ mean $ fmap (\x -> (x-mu)^2) xs
return $ MeanStddev mu sigma
meanStdErr :: (Functor f, Foldable f, RealFloat a)
=> f a -> Maybe (MeanStddev a)
meanStdErr xs = do
ms <- meanStddev xs
return ms { msStddev = msStddev ms / sqrt n }
where n = realToFrac $ length xs
geomMean :: (Functor f, Foldable f, RealFloat a)
=> f a -> Maybe a
geomMean = fmap exp . mean . fmap log'
where log' = log . max 0.05
geomMeanRow :: (Ord r, Ord c, RealFloat a)
=> M.Map r (M.Map c (Relative a))
-> SemiTable String (Maybe (PctChange a))
geomMeanRow xs =
row "geom mean" (M.elems $ fmap (fmap (PctChange . (*100)) . geomMean . mapMaybe ratios . M.elems) $ transpose xs)
where
ratios :: Fractional a => Relative a -> Maybe a
ratios (Relative (ValueBaseline ref val)) = Just (val / ref)
ratios _ = Nothing
runShowS :: ShowS -> String
runShowS = ($ [])
Copyright (c) 2019, Ben Gamari
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 Ben Gamari 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.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
module LabelMatch where
import Control.Applicative
import Control.Monad
import Data.String
import qualified Data.Text as T
import Measurements (Label(..))
newtype LabelMatcher a = LabelMatcher (Label -> Maybe (Label, a))
deriving (Functor)
match :: LabelMatcher a -> Label -> Maybe a
match (LabelMatcher f) l = snd <$> f l
instance (a ~ ()) => IsString (LabelMatcher a) where
fromString = matchPart . fromString
instance Applicative LabelMatcher where
pure x = LabelMatcher $ \lbl -> Just (lbl, x)
(<*>) = ap
instance Alternative LabelMatcher where
LabelMatcher f <|> LabelMatcher g =
LabelMatcher $ \lbl -> f lbl <|> g lbl
empty = LabelMatcher $ const Nothing
instance Monad LabelMatcher where
LabelMatcher f >>= g = LabelMatcher $ \lbl ->
case f lbl of
Nothing -> Nothing
Just (lbl', x) -> let LabelMatcher h = g x
in h lbl'
matchPart :: T.Text -> LabelMatcher ()
matchPart s = LabelMatcher f
where
f (Label (x:xs))
| x == s = Just (Label xs, ())
f _ = Nothing
wildcard :: LabelMatcher String
wildcard = LabelMatcher f
where
f (Label (x:xs)) = Just (Label xs, T.unpack x)
f (Label []) = Nothing
end :: LabelMatcher ()
end = LabelMatcher f
where
f (Label []) = Just (Label [], ())
f (Label _) = Nothing
{-# LANGUAGE OverloadedStrings #-}
import Data.Foldable
import Options.Applicative
import qualified Data.ByteString.Lazy as BS
import qualified Measurements as Ms
import Measurements (Measurements, Label)
args :: Parser (FilePath, [FilePath], Bool)
args =
(,,)
<$> option str (long "output" <> short 'o' <> help "output file")
<*> some (argument str (metavar "FILE" <> help "results.json files"))
<*> switch (long "json" <> short 'j' <> help "produce JSON output")
main :: IO ()
main = do
(output, files, json) <- execParser $ info (helper <*> args) mempty
trees <- mapM Ms.readFile files
let result = fold trees
if json
then Ms.writeFile output result
else Ms.writeFileTsv output result
# The nofib build system
This documents usage of nofib's Shake-based build system. The build system,
`nofib-run`, automates running of the nofib benchmarks and the collection of a
variety of compile- and run-time metrics. These metrics are recorded in a
common semi-structured CSV file format, which can be compared and analysed with
the included `nofib-compare` utility.
## Preparation
The nofib benchmarks require that a number of native dependencies be installed
in the tested compilers user or global package database. To install these:
```
$ cabal v1-install --allow-newer -w /path/to/ghc old-time stm parallel random
```
## Usage
The `nofib-run` executable is used to run the benchmark suite and accepts a variety of arguments.
By default the results of the run will be placed in `_make/{compiler version}`.
The compiler version component of this path can be overridden with the
`--output` flag.
For instance,
```
$ cabal new-run -- nofib-run --compiler=/path/to/ghc --output=test
```
will produce a number of files in `_make/`:
```
$ ls -R _make
_make:
8.11.0.20200205
_make/8.11.0.20200205:
gc imaginary parallel real spectral
_make/8.11.0.20200205/gc:
cacheprof circsim constraints fibheaps gc_bench happy hash lcss linear mutstore1 mutstore2 spellcheck treejoin
_make/8.11.0.20200205/gc/cacheprof:
Arch_x86.hi Arch_x86.o.result Arch_x86.o.stats Generics.hi Generics.o.result Generics.o.stats Main.deps Main.o Main.o.results.csv Main.result
Arch_x86.o Arch_x86.o.results.csv config.txt Generics.o Generics.o.results.csv Main Main.hi Main.o.result Main.o.stats Main.results.csv
...
```
In the case of the `gc/cacheprof` benchmark we see the following were produced:
* build artifacts from the build of the benchmark (e.g. `*.o`, `*.hi`)
* for each object file a `.results.csv` file which contains the metrics for the object size
* `Main.results.csv`, which aggregates all of the above `*.results.csv` files
A number of classes of metrics are collected:
* object code size for each module
* runtime system statistics (e.g. mutator time, GC time, GC counts,
allocations) from the execution of `ghc` while compiling the testcase
* runtime system statistics from the execution of the testcase
### Cachegrind
The benchmarks can also be run under valgrind's
[cachegrind](https://valgrind.org/docs/manual/cg-manual.html) tool with the
`--cachegrind`, which simulates a simple cache hierarchy to allow (mostly)
deterministic modelling of instruction counts, memory, and cache effects.
When running with `--cachegrind` tests can be safely parallelised with the
`-j<n>` flag.
### Performance counters
The benchmarks can also be run under the Linux `perf` tool for collection of
(micro-)architectural event counts. This mode is enabled
## Data format
The output of `nofib-run` is a simple CSV format (defined by the `Measurements`
type in `src/Measurements.hs`) represents semi-structured string keys (known as
`Label`s) and floating-point values. In particular, labels have a path-like
structure with `/` being the component delimiter.
An example of this CSV is:
```
```
There also exists a JSON representation of this format,
```
{
}
```
## Comparing results
```
$ cabal new-run nofib-compare -- approach-b.results.csv approach-a.results.csv
```
import Distribution.Simple
main = defaultMain
cabal-version: >=1.10
name: nofib
version: 0.1.0.0
-- synopsis:
-- description:
-- bug-reports:
license: BSD3
license-file: LICENSE
author: Ben Gamari
maintainer: ben@smart-cactus.org
-- copyright:
-- category:
build-type: Simple
library
exposed-modules: Measurements
ghc-options: -Wall
hs-source-dirs: src
build-depends: base >=4.10 && <4.15,
aeson,
these >= 0.8,
containers,
cassava,
text,
filepath,
vector,
bytestring
default-language: Haskell2010
executable nofib-run
main-is: Main.hs
ghc-options: -Wall
hs-source-dirs: runner
other-modules:
CachegrindParse
, PerfStatParse
, ParseResults
, RunnerTypes
other-extensions: RecordWildCards, DeriveDataTypeable
build-depends: base >=4.10 && <4.15,
time >=1.8 && <1.10,
containers,
bytestring,
directory >=1.3 && <1.4,
filepath,
process >=1.6 && <1.7,
text,
optparse-applicative,
shake,
nofib
default-language: Haskell2010
executable nofib-compare
main-is: Compare.hs
ghc-options: -Wall
other-modules: LabelMatch
other-extensions: RecordWildCards, DeriveDataTypeable
build-depends: base >=4.10 && <4.15,
these,
containers,
directory,
filepath,
text,
aeson,
ansi-wl-pprint,
tabular,
these,
semialign,
optparse-applicative,
ansi-terminal,
nofib
default-language: Haskell2010
executable nofib-merge
main-is: Merge.hs
ghc-options: -Wall
build-depends: base >=4.10 && <4.15,
optparse-applicative,
cassava,
bytestring,
nofib
default-language: Haskell2010
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module CachegrindParse where
import Data.Maybe
import qualified Data.Map as M
newtype EventName = EventName { getEventName :: String }
deriving (Show, Eq, Ord)
parse :: FilePath -> IO (M.Map EventName Integer)
parse fname = parse' <$> readFile fname
parse' :: String -> M.Map EventName Integer
parse' content =
M.fromList $ zip summary events
where
events = case mapMaybe isEventList $ lines content of
[] -> error "No event list found"
[x] -> x
_ -> error "More than one event list found"
summary = case mapMaybe isSummaryList $ lines content of
[] -> error "No event summary found"
[x] -> x
_ -> error "More than one event summary found"
isEventList :: String -> Maybe [Integer]
isEventList line
| "summary:" : rest <- words line = Just $ map read rest
| otherwise = Nothing
isSummaryList :: String -> Maybe [EventName]
isSummaryList line
| "events:" : rest <- words line = Just $ map EventName rest
| otherwise = Nothing
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main(main) where
-- Standard libraries
import Control.Monad
import Data.Bifunctor
import Data.Char
import Data.Foldable
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as M
import qualified System.Directory as IO
import qualified System.FilePath as FP
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import System.Info hiding (compilerVersion)
import Options.Applicative
-- Shake - build system
import Development.Shake
import Development.Shake.FilePath hiding (exe)
import Development.Shake.Util as SU
import RunnerTypes
import qualified Measurements as Ms
import Measurements (Measurements, Label(..))
import qualified ParseResults
import qualified CachegrindParse
import qualified PerfStatParse
-- import Utils
-- import Debug.Trace
-- | A handy shortcut.
ml :: String -> Label
ml = Ms.mkLabel
---------------------------------------------------------------------
-- TEST CONFIGURATION - which tests are available to run
-- | These are directories that contain tests.
testRoots :: [String]
testRoots = words "imaginary spectral real shootout parallel gc smp"
defaultRoots :: [String]
defaultRoots = words "imaginary spectral real shootout"
-- -- | These are tests that are under testRoots, but should be skipped (all are skipped by the Makefile system)
-- disabledTests :: [TestName]
-- disabledTests =
-- [ TestName "spectral/hartel"
-- , TestName "spectral/last-piece"
-- , TestName "spectral/secretary"
-- , TestName "spectral/minimax"
-- , TestName "parallel/cfd"
-- , TestName "parallel/dcbm"
-- , TestName "parallel/linsolv"
-- , TestName "parallel/warshall"
-- ]
-- -- | These tests are compiled by the Makefile system, but don't work for me (mostly GHC 7.4 breaks)
-- newlyDisabledTests :: [TestName]
-- newlyDisabledTests =
-- [ TestName "power"
-- , TestName "lift"
-- , TestName "fulsom"
-- , TestName "fluid"
-- , TestName "real/eff"
-- ]
-- | Directories containing tests that the system can run.
getTestDirs :: [TestName] -> IO [TestName]
getTestDirs user_roots = do
benchDirs <- if null user_roots
then concat <$> mapM getSubDirs testRoots
else concat <$> mapM getSubDirs (map unTestName user_roots)
return $ map TestName benchDirs
-- Looking at a folder, determine paths to actual benchmarks.
--
-- We do so by parsing the makefile. If there is no Makefile there are no benchmarks.
-- If there is a SUBDIRS entry it gives the subfolders containing benchmarks
-- directly or indirectly via another Makefile with a SUBDIRS entry.
-- If there is a Makefile but no SUBDIRS entry then the path itself must be
-- a benchmark.
-- This only applies to benchmark folders. (real, shootout/binary-trees, ..)
getSubDirs :: FilePath -> IO [FilePath]
getSubDirs root = do
hasMakefile <- IO.doesFileExist $ root </> "Makefile"
if not hasMakefile then return [] else do
config <- readConfig $ root </> "Makefile"
let subdir_paths = words $ config "SUBDIRS"
if null subdir_paths
then return [root]
else concat <$> mapM (\s -> getSubDirs (root </> s)) subdir_paths
-- contents <- IO.listDirectory root
-- subDirs <- filterM hasMakeFile (map (root </>) contents)
-- return $ if null subDirs
-- then [root]
-- else subDirs
-- hasMakeFile dir = do
-- (IO.doesDirectoryExist dir) <|> (IO.doesFileExist (dir </> "Makefile"))
---------------------------------------------------------------------
-- MAIN DRIVER
-- | Main program, just interpret the arguments and dispatch the tasks.
main :: IO ()
main = do
-- Sanitize arguments
args <- nofibArgs
case args of
Build{..} -> do
when clean $
removeDirectoryRecursive output
tests' <- getTestDirs tests
putStrLn $ "Running: " ++ unwords (map unTestName tests')
let shakeOpts = shakeOptions
{ shakeThreads = threads
, shakeFiles = output ++ "/"
, shakeReport = [output ++ "/shake_report.html"]
, shakeStaunch = True
, shakeVerbosity = Development.Shake.Loud
}
-- print shakeOpts
shake shakeOpts $ buildRules (args {tests = tests'})
putStrLn "Build completed"
-- | Rules to build the given tests. For each test, these are the files
-- we care about:
--
-- * config.txt - a cleaned up version of the configuration out of Makefile,
-- created by convertConfig. Also contains "MAIN" which points at the name
-- of the Main module.
--
-- * Main.exe - the actual binary, produced by ghc linking everything.
--
-- * .depend - lists all .o files required and their dependencies. Created by ghc -M.
--
-- * .hi/.o - files produced by ghc -c.
--
-- * .result - the stdout and stderr output from the build
--
-- Most complication comes from modules not named Main, which still produce
-- Main.o object files (I think ghc -M gets these wrong).
buildRules :: Nofib -> Rules ()
buildRules nofib@Build{..} = do
linkerResource <- newResource "ghc linker" 1
let resultDir :: TestName -> FilePath
resultDir (TestName t) = output </> t
unoutput :: String -> TestName
unoutput =
let f path
| hasExtension path = f (takeDirectory path)
| otherwise = path
in TestName . f . takeDirectory . drop (length output + 1)
want $ concat
[ [resultDir t </> "Main" <.> exe, resultDir t </> "config.txt"]
| t <- tests
]
when cachegrind $ want [ output </> "cachegrind.results.tsv" ]
when perf $ want [ output </> "perf.results.tsv" ]
when (not cachegrind && not perf) $ want [ output </> "run.results.tsv" ]
-- Convenience phony rules
sequence_
[ unTestName t ~> need [resultDir t </> "results.tsv"]
| t <- tests
]
-- Aggregate rules
let aggregateTarget :: [FilePath] -> FilePath -> Action ()
aggregateTarget results out = do
let results' = [ resultDir t </> fname
| t <- tests
, fname <- results
]
liftIO $ print out
liftIO $ print results'
need results'
xs <- mapM readFileLines results'
writeFileLines out (concat xs)
(output </> "perf.results.tsv") %> aggregateTarget ["Main.perf.results.tsv"]
(output </> "cachegrind.results.tsv") %> aggregateTarget ["Main.cachegrind.results.tsv"]
(output </> "run.results.tsv") %> aggregateTarget ["Main" <.> "link.tsv", "Main.run.results.tsv"]
let ghcPkg = let (path, _ghcExec) = (FP.splitFileName compiler)
in path </> "ghc-pkg" <> IO.exeExtension
-- Build dependency installation
let buildDepsRoot = output </> "dep-packages" :: FilePath
buildDepsStamp = buildDepsRoot </> ".stamp" :: FilePath
let buildDepsPkgDb = do
need [buildDepsStamp]
compilerVer <- liftIO $ compilerVersion compiler
-- Ideally we would rather point GHC at the package environment file
-- created by cabal-install, but unfortunately I haven't been able to
-- convince cabal v2-install to create such a file.
-- The cabal env interface described here looks handy:
-- https://github.com/haskell/cabal/issues/6481#issuecomment-620865817
let pkgdb_path = buildDepsRoot </> ("ghc-" <> compilerVer) </> "package.db"
return $ pkgdb_path
buildDepsArgs _test = do
pkgdb <- buildDepsPkgDb
db_exists <- liftIO $ IO.doesPathExist pkgdb
unless (db_exists) $ do
cmd_ ghcPkg "init" pkgdb
return [ "-package-db", pkgdb, "-no-user-package-db" ]
buildDepsStamp %> \out -> do
configs <- mapM (getTestConfig nofib) tests
let deps = foldMap (\config -> words $ config "SRC_DEPS") configs
-- TODO: Invoking cabal in the way we do without any package argument fails.
root <- liftIO $ IO.makeAbsolute buildDepsRoot
unless (null deps) $ cmd_ "cabal" ("--store-dir=" <> root) "v2-install" "--lib" "-w" compiler "--allow-newer" deps
-- cmd_ "cabal" ("--store-dir=" <> root) "v2-install" "--lib" "-w" compiler "--allow-newer" deps
liftIO $ writeFile out ""
-- Benchmark rules
"//config.txt" %> \out -> do
let test = unoutput out
let dir = testDir test
src <- readFileLines $ dir </> "Makefile"
let poss = ["Main.hs","Main.lhs","Era.hs","SumEuler.hs",takeFileName dir <.> "hs",takeFileName dir <.> "lhs"]
bs <- filterM (doesFileExist . (dir </>)) poss
let mainMod = case bs of
[] -> error $ "Could not find Main file for " ++ dir
x:_ -> "MAIN = " ++ x
writeFileLines out $ mainMod : convertConfig src
-- Link executable
["//Main" <.> exe, "//Main.link.tsv"] &%> \[out, resultsTsv] -> do
deps <- readFile' $ replaceFileName out ".depends"
let objs = nub [ if isLower $ head $ takeFileName x then replaceExtension out "o" else output </> x
| x <- words deps, takeExtension x == ".o"]
need objs
let test = unoutput out
-- Metrics from object file compilations
objectResults <- forM objs $ \o -> do
liftIO $ Ms.readFile (o <.> "compile.tsv")
-- Link executable
compileArgs <- getTestCompileArgs nofib test
deps_args <- buildDepsArgs test
() <- withResource linkerResource 1 $
-- We pass the compiler_args as well, as we don't distinguish between link and compile time arguments
cmd compiler $ ["-Rghc-timing","-rtsopts","-o", out] ++ objs ++ compileArgs ++ compiler_args ++ deps_args
-- Report executable size
Stdout out_err <- cmd "size" [out]
let execSize = ParseResults.parseCodeSize $ BS.unpack out_err
liftIO $ Ms.writeFileTsv resultsTsv
$ fold objectResults
<> Ms.singleton (testLabel test <> ml "executable size") (realToFrac execSize)
-- Compile object code
["//*.o","//*.hi","//*.o.compile.tsv"] &%> \[o, _hi, resultsTsv] -> do
liftIO $ print o
let test = unoutput o
dir = testDir test
obj = output </> dir
config <- readConfig' $ obj </> "config.txt"
liftIO $ print "FooBar"
-- Figure out source location
let modName =
let x = dropExtension $ drop (length obj + 1) o
in if x == "Main" then dropExtension $ config "MAIN" else x
src <- do b <- doesFileExist $ dir </> modName <.> "hs"
return $ dir </> modName <.> (if b then "hs" else "lhs")
-- Figure out build dependencies
need $ [obj </> ".depends"]
deps <- readFileLines $ obj </> ".depends"
liftIO $ print "deps:"
liftIO $ print deps
let mkNeed rhs =
if takeExtension rhs `elem` [".h",".hs",".lhs"]
then replaceExtension rhs ".o"
else output </> rhs
let needs = [ mkNeed r
| lhs:":":rhss <- map words $ deps
, -- equalFilePath is required so that foo/bar and foo\bar match.
-- This can happen on windows.
equalFilePath (dir </> modName <.> "o") lhs
, r <- rhss
-- For a dependency of Main.o : Main.hs there is nothing to do
, not (equalFilePath r src)
]
liftIO $ do
print "needs"
mapM_ print needs
need needs
-- Compile it
let ghc_rts_args = [ "+RTS", "--machine-readable", "-t"++o++".stats" ]
compileArgs <- getTestCompileArgs nofib test
deps_args <- buildDepsArgs test
() <- cmd compiler $ ["-Rghc-timing","-c",src,"-w","-i"++obj,"-odir="++obj,"-hidir="++obj]
++ compileArgs ++ compiler_args ++ deps_args ++ ghc_rts_args
-- Measure code size
Stdout out_err <- cmd "size" [o]
let objSize = realToFrac $ ParseResults.parseCodeSize $ BS.unpack out_err
rtsStats <- liftIO $ readRtsStats $ o++".stats"
liftIO $ Ms.writeFileTsv resultsTsv
$ Ms.prefix (testLabel test <> ml "objects" <> Ms.mkLabel (takeFileName o))
$ Ms.singleton (ml "size") objSize
<> Ms.prefix (ml "rts stats") rtsStats
-- Compute build dependencies
"//.depends" %> \out -> do
let test = unoutput out
config <- readConfig' $ takeDirectory out </> "config.txt"
compileArgs <- getTestCompileArgs nofib test
deps_args <- buildDepsArgs test
cmd_ compiler $
[ "-w"
, "-M",testDir test </> config "MAIN"
, "-i" ++ testDir test
, "-dep-makefile=" ++ out
, "-dep-suffix", ""
] ++ compileArgs ++
-- It's unlikely but possible that flags could affect dependencies.
compiler_args ++
deps_args
src <- liftIO $ readFile out
need [x | x <- words src, takeExtension x `elem` [".hs",".lhs",".h"]]
-- Run tests normally
["//Main.run.results.tsv"] &%> \[resultsTsv] -> do
runTest nofib ModeRun resultsTsv
-- Run tests under perf stat
["//Main.perf.result", "//Main.perf.results.tsv"] &%> \[out, resultsTsv] -> do
out' <- liftIO $ IO.canonicalizePath out
let test = testFromResultTsv nofib resultsTsv
let args n = ["perf", "stat"] <> perf_args <> ["-x,", ("--output="<>out' <.> show n), "--"]
let parse_perf n = do
stats <- PerfStatParse.readPerfStat (out' <.> show n)
return $ Ms.fromList
[ (testLabel test <> ml "run" <> ml "perf" <> lbl, v)
| (eventName, vs) <- M.toList stats
, v <- vs
, let lbl = Ms.mkLabel $ PerfStatParse.getEventName eventName
]
runTest nofib (ModeWrapped args parse_perf) resultsTsv
-- Run tests under cachegrind
["//Main.cachegrind.result", "//Main.cachegrind.results.tsv"] &%> \[out, resultsTsv] -> do
out' <- liftIO $ IO.canonicalizePath out
let test = testFromResultTsv nofib resultsTsv
let wrapper_args n = ["valgrind", "--tool=cachegrind"] <> cachegrind_args <>
[("--cachegrind-out-file="<>out'<.>show n)]
let parse_cachegrind n = do
stats <- CachegrindParse.parse (out' <.> show n)
return $ Ms.fromList
[ (testLabel test <> ml "run" <> ml "cachegrind" <> lbl, realToFrac v)
| (eventName, v) <- M.toList stats
, let lbl = Ms.mkLabel $ CachegrindParse.getEventName eventName
]
runTest nofib (ModeWrapped wrapper_args parse_cachegrind) resultsTsv
data RunMode = ModeRun -- ^ Regular runtime measurement
-- | Wrap the executable by a call to another executable.
--
-- For example perf or valgrind.
| ModeWrapped (Int -> [String])
(Int -> IO (Measurements Double))
getWrapperArgs :: RunMode -> (Int -> [String])
getWrapperArgs ModeRun = const []
getWrapperArgs (ModeWrapped args _) = args
getWrapperParser :: RunMode -> (Int -> IO (Measurements Double))
getWrapperParser ModeRun = \_ -> return mempty
getWrapperParser (ModeWrapped _ parser) = parser
---------------------------------------------------------------------
-- RULES
-- | "foo/results.tsv" => TestName foo
testFromResultTsv :: Nofib -> String -> TestName
testFromResultTsv Build{..}=
let f path
| hasExtension path = f (takeDirectory path)
| otherwise = path
in TestName . f . takeDirectory . drop (length output + 1)
runTest :: Nofib
-> RunMode
-> String
-> Action ()
runTest nofib@Build{..} runMode resultsTsv = do
-- Build executable first
need [takeDirectory resultsTsv </> "config.txt"]
need [replaceExtensions resultsTsv exe]
let test = testFromResultTsv nofib resultsTsv :: TestName
-- Construct benchmark invocation
(stdin, args) <- liftIO $ getTestCmdline nofib test
executable <- liftIO $ IO.canonicalizePath $ output </> testDir test </> "Main" <.> exe
-- Create stats.0, stats.1, etc.
let doRun :: Int -> Action ()
doRun n = do
let rtsStatsOut = executable <.> "stats" <.> show n
cmd_ (Cwd $ testDir test) (EchoStdout False) (StdinBS stdin)
(getWrapperArgs runMode $ n)
executable args "+RTS" rts_args "--machine-readable" ("-t"++rtsStatsOut)
-- Run benchmarks n times
forM_ [1..times] $ \n -> doRun n
-- Read results
let doParse :: Int -> Action (Measurements Double)
doParse n = do
let rtsStatsOut = executable <.> "stats" <.> show n
wrapper_measurements <- liftIO (getWrapperParser runMode $ n) :: Action (Measurements Double)
rtsStats <- liftIO $ readRtsStats rtsStatsOut
return $
wrapper_measurements <>
(Ms.prefix (testLabel test <> ml "run" <> ml "rts stats") rtsStats)
measurements <- foldMap doParse [1..times :: Int] :: Action (Measurements Double)
liftIO $ Ms.writeFileTsv resultsTsv $ measurements
getTestConfig :: Nofib -> TestName -> Action (String -> String)
getTestConfig Build{..} test =
readConfig' $ output </> testDir test </> "config.txt"
getTestCompileArgs :: Nofib -> TestName -> Action [String]
getTestCompileArgs nofib test = do
config <- getTestConfig nofib test
return $ words (config "SRC_HC_OPTS")
++ [ "-package-env", "-" ]
++ concat [ ["-package", pkg] | pkg <- words (config "SRC_DEPS") ]
getModeArgs :: (String -> String) -> Speed -> [String]
getModeArgs benchSettings speed = words $
case speed of
Slow -> with_default "SLOW_OPTS"
Norm -> benchSettings "NORM_OPTS"
Fast -> with_default "FAST_OPTS"
where
with_default mode_key
| settings <- (benchSettings mode_key)
, not (null settings)
= settings
| otherwise
= (benchSettings "NORM_OPTS")
getTestCmdline :: Nofib -> TestName -> IO (BSL.ByteString, [String])
getTestCmdline Build{..} test = do
config <- readConfig $ output </> unTestName test </> "config.txt"
-- Mode/Speed args default to normal mode.
let speed_args = getModeArgs config speed
-- print config
let args = words (config "PROG_ARGS")
++ speed_args
stdin_path <-
let s = config "STDIN_FILE"
in if s == ""
then grab "stdin"
else pure $ Just $ testDir test </> s
putStrLn $ "test " <> unTestName test <> " stdin: " <> show stdin_path
stdin <- maybe (pure BSL.empty) BSL.readFile stdin_path
return (stdin, args)
where
grab :: String -> IO (Maybe FilePath)
grab ext = do
let s = [testDir test </> takeFileName (unTestName test) <.> map toLower (show speed) ++ ext
,testDir test </> takeFileName (unTestName test) <.> ext]
ss <- filterM IO.doesFileExist s
return $ listToMaybe ss
readRtsStats :: FilePath -> IO (Measurements Double)
readRtsStats fname = do
rtsStats <- ParseResults.parseRtsStats <$> readFile fname
return $ Ms.fromList $ map (first Ms.mkLabel) $ M.toList rtsStats
---------------------------------------------------------------------
-- CONFIGURATION UTILITIES
-- The Makefile's are slurped for configuration, to produce a cleaned-up config file
-- | Given the source of a Makefile, slurp out the configuration strings.
convertConfig :: [String] -> [String]
convertConfig xs =
[ k ++ " = " ++ v
| (k, v) <- M.toList vars
]
where
vars =
M.fromListWith (\a b -> a ++ " " ++ b)
[ (a, b)
| x <- xs
, let (a,b) = separate x
, a `elem` keep
]
keep = words "PROG_ARGS SRC_HC_OPTS SLOW_OPTS NORM_OPTS FAST_OPTS STDIN_FILE SRC_DEPS SUBDIRS"
separate x = (name,rest)
where (name,x2) = span (\c -> isAlpha c || c == '_') x
rest = dropWhile isSpace $ dropWhile (`elem` "+=") $ dropWhile isSpace x2
-- | Read a configuration file (new format) into a function supplying options.
readConfig :: FilePath -> IO (String -> String)
readConfig x = do
src <- fuseLines <$> readFile x
let res = [ (reverse $ dropWhile isSpace $ reverse a, dropWhile isSpace $ drop 1 b)
| y <- lines src
, let (a,b) = break (== '=') y