haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-11 08:45:35 +03:00
Code Issues Projects Releases Wiki Activity

Extract the benchmarking Shake rules to a standalone Cabal package (haskell/ghcide#941)

Browse Source 
* [bench-hist] break down in rule functions

* Extract the benchmarking Shake rules to a shake-bench package

There's some room for reusing the rules used in the historic benchmarking suite
in other projects. This change makes that a bit easier and improves the
documentation and code structure.

The new structure is:
- lib:shake-bench - a Cabal library with functions to generate Shake rules
- ghcide:bench:benchHist - the ghcide instantiation of the above Shake rules

That's not to say that shake-bench is completely decoupled from ghcide -
there are still plenty of assumptions on how the benchmarks are organized, their
outputs, etc. But with a little bit of effort, it should be easy to make
these rules more reusable

* Fix nix build

* Fix license

* hlints and redundant imports

* more hlints

* Exclude shake-bench from the stack build
This commit is contained in:
Pepe Iborra 2020-12-07 15:03:15 +00:00 committed by GitHub
parent c47f892df8
commit 14af467e97
15 changed files with 906 additions and 473 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.hlint.yaml
View File

@ -63,7 +63,6 @@
- {name: GeneralizedNewtypeDeriving, within: []}
- {name: LambdaCase, within: []}
- {name: NamedFieldPuns, within: []}
- {name: OverloadedStrings, within: []}
- {name: PackageImports, within: []}
- {name: RecordWildCards, within: []}
- {name: ScopedTypeVariables, within: []}

2
fmt.sh
View File

@ -1,3 +1,3 @@
#!/usr/bin/env bash
set -eou pipefail
curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s src exe bench/exe test/exe --with-group=extra
curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s src exe bench shake-bench/src test/exe --with-group=extra

3
ghcide/bench/config.yaml
View File

@ -4,9 +4,6 @@ samples: 100
buildTool: cabal
# Path to the ghcide-bench binary to use for experiments
ghcideBench: ghcide-bench
# Output folder for the experiments
outputFolder: bench-results

509
ghcide/bench/hist/Main.hs
View File

@ -38,491 +38,110 @@
> cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"
-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies#-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wno-orphans #-}
import Control.Applicative (Alternative (empty))
import Control.Monad (when, forM, forM_, replicateM)
import Data.Char (toLower)
import Data.Foldable (find)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow)
import Data.Yaml (FromJSON (..), decodeFileThrow)
import Development.Benchmark.Rules
import Development.Shake
import Development.Shake.Classes (Binary, Hashable, NFData)
import Experiments.Types (getExampleName, exampleToOptions, Example(..))
import GHC.Exts (IsList (..))
import Experiments.Types (Example, exampleToOptions)
import qualified Experiments.Types as E
import GHC.Generics (Generic)
import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
import Graphics.Rendering.Chart.Easy ((.=))
import qualified Graphics.Rendering.Chart.Easy as E
import Numeric.Natural (Natural)
import System.Directory
import System.FilePath
import qualified Text.ParserCombinators.ReadP as P
import Text.Read (Read (..), get, readMaybe, readP_to_Prec)
import GHC.Stack (HasCallStack)
import Data.List (transpose)
config :: FilePath
config = "bench/config.yaml"
-- | Read the config without dependency
readConfigIO :: FilePath -> IO Config
readConfigIO :: FilePath -> IO (Config BuildSystem)
readConfigIO = decodeFileThrow
newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show)
instance IsExample Example where getExampleName = E.getExampleName
type instance RuleResult GetExample = Maybe Example
type instance RuleResult GetExamples = [Example]
type instance RuleResult GetSamples = Natural
type instance RuleResult GetExperiments = [Unescaped String]
type instance RuleResult GetVersions = [GitCommit]
type instance RuleResult GetParent = Text
type instance RuleResult GetCommitId = String
main :: IO ()
main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
want ["all"]
createBuildSystem $ \resource -> do
configStatic <- liftIO $ readConfigIO config
let build = outputFolder configStatic
buildRules build ghcideBuildRules
benchRules build resource (MkBenchRules (benchGhcide $ samples configStatic) "ghcide")
csvRules build
svgRules build
action $ allTargets build
readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)
_ <- addOracle $ \GetSamples {} -> samples <$> readConfig config
_ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config
_ <- addOracle $ \GetVersions {} -> versions <$> readConfig config
_ <- addOracle $ \GetExamples{} -> examples <$> readConfig config
_ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config
_ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config
let readVersions = askOracle $ GetVersions ()
readExperiments = askOracle $ GetExperiments ()
readExamples = askOracle $ GetExamples ()
readSamples = askOracle $ GetSamples ()
getParent = askOracle . GetParent
getExample = askOracle . GetExample
configStatic <- liftIO $ readConfigIO config
ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config)
let build = outputFolder configStatic
buildSystem = buildTool configStatic
phony "all" $ do
Config {..} <- readConfig config
need $
[build </> getExampleName e </> "results.csv" | e <- examples ] ++
[build </> "results.csv"]
++ [ build </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"
| e <- experiments
, ex <- examples
]
++ [ build </> getExampleName ex </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"
| e <- experiments,
ex <- examples,
ver <- versions,
mode <- ["", "diff"]
]
build -/- "*/commitid" %> \out -> do
alwaysRerun
let [_,ver,_] = splitDirectories out
mbEntry <- find ((== T.pack ver) . humanName) <$> readVersions
let gitThing :: String
gitThing = maybe ver (T.unpack . gitName) mbEntry
Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]
writeFileChanged out $ init commitid
priority 10 $ [ build -/- "HEAD/ghcide"
, build -/- "HEAD/ghc.path"
]
&%> \[out, ghcpath] -> do
liftIO $ createDirectoryIfMissing True $ dropFileName out
need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"]
cmd_ $ buildGhcide buildSystem (takeDirectory out)
ghcLoc <- findGhc "." buildSystem
writeFile' ghcpath ghcLoc
[ build -/- "*/ghcide",
build -/- "*/ghc.path"
]
&%> \[out, ghcpath] -> do
let [b, ver, _] = splitDirectories out
liftIO $ createDirectoryIfMissing True $ dropFileName out
commitid <- readFile' $ b </> ver </> "commitid"
cmd_ $ "git worktree add bench-temp " ++ commitid
flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do
ghcLoc <- findGhc "bench-temp" buildSystem
cmd_ [Cwd "bench-temp"] $ buildGhcide buildSystem (".." </> takeDirectory out)
writeFile' ghcpath ghcLoc
build -/- "*/*/results.csv" %> \out -> do
experiments <- readExperiments
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
allResults <- traverse readFileLines allResultFiles
let header = head $ head allResults
results = map tail allResults
writeFileChanged out $ unlines $ header : concat results
ghcideBenchResource <- newResource "ghcide-bench" 1
priority 0 $
[ build -/- "*/*/*.csv",
build -/- "*/*/*.benchmark-gcStats",
build -/- "*/*/*.log"
]
&%> \[outcsv, _outGc, outLog] -> do
let [_, exampleName, ver, exp] = splitDirectories outcsv
example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> getExample exampleName
samples <- readSamples
liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
let ghcide = build </> ver </> "ghcide"
ghcpath = build </> ver </> "ghc.path"
need [ghcide, ghcpath]
ghcPath <- readFile' ghcpath
withResource ghcideBenchResource 1 $ do
command_
[ EchoStdout False,
FileStdout outLog,
RemEnv "NIX_GHC_LIBDIR",
RemEnv "GHC_PACKAGE_PATH",
AddPath [takeDirectory ghcPath, "."] []
]
ghcideBenchPath $
[ "--timeout=3000",
"-v",
"--samples=" <> show samples,
"--csv=" <> outcsv,
"--ghcide-options= +RTS -I0.5 -RTS",
"--ghcide=" <> ghcide,
"--select",
unescaped (unescapeExperiment (Escaped $ dropExtension exp))
] ++
exampleToOptions example ++
[ "--stack" | Stack == buildSystem]
cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv
build -/- "results.csv" %> \out -> do
examples <- map getExampleName <$> readExamples
let allResultFiles = [build </> e </> "results.csv" | e <- examples]
allResults <- traverse readFileLines allResultFiles
let header = head $ head allResults
results = map tail allResults
header' = "example, " <> header
results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results
writeFileChanged out $ unlines $ header' : concat results'
build -/- "*/results.csv" %> \out -> do
versions <- map (T.unpack . humanName) <$> readVersions
let example = takeFileName $ takeDirectory out
allResultFiles =
[build </> example </> v </> "results.csv" | v <- versions]
allResults <- traverse readFileLines allResultFiles
let header = head $ head allResults
results = map tail allResults
header' = "version, " <> header
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results
writeFileChanged out $ unlines $ header' : interleave results'
priority 2 $
build -/- "*/*/*.diff.svg" %> \out -> do
let [b, example, ver, exp_] = splitDirectories out
exp = Escaped $ dropExtension $ dropExtension exp_
prev <- getParent $ T.pack ver
runLog <- loadRunLog b example exp ver
runLogPrev <- loadRunLog b example exp $ T.unpack prev
let diagram = Diagram Live [runLog, runLogPrev] title
title = show (unescapeExperiment exp) <> " - live bytes over time compared"
plotDiagram True diagram out
priority 1 $
build -/- "*/*/*.svg" %> \out -> do
let [b, example, ver, exp] = splitDirectories out
runLog <- loadRunLog b example (Escaped $ dropExtension exp) ver
let diagram = Diagram Live [runLog] title
title = ver <> " live bytes over time"
plotDiagram True diagram out
build -/- "*/*.svg" %> \out -> do
let exp = Escaped $ dropExtension $ takeFileName out
example = takeFileName $ takeDirectory out
versions <- readVersions
runLogs <- forM (filter include versions) $ \v -> do
loadRunLog build example exp $ T.unpack $ humanName v
let diagram = Diagram Live runLogs title
title = show (unescapeExperiment exp) <> " - live bytes over time"
plotDiagram False diagram out
ghcideBuildRules :: MkBuildRules BuildSystem
ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" buildGhcide
--------------------------------------------------------------------------------
buildGhcide :: BuildSystem -> String -> String
buildGhcide Cabal out = unwords
["cabal install"
,"exe:ghcide"
,"--installdir=" ++ out
,"--install-method=copy"
,"--overwrite-policy=always"
,"--ghc-options -rtsopts"
]
buildGhcide Stack out =
"stack --local-bin-path=" <> out
<> " build ghcide:ghcide --copy-bins --ghc-options -rtsopts"
findGhc :: FilePath -> BuildSystem -> Action FilePath
findGhc _cwd Cabal =
liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"
findGhc cwd Stack = do
Stdout ghcLoc <- cmd [Cwd cwd] (s "stack exec which ghc")
return ghcLoc
--------------------------------------------------------------------------------
data Config = Config
data Config buildSystem = Config
{ experiments :: [Unescaped String],
examples :: [Example],
samples :: Natural,
versions :: [GitCommit],
-- | Path to the ghcide-bench binary for the experiments
ghcideBench :: FilePath,
-- | Output folder ('foo' works, 'foo/bar' does not)
outputFolder :: String,
buildTool :: BuildSystem
buildTool :: buildSystem
}
deriving (Generic, Show)
deriving anyclass (FromJSON)
data GitCommit = GitCommit
{ -- | A git hash, tag or branch name (e.g. v0.1.0)
gitName :: Text,
-- | A human understandable name (e.g. fix-collisions-leak)
name :: Maybe Text,
-- | The human understandable name of the parent, if specified explicitly
parent :: Maybe Text,
-- | Whether to include this version in the top chart
include :: Bool
}
deriving (Binary, Eq, Hashable, Generic, NFData, Show)
createBuildSystem :: (Resource -> Rules a) -> Rules a
createBuildSystem userRules = do
readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)
instance FromJSON GitCommit where
parseJSON (String s) = pure $ GitCommit s Nothing Nothing True
parseJSON (Object (toList -> [(name, String gitName)])) =
pure $ GitCommit gitName (Just name) Nothing True
parseJSON (Object (toList -> [(name, Object props)])) =
GitCommit
<$> props .:? "git" .!= name
<*> pure (Just name)
<*> props .:? "parent"
<*> props .:? "include" .!= True
parseJSON _ = empty
_ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config
_ <- addOracle $ \GetVersions {} -> versions <$> readConfig config
_ <- addOracle $ \GetExamples{} -> examples <$> readConfig config
_ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config
_ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config
instance ToJSON GitCommit where
toJSON GitCommit {..} =
case name of
Nothing -> String gitName
Just n -> Object $ fromList [(n, String gitName)]
benchResource <- newResource "ghcide-bench" 1
humanName :: GitCommit -> Text
humanName GitCommit {..} = fromMaybe gitName name
userRules benchResource
findPrev :: Text -> [GitCommit] -> Text
findPrev name (x : y : xx)
| humanName y == name = humanName x
| otherwise = findPrev name (y : xx)
findPrev name _ = name
--------------------------------------------------------------------------------
data BuildSystem = Cabal | Stack
deriving (Eq, Read, Show)
instance FromJSON BuildSystem where
parseJSON x = fromString . map toLower <$> parseJSON x
where
fromString "stack" = Stack
fromString "cabal" = Cabal
fromString other = error $ "Unknown build system: " <> other
instance ToJSON BuildSystem where
toJSON = toJSON . show
----------------------------------------------------------------------------------------------------
-- | A line in the output of -S
data Frame = Frame
{ allocated, copied, live :: !Int,
user, elapsed, totUser, totElapsed :: !Double,
generation :: !Int
}
deriving (Show)
instance Read Frame where
readPrec = do
spaces
allocated <- readPrec @Int <* spaces
copied <- readPrec @Int <* spaces
live <- readPrec @Int <* spaces
user <- readPrec @Double <* spaces
elapsed <- readPrec @Double <* spaces
totUser <- readPrec @Double <* spaces
totElapsed <- readPrec @Double <* spaces
_ <- readPrec @Int <* spaces
_ <- readPrec @Int <* spaces
"(Gen: " <- replicateM 7 get
generation <- readPrec @Int
')' <- get
return Frame {..}
where
spaces = readP_to_Prec $ const P.skipSpaces
data TraceMetric = Allocated | Copied | Live | User | Elapsed
deriving (Generic, Enum, Bounded, Read)
instance Show TraceMetric where
show Allocated = "Allocated bytes"
show Copied = "Copied bytes"
show Live = "Live bytes"
show User = "User time"
show Elapsed = "Elapsed time"
frameMetric :: TraceMetric -> Frame -> Double
frameMetric Allocated = fromIntegral . allocated
frameMetric Copied = fromIntegral . copied
frameMetric Live = fromIntegral . live
frameMetric Elapsed = elapsed
frameMetric User = user
data Diagram = Diagram
{ traceMetric :: TraceMetric,
runLogs :: [RunLog],
title :: String
}
deriving (Generic)
-- | A file path containing the output of -S for a given run
data RunLog = RunLog
{ runVersion :: !String,
_runExample :: !String,
_runExperiment :: !String,
runFrames :: ![Frame],
runSuccess :: !Bool
}
loadRunLog :: HasCallStack => FilePath -> String -> Escaped FilePath -> FilePath -> Action RunLog
loadRunLog buildF example exp ver = do
let log_fp = buildF </> example </> ver </> escaped exp <.> "benchmark-gcStats"
csv_fp = replaceExtension log_fp "csv"
log <- readFileLines log_fp
csv <- readFileLines csv_fp
let frames =
[ f
| l <- log,
Just f <- [readMaybe l],
-- filter out gen 0 events as there are too many
generation f == 1
buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action ()
buildGhcide Cabal args out = do
command_ args "cabal"
["install"
,"exe:ghcide"
,"--installdir=" ++ out
,"--install-method=copy"
,"--overwrite-policy=always"
,"--ghc-options=-rtsopts"
]
success = case map (T.split (== ',') . T.pack) csv of
[_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s
_ -> error $ "Cannot parse: " <> csv_fp
return $ RunLog ver example (dropExtension $ escaped exp) frames success
plotDiagram :: Bool -> Diagram -> FilePath -> Action ()
plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do
let extract = frameMetric traceMetric
liftIO $ E.toFile E.def out $ do
E.layout_title .= title t
E.setColors myColors
forM_ runLogs $ \rl ->
when (includeFailed || runSuccess rl) $ E.plot $ do
lplot <- E.line
(runVersion rl ++ if runSuccess rl then "" else " (FAILED)")
[ [ (totElapsed f, extract f)
| f <- runFrames rl
]
]
return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2)
buildGhcide Stack args out =
command_ args "stack"
["--local-bin-path=" <> out
,"build"
,"ghcide:ghcide"
,"--copy-bins"
,"--ghc-options=-rtsopts"
]
s :: String -> String
s = id
benchGhcide
:: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()
benchGhcide samples buildSystem args BenchProject{..} =
command_ args "ghcide-bench" $
[ "--timeout=3000",
"-v",
"--samples=" <> show samples,
"--csv=" <> outcsv,
"--ghcide=" <> exePath,
"--select",
unescaped (unescapeExperiment experiment)
] ++
exampleToOptions example ++
[ "--stack" | Stack == buildSystem
] ++
exeExtraArgs
(-/-) :: FilePattern -> FilePattern -> FilePattern
a -/- b = a <> "/" <> b
newtype Escaped a = Escaped {escaped :: a}
newtype Unescaped a = Unescaped {unescaped :: a}
deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable)
escapeExperiment :: Unescaped String -> Escaped String
escapeExperiment = Escaped . map f . unescaped
where
f ' ' = '_'
f other = other
unescapeExperiment :: Escaped String -> Unescaped String
unescapeExperiment = Unescaped . map f . escaped
where
f '_' = ' '
f other = other
interleave :: [[a]] -> [a]
interleave = concat . transpose
myColors :: [E.AlphaColour Double]
myColors = map E.opaque
[ E.blue
, E.green
, E.red
, E.orange
, E.yellow
, E.violet
, E.black
, E.gold
, E.brown
, E.hotpink
, E.aliceblue
, E.aqua
, E.beige
, E.bisque
, E.blueviolet
, E.burlywood
, E.cadetblue
, E.chartreuse
, E.coral
, E.crimson
, E.darkblue
, E.darkgray
, E.darkgreen
, E.darkkhaki
, E.darkmagenta
, E.deeppink
, E.dodgerblue
, E.firebrick
, E.forestgreen
, E.fuchsia
, E.greenyellow
, E.lightsalmon
, E.seagreen
, E.olive
, E.sandybrown
, E.sienna
, E.peru
]

10
ghcide/bench/lib/Experiments.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ImplicitParams #-}
@ -273,19 +272,16 @@ runBenchmarksFun dir allBenchmarks = do
outputRow $ (map . map) (const '-') paddedHeaders
forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row
where
gcStats name = escapeSpaces (name <> ".benchmark-gcStats")
cmd name dir =
unwords $
[ ghcide ?config,
"--lsp",
"--test",
"--cwd",
dir,
"+RTS",
"-S" <> gcStats name
dir
]
++ case otMemoryProfiling ?config of
Just dir -> ["-l", "-ol" ++ (dir </> (map (\c -> if c == ' ' then '-' else c) name) <.> "eventlog")]
Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]
Nothing -> []
++ [ "-RTS" ]
++ ghcideOptions ?config
@ -293,7 +289,7 @@ runBenchmarksFun dir allBenchmarks = do
[ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]
]
++ ["--verbose" | verbose ?config]
++ if isJust (otMemoryProfiling ?config) then [ "--ot-memory-profiling" ] else []
++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]
lspTestCaps =
fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
conf =

3
ghcide/bench/lib/Experiments/Types.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
module Experiments.Types where
{-# LANGUAGE OverloadedStrings #-}
module Experiments.Types (module Experiments.Types ) where
import Data.Aeson
import Data.Version

2
ghcide/cabal.project
View File

@ -1,4 +1,4 @@
packages: . ./hie-compat/
packages: . ./hie-compat/ ./shake-bench/
test-show-details: direct

10
ghcide/ghcide.cabal
View File

@ -208,7 +208,6 @@ benchmark benchHist
hs-source-dirs: bench/hist bench/lib
other-modules: Experiments.Types
build-tool-depends:
ghcide:ghcide,
ghcide:ghcide-bench
default-extensions:
BangPatterns
@ -218,7 +217,6 @@ benchmark benchHist
GeneralizedNewtypeDeriving
LambdaCase
NamedFieldPuns
OverloadedStrings
RecordWildCards
ScopedTypeVariables
StandaloneDeriving
@ -229,12 +227,8 @@ benchmark benchHist
build-depends:
aeson,
base == 4.*,
Chart,
Chart-diagrams,
diagrams,
diagrams-svg,
shake-bench == 0.1.*,
directory,
extra >= 1.7.2,
filepath,
shake,
text,
@ -392,7 +386,7 @@ executable ghcide-bench
text
hs-source-dirs: bench/lib bench/exe
include-dirs: include
ghc-options: -threaded -Wall -Wno-name-shadowing
ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
main-is: Main.hs
other-modules:
Experiments

5
ghcide/hie.yaml
View File

@ -4,6 +4,11 @@ cradle:
multi:
- path: "./test/data"
config: { cradle: { none: } }
- path: "./shake-bench/src"
config:
cradle:
cabal:
component: "lib:shake-bench"
- path: "./"
config:
cradle:

13
ghcide/nix/default.nix
View File

@ -14,14 +14,21 @@ let
});
};
};
gitignoreSource = (import sources.gitignore { inherit (pkgs) lib; }).gitignoreSource;
extend = haskellPackages:
(haskellPackages.override sharedOverrides).extend (pkgs.haskell.lib.packageSourceOverrides {
ghcide = gitignoreSource ../.;
hie-compat = gitignoreSource ../hie-compat;
shake-bench = gitignoreSource ../shake-bench;
});
in
{
inherit (import sources.gitignore { inherit (pkgs) lib; }) gitignoreSource;
inherit gitignoreSource;
ourHaskell = pkgs.haskell // {
packages = pkgs.haskell.packages // {
# relax upper bounds on ghc 8.10.x versions (and skip running tests)
ghc8101 = pkgs.haskell.packages.ghc8101.override sharedOverrides;
ghc8102 = pkgs.haskell.packages.ghc8102.override sharedOverrides;
ghc8101 = extend pkgs.haskell.packages.ghc8101;
ghc8102 = extend pkgs.haskell.packages.ghc8102;
};
};
};

7
ghcide/shell.nix
View File

@ -17,14 +17,15 @@ let defaultCompiler = "ghc" + lib.replaceStrings ["."] [""] haskellPackages.ghc.
if compiler == "default"
then ourHaskell.packages.${defaultCompiler}
else ourHaskell.packages.${compiler};
ghcide = p: haskell.lib.doCheck
(p.callCabal2nixWithOptions "ghcide" (nixpkgs.gitignoreSource ./.) "--benchmark" {});
isSupported = compiler == "default" || compiler == defaultCompiler;
in
haskellPackagesForProject.shellFor {
inherit withHoogle;
doBenchmark = true;
packages = p: [ (if isSupported then ghcide p else p.ghc-paths) ];
packages = p:
if isSupported
then [p.ghcide p.hie-compat p.shake-bench]
else [p.ghc-paths];
buildInputs = [
gmp
zlib

1
ghcide/stack.yaml
View File

@ -3,6 +3,7 @@ resolver: nightly-2020-09-02
packages:
- .
- ./hie-compat/
extra-deps:
- haskell-lsp-0.22.0.0
- haskell-lsp-types-0.22.0.0

201
shake-bench/LICENSE Normal file
View File

@ -0,0 +1,201 @@
Apache License
Version 2.0, January 2004
http://www.apache.org/licenses/
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
1. Definitions.
"License" shall mean the terms and conditions for use, reproduction,
and distribution as defined by Sections 1 through 9 of this document.
"Licensor" shall mean the copyright owner or entity authorized by
the copyright owner that is granting the License.
"Legal Entity" shall mean the union of the acting entity and all
other entities that control, are controlled by, or are under common
control with that entity. For the purposes of this definition,
"control" means (i) the power, direct or indirect, to cause the
direction or management of such entity, whether by contract or
otherwise, or (ii) ownership of fifty percent (50%) or more of the
outstanding shares, or (iii) beneficial ownership of such entity.
"You" (or "Your") shall mean an individual or Legal Entity
exercising permissions granted by this License.
"Source" form shall mean the preferred form for making modifications,
including but not limited to software source code, documentation
source, and configuration files.
"Object" form shall mean any form resulting from mechanical
transformation or translation of a Source form, including but
not limited to compiled object code, generated documentation,
and conversions to other media types.
"Work" shall mean the work of authorship, whether in Source or
Object form, made available under the License, as indicated by a
copyright notice that is included in or attached to the work
(an example is provided in the Appendix below).
"Derivative Works" shall mean any work, whether in Source or Object
form, that is based on (or derived from) the Work and for which the
editorial revisions, annotations, elaborations, or other modifications
represent, as a whole, an original work of authorship. For the purposes
of this License, Derivative Works shall not include works that remain
separable from, or merely link (or bind by name) to the interfaces of,
the Work and Derivative Works thereof.
"Contribution" shall mean any work of authorship, including
the original version of the Work and any modifications or additions
to that Work or Derivative Works thereof, that is intentionally
submitted to Licensor for inclusion in the Work by the copyright owner
or by an individual or Legal Entity authorized to submit on behalf of
the copyright owner. For the purposes of this definition, "submitted"
means any form of electronic, verbal, or written communication sent
to the Licensor or its representatives, including but not limited to
communication on electronic mailing lists, source code control systems,
and issue tracking systems that are managed by, or on behalf of, the
Licensor for the purpose of discussing and improving the Work, but
excluding communication that is conspicuously marked or otherwise
designated in writing by the copyright owner as "Not a Contribution."
"Contributor" shall mean Licensor and any individual or Legal Entity
on behalf of whom a Contribution has been received by Licensor and
subsequently incorporated within the Work.
2. Grant of Copyright License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
copyright license to reproduce, prepare Derivative Works of,
publicly display, publicly perform, sublicense, and distribute the
Work and such Derivative Works in Source or Object form.
3. Grant of Patent License. Subject to the terms and conditions of
this License, each Contributor hereby grants to You a perpetual,
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
(except as stated in this section) patent license to make, have made,
use, offer to sell, sell, import, and otherwise transfer the Work,
where such license applies only to those patent claims licensable
by such Contributor that are necessarily infringed by their
Contribution(s) alone or by combination of their Contribution(s)
with the Work to which such Contribution(s) was submitted. If You
institute patent litigation against any entity (including a
cross-claim or counterclaim in a lawsuit) alleging that the Work
or a Contribution incorporated within the Work constitutes direct
or contributory patent infringement, then any patent licenses
granted to You under this License for that Work shall terminate
as of the date such litigation is filed.
4. Redistribution. You may reproduce and distribute copies of the
Work or Derivative Works thereof in any medium, with or without
modifications, and in Source or Object form, provided that You
meet the following conditions:
(a) You must give any other recipients of the Work or
Derivative Works a copy of this License; and
(b) You must cause any modified files to carry prominent notices
stating that You changed the files; and
(c) You must retain, in the Source form of any Derivative Works
that You distribute, all copyright, patent, trademark, and
attribution notices from the Source form of the Work,
excluding those notices that do not pertain to any part of
the Derivative Works; and
(d) If the Work includes a "NOTICE" text file as part of its
distribution, then any Derivative Works that You distribute must
include a readable copy of the attribution notices contained
within such NOTICE file, excluding those notices that do not
pertain to any part of the Derivative Works, in at least one
of the following places: within a NOTICE text file distributed
as part of the Derivative Works; within the Source form or
documentation, if provided along with the Derivative Works; or,
within a display generated by the Derivative Works, if and
wherever such third-party notices normally appear. The contents
of the NOTICE file are for informational purposes only and
do not modify the License. You may add Your own attribution
notices within Derivative Works that You distribute, alongside
or as an addendum to the NOTICE text from the Work, provided
that such additional attribution notices cannot be construed
as modifying the License.
You may add Your own copyright statement to Your modifications and
may provide additional or different license terms and conditions
for use, reproduction, or distribution of Your modifications, or
for any such Derivative Works as a whole, provided Your use,
reproduction, and distribution of the Work otherwise complies with
the conditions stated in this License.
5. Submission of Contributions. Unless You explicitly state otherwise,
any Contribution intentionally submitted for inclusion in the Work
by You to the Licensor shall be under the terms and conditions of
this License, without any additional terms or conditions.
Notwithstanding the above, nothing herein shall supersede or modify
the terms of any separate license agreement you may have executed
with Licensor regarding such Contributions.
6. Trademarks. This License does not grant permission to use the trade
names, trademarks, service marks, or product names of the Licensor,
except as required for reasonable and customary use in describing the
origin of the Work and reproducing the content of the NOTICE file.
7. Disclaimer of Warranty. Unless required by applicable law or
agreed to in writing, Licensor provides the Work (and each
Contributor provides its Contributions) on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied, including, without limitation, any warranties or conditions
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
PARTICULAR PURPOSE. You are solely responsible for determining the
appropriateness of using or redistributing the Work and assume any
risks associated with Your exercise of permissions under this License.
8. Limitation of Liability. In no event and under no legal theory,
whether in tort (including negligence), contract, or otherwise,
unless required by applicable law (such as deliberate and grossly
negligent acts) or agreed to in writing, shall any Contributor be
liable to You for damages, including any direct, indirect, special,
incidental, or consequential damages of any character arising as a
result of this License or out of the use or inability to use the
Work (including but not limited to damages for loss of goodwill,
work stoppage, computer failure or malfunction, or any and all
other commercial damages or losses), even if such Contributor
has been advised of the possibility of such damages.
9. Accepting Warranty or Additional Liability. While redistributing
the Work or Derivative Works thereof, You may choose to offer,
and charge a fee for, acceptance of support, warranty, indemnity,
or other liability obligations and/or rights consistent with this
License. However, in accepting such obligations, You may act only
on Your own behalf and on Your sole responsibility, not on behalf
of any other Contributor, and only if You agree to indemnify,
defend, and hold each Contributor harmless for any liability
incurred by, or claims asserted against, such Contributor by reason
of your accepting any such warranty or additional liability.
END OF TERMS AND CONDITIONS
APPENDIX: How to apply the Apache License to your work.
To apply the Apache License to your work, attach the following
boilerplate notice, with the fields enclosed by brackets "[]"
replaced with your own identifying information. (Don't include
the brackets!) The text should be enclosed in the appropriate
comment syntax for the file format. We also recommend that a
file or class name and description of purpose be included on the
same "printed page" as the copyright notice for easier
identification within third-party archives.
Copyright 2020-2021 Jose Iborra Lopez
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

44
shake-bench/shake-bench.cabal Normal file
View File

@ -0,0 +1,44 @@
cabal-version: 2.2
name: shake-bench
version: 0.1.0.0
synopsis: Build rules for historical benchmarking
license: Apache-2.0
license-file: LICENSE
author: Pepe Iborra
maintainer: pepeiborra@gmail.com
category: Development
build-type: Simple
description:
A library Shake rules to build and run benchmarks for multiple revisions of a project.
An example of usage can be found in the ghcide benchmark suite
library
exposed-modules: Development.Benchmark.Rules
hs-source-dirs: src
build-depends:
aeson,
base == 4.*,
Chart,
Chart-diagrams,
diagrams,
diagrams-svg,
directory,
extra >= 1.7.2,
filepath,
shake,
text
default-language: Haskell2010
default-extensions:
BangPatterns
DeriveFunctor
DeriveGeneric
FlexibleContexts
GeneralizedNewtypeDeriving
LambdaCase
NamedFieldPuns
RecordWildCards
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
ViewPatterns

568
shake-bench/src/Development/Benchmark/Rules.hs Normal file
View File

@ -0,0 +1,568 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{- |
This module provides a bunch of Shake rules to build multiple revisions of a
project and analyse their performance.
It assumes a project bench suite composed of examples that runs a fixed set
of experiments on every example
Your code must implement all of the GetFoo oracles and the IsExample class,
instantiate the Shake rules, and probably 'want' a set of targets.
The results of the benchmarks and the analysis are recorded in the file
system, using the following structure:
<build-folder>
├── binaries
│ └── <git-reference>
│  ├── ghc.path - path to ghc used to build the executable
│  └── <executable> - binary for this version
│  └── commitid - Git commit id for this reference
├─ <example>
│ ├── results.csv - aggregated results for all the versions
│ └── <git-reference>
│   ├── <experiment>.benchmark-gcStats - RTS -s output
│   ├── <experiment>.csv - stats for the experiment
│   ├── <experiment>.svg - Graph of bytes over elapsed time
│   ├── <experiment>.diff.svg - idem, including the previous version
│   ├── <experiment>.log - bench stdout
│   └── results.csv - results of all the experiments for the example
├── results.csv - aggregated results of all the experiments and versions
└── <experiment>.svg - graph of bytes over elapsed time, for all the included versions
For diff graphs, the "previous version" is the preceding entry in the list of versions
in the config file. A possible improvement is to obtain this info via `git rev-list`.
-}
module Development.Benchmark.Rules
(
buildRules, MkBuildRules(..),
benchRules, MkBenchRules(..), BenchProject(..),
csvRules,
svgRules,
allTargets,
GetExample(..), GetExamples(..),
IsExample(..), RuleResultForExample,
GetExperiments(..),
GetVersions(..),
GetCommitId(..),
GetBuildSystem(..),
BuildSystem(..), findGhcForBuildSystem,
Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment,
GitCommit
) where
import Control.Applicative
import Control.Monad
import Data.Aeson (FromJSON (..),
ToJSON (..),
Value (..), (.!=),
(.:?))
import Data.List (find, transpose)
import Data.List.Extra (lower)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Development.Shake
import Development.Shake.Classes (Binary, Hashable,
NFData, Typeable)
import GHC.Exts (IsList (toList),
fromList)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
import Graphics.Rendering.Chart.Easy ((.=))
import qualified Graphics.Rendering.Chart.Easy as E
import System.Directory (findExecutable, createDirectoryIfMissing)
import System.FilePath
import qualified Text.ParserCombinators.ReadP as P
import Text.Read (Read (..), get,
readMaybe,
readP_to_Prec)
newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetBuildSystem = GetBuildSystem () deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show)
newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
type instance RuleResult GetExperiments = [Unescaped String]
type instance RuleResult GetVersions = [GitCommit]
type instance RuleResult GetParent = Text
type instance RuleResult GetCommitId = String
type instance RuleResult GetBuildSystem = BuildSystem
type RuleResultForExample e =
( RuleResult GetExample ~ Maybe e
, RuleResult GetExamples ~ [e]
, IsExample e)
-- | Knowledge needed to run an example
class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where
getExampleName :: e -> String
--------------------------------------------------------------------------------
allTargets :: RuleResultForExample e => FilePath -> Action ()
allTargets buildFolder = do
experiments <- askOracle $ GetExperiments ()
examples <- askOracle $ GetExamples ()
versions <- askOracle $ GetVersions ()
need $
[buildFolder </> getExampleName e </> "results.csv" | e <- examples ] ++
[buildFolder </> "results.csv"]
++ [ buildFolder </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"
| e <- experiments
, ex <- examples
]
++ [ buildFolder </>
getExampleName ex </>
T.unpack (humanName ver) </>
escaped (escapeExperiment e) <.> mode <.> "svg"
| e <- experiments,
ex <- examples,
ver <- versions,
mode <- ["", "diff"]
]
--------------------------------------------------------------------------------
type OutputFolder = FilePath
data MkBuildRules buildSystem = MkBuildRules
{ -- | Return the path to the GHC executable to use for the project found in the cwd
findGhc :: buildSystem -> FilePath -> IO FilePath
-- | Name of the binary produced by 'buildProject'
, executableName :: String
-- | Build the project found in the cwd and save the build artifacts in the output folder
, buildProject :: buildSystem
-> [CmdOption]
-> OutputFolder
-> Action ()
}
-- | Rules that drive a build system to build various revisions of a project
buildRules :: FilePattern -> MkBuildRules BuildSystem -> Rules ()
-- TODO generalize BuildSystem
buildRules build MkBuildRules{..} = do
-- query git for the commitid for a version
build -/- "binaries/*/commitid" %> \out -> do
alwaysRerun
let [_,_,ver,_] = splitDirectories out
mbEntry <- find ((== T.pack ver) . humanName) <$> askOracle (GetVersions ())
let gitThing :: String
gitThing = maybe ver (T.unpack . gitName) mbEntry
Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]
writeFileChanged out $ init commitid
-- build rules for HEAD
priority 10 $ [ build -/- "binaries/HEAD/" <> executableName
, build -/- "binaries/HEAD/ghc.path"
]
&%> \[out, ghcpath] -> do
liftIO $ createDirectoryIfMissing True $ dropFileName out
-- TOOD more precise dependency tracking
need =<< getDirectoryFiles "." ["//*.hs", "*.cabal"]
buildSystem <- askOracle $ GetBuildSystem ()
buildProject buildSystem [Cwd "."] (takeDirectory out)
ghcLoc <- liftIO $ findGhc buildSystem "."
writeFile' ghcpath ghcLoc
-- build rules for non HEAD revisions
[build -/- "binaries/*/" <> executableName
,build -/- "binaries/*/ghc.path"
] &%> \[out, ghcPath] -> do
let [_, _binaries, _ver, _] = splitDirectories out
liftIO $ createDirectoryIfMissing True $ dropFileName out
commitid <- readFile' $ takeDirectory out </> "commitid"
cmd_ $ "git worktree add bench-temp " ++ commitid
buildSystem <- askOracle $ GetBuildSystem ()
flip actionFinally (cmd_ ("git worktree remove bench-temp --force" :: String)) $ do
ghcLoc <- liftIO $ findGhc buildSystem "bench-temp"
buildProject buildSystem [Cwd "bench-temp"] (".." </> takeDirectory out)
writeFile' ghcPath ghcLoc
--------------------------------------------------------------------------------
data MkBenchRules buildSystem example = MkBenchRules
{ benchProject :: buildSystem -> [CmdOption] -> BenchProject example -> Action ()
-- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules'
, executableName :: String
}
data BenchProject example = BenchProject
{ outcsv :: FilePath -- ^ where to save the CSV output
, exePath :: FilePath -- ^ where to find the executable for benchmarking
, exeExtraArgs :: [String] -- ^ extra args for the executable
, example :: example -- ^ example to benchmark
, experiment :: Escaped String -- ^ experiment to run
}
-- TODO generalize BuildSystem
benchRules :: RuleResultForExample example => FilePattern -> Resource -> MkBenchRules BuildSystem example -> Rules ()
benchRules build benchResource MkBenchRules{..} = do
-- run an experiment
priority 0 $
[ build -/- "*/*/*.csv",
build -/- "*/*/*.benchmark-gcStats",
build -/- "*/*/*.log"
]
&%> \[outcsv, outGc, outLog] -> do
let [_, exampleName, ver, exp] = splitDirectories outcsv
example <- fromMaybe (error $ "Unknown example " <> exampleName)
<$> askOracle (GetExample exampleName)
buildSystem <- askOracle $ GetBuildSystem ()
liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
let exePath = build </> "binaries" </> ver </> executableName
exeExtraArgs = ["+RTS", "-I0.5", "-S" <> takeFileName outGc, "-RTS"]
ghcPath = build </> "binaries" </> ver </> "ghc.path"
experiment = Escaped $ dropExtension exp
need [exePath, ghcPath]
ghcPath <- readFile' ghcPath
withResource benchResource 1 $ do
benchProject buildSystem
[ EchoStdout False,
FileStdout outLog,
RemEnv "NIX_GHC_LIBDIR",
RemEnv "GHC_PACKAGE_PATH",
AddPath [takeDirectory ghcPath, "."] []
]
BenchProject{..}
cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv
--------------------------------------------------------------------------------
-- | Rules to aggregate the CSV output of individual experiments
csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules ()
csvRules build = do
-- build results for every experiment*example
build -/- "*/*/results.csv" %> \out -> do
experiments <- askOracle $ GetExperiments ()
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
allResults <- traverse readFileLines allResultFiles
let header = head $ head allResults
results = map tail allResults
writeFileChanged out $ unlines $ header : concat results
-- aggregate all experiments for an example
build -/- "*/results.csv" %> \out -> do
versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ())
let example = takeFileName $ takeDirectory out
allResultFiles =
[build </> example </> v </> "results.csv" | v <- versions]
allResults <- traverse readFileLines allResultFiles
let header = head $ head allResults
results = map tail allResults
header' = "version, " <> header
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results
writeFileChanged out $ unlines $ header' : interleave results'
-- aggregate all examples
build -/- "results.csv" %> \out -> do
examples <- map (getExampleName @example) <$> askOracle (GetExamples ())
let allResultFiles = [build </> e </> "results.csv" | e <- examples]
allResults <- traverse readFileLines allResultFiles
let header = head $ head allResults
results = map tail allResults
header' = "example, " <> header
results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results
writeFileChanged out $ unlines $ header' : concat results'
--------------------------------------------------------------------------------
-- | Rules to produce charts for the GC stats
svgRules :: FilePattern -> Rules ()
svgRules build = do
_ <- addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ())
-- chart GC stats for an experiment on a given revision
priority 1 $
build -/- "*/*/*.svg" %> \out -> do
let [b, example, ver, exp] = splitDirectories out
runLog <- loadRunLog b example (Escaped $ dropExtension exp) ver
let diagram = Diagram Live [runLog] title
title = ver <> " live bytes over time"
plotDiagram True diagram out
-- chart of GC stats for an experiment on this and the previous revision
priority 2 $
build -/- "*/*/*.diff.svg" %> \out -> do
let [b, example, ver, exp_] = splitDirectories out
exp = Escaped $ dropExtension $ dropExtension exp_
prev <- askOracle $ GetParent $ T.pack ver
runLog <- loadRunLog b example exp ver
runLogPrev <- loadRunLog b example exp $ T.unpack prev
let diagram = Diagram Live [runLog, runLogPrev] title
title = show (unescapeExperiment exp) <> " - live bytes over time compared"
plotDiagram True diagram out
-- aggregated chart of GC stats for all the revisions
build -/- "*/*.svg" %> \out -> do
let exp = Escaped $ dropExtension $ takeFileName out
example = takeFileName $ takeDirectory out
versions <- askOracle $ GetVersions ()
runLogs <- forM (filter include versions) $ \v -> do
loadRunLog build example exp $ T.unpack $ humanName v
let diagram = Diagram Live runLogs title
title = show (unescapeExperiment exp) <> " - live bytes over time"
plotDiagram False diagram out
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- | Default build system that handles Cabal and Stack
data BuildSystem = Cabal | Stack
deriving (Eq, Read, Show, Generic)
deriving (Binary, Hashable, NFData)
findGhcForBuildSystem :: BuildSystem -> FilePath -> IO FilePath
findGhcForBuildSystem Cabal _cwd =
liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"
findGhcForBuildSystem Stack cwd = do
Stdout ghcLoc <- cmd [Cwd cwd] ("stack exec which ghc" :: String)
return ghcLoc
instance FromJSON BuildSystem where
parseJSON x = fromString . lower <$> parseJSON x
where
fromString "stack" = Stack
fromString "cabal" = Cabal
fromString other = error $ "Unknown build system: " <> other
instance ToJSON BuildSystem where
toJSON = toJSON . show
--------------------------------------------------------------------------------
data GitCommit = GitCommit
{ -- | A git hash, tag or branch name (e.g. v0.1.0)
gitName :: Text,
-- | A human understandable name (e.g. fix-collisions-leak)
name :: Maybe Text,
-- | The human understandable name of the parent, if specified explicitly
parent :: Maybe Text,
-- | Whether to include this version in the top chart
include :: Bool
}
deriving (Binary, Eq, Hashable, Generic, NFData, Show)
instance FromJSON GitCommit where
parseJSON (String s) = pure $ GitCommit s Nothing Nothing True
parseJSON (Object (toList -> [(name, String gitName)])) =
pure $ GitCommit gitName (Just name) Nothing True
parseJSON (Object (toList -> [(name, Object props)])) =
GitCommit
<$> props .:? "git" .!= name
<*> pure (Just name)
<*> props .:? "parent"
<*> props .:? "include" .!= True
parseJSON _ = empty
instance ToJSON GitCommit where
toJSON GitCommit {..} =
case name of
Nothing -> String gitName
Just n -> Object $ fromList [(n, String gitName)]
humanName :: GitCommit -> Text
humanName GitCommit {..} = fromMaybe gitName name
findPrev :: Text -> [GitCommit] -> Text
findPrev name (x : y : xx)
| humanName y == name = humanName x
| otherwise = findPrev name (y : xx)
findPrev name _ = name
--------------------------------------------------------------------------------
-- | A line in the output of -S
data Frame = Frame
{ allocated, copied, live :: !Int,
user, elapsed, totUser, totElapsed :: !Double,
generation :: !Int
}
deriving (Show)
instance Read Frame where
readPrec = do
spaces
allocated <- readPrec @Int <* spaces
copied <- readPrec @Int <* spaces
live <- readPrec @Int <* spaces
user <- readPrec @Double <* spaces
elapsed <- readPrec @Double <* spaces
totUser <- readPrec @Double <* spaces
totElapsed <- readPrec @Double <* spaces
_ <- readPrec @Int <* spaces
_ <- readPrec @Int <* spaces
"(Gen: " <- replicateM 7 get
generation <- readPrec @Int
')' <- get
return Frame {..}
where
spaces = readP_to_Prec $ const P.skipSpaces
-- | A file path containing the output of -S for a given run
data RunLog = RunLog
{ runVersion :: !String,
_runExample :: !String,
_runExperiment :: !String,
runFrames :: ![Frame],
runSuccess :: !Bool
}
loadRunLog :: HasCallStack => FilePath -> String -> Escaped FilePath -> FilePath -> Action RunLog
loadRunLog buildF example exp ver = do
let log_fp = buildF </> example </> ver </> escaped exp <.> "benchmark-gcStats"
csv_fp = replaceExtension log_fp "csv"
log <- readFileLines log_fp
csv <- readFileLines csv_fp
let frames =
[ f
| l <- log,
Just f <- [readMaybe l],
-- filter out gen 0 events as there are too many
generation f == 1
]
-- TODO this assumes a certain structure in the CSV file
success = case map (T.split (== ',') . T.pack) csv of
[_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s
_ -> error $ "Cannot parse: " <> csv_fp
return $ RunLog ver example (dropExtension $ escaped exp) frames success
--------------------------------------------------------------------------------
data TraceMetric = Allocated | Copied | Live | User | Elapsed
deriving (Generic, Enum, Bounded, Read)
instance Show TraceMetric where
show Allocated = "Allocated bytes"
show Copied = "Copied bytes"
show Live = "Live bytes"
show User = "User time"
show Elapsed = "Elapsed time"
frameMetric :: TraceMetric -> Frame -> Double
frameMetric Allocated = fromIntegral . allocated
frameMetric Copied = fromIntegral . copied
frameMetric Live = fromIntegral . live
frameMetric Elapsed = elapsed
frameMetric User = user
data Diagram = Diagram
{ traceMetric :: TraceMetric,
runLogs :: [RunLog],
title :: String
}
deriving (Generic)
plotDiagram :: Bool -> Diagram -> FilePath -> Action ()
plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do
let extract = frameMetric traceMetric
liftIO $ E.toFile E.def out $ do
E.layout_title .= title t
E.setColors myColors
forM_ runLogs $ \rl ->
when (includeFailed || runSuccess rl) $ E.plot $ do
lplot <- E.line
(runVersion rl ++ if runSuccess rl then "" else " (FAILED)")
[ [ (totElapsed f, extract f)
| f <- runFrames rl
]
]
return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2)
--------------------------------------------------------------------------------
newtype Escaped a = Escaped {escaped :: a}
newtype Unescaped a = Unescaped {unescaped :: a}
deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable)
escapeExperiment :: Unescaped String -> Escaped String
escapeExperiment = Escaped . map f . unescaped
where
f ' ' = '_'
f other = other
unescapeExperiment :: Escaped String -> Unescaped String
unescapeExperiment = Unescaped . map f . escaped
where
f '_' = ' '
f other = other
--------------------------------------------------------------------------------
(-/-) :: FilePattern -> FilePattern -> FilePattern
a -/- b = a <> "/" <> b
interleave :: [[a]] -> [a]
interleave = concat . transpose
--------------------------------------------------------------------------------
myColors :: [E.AlphaColour Double]
myColors = map E.opaque
[ E.blue
, E.green
, E.red
, E.orange
, E.yellow
, E.violet
, E.black
, E.gold
, E.brown
, E.hotpink
, E.aliceblue
, E.aqua
, E.beige
, E.bisque
, E.blueviolet
, E.burlywood
, E.cadetblue
, E.chartreuse
, E.coral
, E.crimson
, E.darkblue
, E.darkgray
, E.darkgreen
, E.darkkhaki
, E.darkmagenta
, E.deeppink
, E.dodgerblue
, E.firebrick
, E.forestgreen
, E.fuchsia
, E.greenyellow
, E.lightsalmon
, E.seagreen
, E.olive
, E.sandybrown
, E.sienna
, E.peru
]