mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Run benchmarks on a list of examples (#864)
- Cabal 3.0.0.0 - haskell-lsp-types 0.22.0.0
This commit is contained in:
parent
f26c4abb69
commit
7339784509
@ -13,11 +13,17 @@ outputFolder: bench-results
|
||||
# Example project used to run the experiments
|
||||
# Can either be a Hackage package (name,version)
|
||||
# or a local project (path) with a valid `hie.yaml` file
|
||||
example:
|
||||
name: Cabal
|
||||
examples:
|
||||
# Medium-sized project without TH
|
||||
- name: Cabal
|
||||
version: 3.0.0.0
|
||||
# path: path/to/example
|
||||
module: Distribution/Simple.hs
|
||||
# Small-sized project with TH
|
||||
- name: haskell-lsp-types
|
||||
version: 0.22.0.0
|
||||
module: src/Language/Haskell/LSP/Types/Lens.hs
|
||||
# - path: path-to-example
|
||||
# module: path-to-module
|
||||
|
||||
# The set of experiments to execute
|
||||
experiments:
|
||||
|
@ -10,17 +10,20 @@
|
||||
system with the following structure:
|
||||
|
||||
bench-results
|
||||
├── <git-reference> - one folder per version
|
||||
│ ├── <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 - ghcide-bench output
|
||||
│ ├── ghc.path - path to ghc used to build the binary
|
||||
│ ├── ghcide - binary for this version
|
||||
│ └── results.csv - results of all the experiments for the version
|
||||
├── <git-reference>
|
||||
│ ├── ghc.path - path to ghc used to build the binary
|
||||
│ ├── ghcide - binary for this version
|
||||
├─ <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 - ghcide-bench output
|
||||
│ └── 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
|
||||
└── <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`.
|
||||
@ -35,6 +38,7 @@
|
||||
> cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"
|
||||
|
||||
-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies#-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
@ -49,7 +53,7 @@ import qualified Data.Text as T
|
||||
import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow)
|
||||
import Development.Shake
|
||||
import Development.Shake.Classes (Binary, Hashable, NFData)
|
||||
import Experiments.Types (exampleToOptions, Example(..))
|
||||
import Experiments.Types (getExampleName, exampleToOptions, Example(..))
|
||||
import GHC.Exts (IsList (..))
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
|
||||
@ -60,6 +64,7 @@ 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)
|
||||
|
||||
config :: FilePath
|
||||
config = "bench/config.yaml"
|
||||
@ -68,24 +73,20 @@ config = "bench/config.yaml"
|
||||
readConfigIO :: FilePath -> IO Config
|
||||
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)
|
||||
|
||||
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 ()
|
||||
@ -97,12 +98,16 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
|
||||
_ <- 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)
|
||||
@ -112,16 +117,16 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
|
||||
phony "all" $ do
|
||||
Config {..} <- readConfig config
|
||||
|
||||
forM_ versions $ \ver ->
|
||||
need [build </> T.unpack (humanName ver) </> "results.csv"]
|
||||
|
||||
need $
|
||||
[build </> getExampleName e </> "results.csv" | e <- examples ] ++
|
||||
[build </> "results.csv"]
|
||||
++ [ build </> escaped (escapeExperiment e) <.> "svg"
|
||||
++ [ build </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"
|
||||
| e <- experiments
|
||||
, ex <- examples
|
||||
]
|
||||
++ [ build </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"
|
||||
++ [ build </> getExampleName ex </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"
|
||||
| e <- experiments,
|
||||
ex <- examples,
|
||||
ver <- versions,
|
||||
mode <- ["", "diff"]
|
||||
]
|
||||
@ -136,7 +141,7 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
|
||||
Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]
|
||||
writeFileChanged out $ init commitid
|
||||
|
||||
priority 10 $ [build -/- "HEAD/ghcide"
|
||||
priority 10 $ [ build -/- "HEAD/ghcide"
|
||||
, build -/- "HEAD/ghc.path"
|
||||
]
|
||||
&%> \[out, ghcpath] -> do
|
||||
@ -159,8 +164,7 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
|
||||
cmd_ [Cwd "bench-temp"] $ buildGhcide buildSystem (".." </> takeDirectory out)
|
||||
writeFile' ghcpath ghcLoc
|
||||
|
||||
priority 8000 $
|
||||
build -/- "*/results.csv" %> \out -> do
|
||||
build -/- "*/*/results.csv" %> \out -> do
|
||||
experiments <- readExperiments
|
||||
|
||||
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
|
||||
@ -173,16 +177,17 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
|
||||
ghcideBenchResource <- newResource "ghcide-bench" 1
|
||||
|
||||
priority 0 $
|
||||
[ build -/- "*/*.csv",
|
||||
build -/- "*/*.benchmark-gcStats",
|
||||
build -/- "*/*.log"
|
||||
[ build -/- "*/*/*.csv",
|
||||
build -/- "*/*/*.benchmark-gcStats",
|
||||
build -/- "*/*/*.log"
|
||||
]
|
||||
&%> \[outcsv, _outGc, outLog] -> do
|
||||
let [_, _, exp] = splitDirectories outcsv
|
||||
let [_, exampleName, ver, exp] = splitDirectories outcsv
|
||||
example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> getExample exampleName
|
||||
samples <- readSamples
|
||||
liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
|
||||
let ghcide = dropFileName outcsv </> "ghcide"
|
||||
ghcpath = dropFileName outcsv </> "ghc.path"
|
||||
let ghcide = build </> ver </> "ghcide"
|
||||
ghcpath = build </> ver </> "ghc.path"
|
||||
need [ghcide, ghcpath]
|
||||
ghcPath <- readFile' ghcpath
|
||||
withResource ghcideBenchResource 1 $ do
|
||||
@ -203,53 +208,66 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
|
||||
"--select",
|
||||
unescaped (unescapeExperiment (Escaped $ dropExtension exp))
|
||||
] ++
|
||||
exampleToOptions (example configStatic) ++
|
||||
exampleToOptions example ++
|
||||
[ "--stack" | Stack == buildSystem]
|
||||
cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv
|
||||
|
||||
build -/- "results.csv" %> \out -> do
|
||||
versions <- readVersions
|
||||
let allResultFiles =
|
||||
[build </> T.unpack (humanName v) </> "results.csv" | v <- versions]
|
||||
examples <- map getExampleName <$> readExamples
|
||||
let allResultFiles = [build </> e </> "results.csv" | e <- examples]
|
||||
|
||||
need [build </> T.unpack (humanName v) </> "ghcide" | v <- versions]
|
||||
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 -> T.unpack (humanName v) <> ", " <> l)) versions results
|
||||
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results
|
||||
|
||||
writeFileChanged out $ unlines $ header' : concat results'
|
||||
|
||||
priority 2 $
|
||||
build -/- "*/*.diff.svg" %> \out -> do
|
||||
let [b, ver, exp_] = splitDirectories out
|
||||
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 exp ver
|
||||
runLogPrev <- loadRunLog b exp $ T.unpack prev
|
||||
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, ver, exp] = splitDirectories out
|
||||
runLog <- loadRunLog b (Escaped $ dropExtension exp) ver
|
||||
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
|
||||
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 exp $ T.unpack $ humanName v
|
||||
loadRunLog build example exp $ T.unpack $ humanName v
|
||||
|
||||
let diagram = Diagram Live runLogs title
|
||||
title = show (unescapeExperiment exp) <> " - live bytes over time"
|
||||
@ -282,7 +300,7 @@ findGhc Stack = do
|
||||
|
||||
data Config = Config
|
||||
{ experiments :: [Unescaped String],
|
||||
example :: Example,
|
||||
examples :: [Example],
|
||||
samples :: Natural,
|
||||
versions :: [GitCommit],
|
||||
-- | Path to the ghcide-bench binary for the experiments
|
||||
@ -401,14 +419,15 @@ data Diagram = Diagram
|
||||
-- | 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 :: FilePath -> Escaped FilePath -> FilePath -> Action RunLog
|
||||
loadRunLog buildF exp ver = do
|
||||
let log_fp = buildF </> ver </> escaped exp <.> "benchmark-gcStats"
|
||||
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
|
||||
@ -422,7 +441,7 @@ loadRunLog buildF exp ver = do
|
||||
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 (dropExtension $ escaped exp) frames success
|
||||
return $ RunLog ver example (dropExtension $ escaped exp) frames success
|
||||
|
||||
plotDiagram :: Bool -> Diagram -> FilePath -> Action ()
|
||||
plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do
|
||||
|
@ -5,6 +5,9 @@ module Experiments.Types where
|
||||
import Data.Aeson
|
||||
import Data.Version
|
||||
import Numeric.Natural
|
||||
import System.FilePath (isPathSeparator)
|
||||
import Development.Shake.Classes
|
||||
import GHC.Generics
|
||||
|
||||
data CabalStack = Cabal | Stack
|
||||
deriving (Eq, Show)
|
||||
@ -29,7 +32,17 @@ data Config = Config
|
||||
data Example
|
||||
= GetPackage {exampleName, exampleModule :: String, exampleVersion :: Version}
|
||||
| UsePackage {examplePath :: FilePath, exampleModule :: String}
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Generic, Show)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
getExampleName :: Example -> String
|
||||
getExampleName UsePackage{examplePath} = map replaceSeparator examplePath
|
||||
where
|
||||
replaceSeparator x
|
||||
| isPathSeparator x = '_'
|
||||
| otherwise = x
|
||||
getExampleName GetPackage{exampleName, exampleVersion} =
|
||||
exampleName <> "-" <> showVersion exampleVersion
|
||||
|
||||
instance FromJSON Example where
|
||||
parseJSON = withObject "example" $ \x -> do
|
||||
|
@ -399,6 +399,7 @@ executable ghcide-bench
|
||||
optparse-applicative,
|
||||
process,
|
||||
safe-exceptions,
|
||||
shake,
|
||||
text
|
||||
hs-source-dirs: bench/lib bench/exe
|
||||
include-dirs: include
|
||||
|
Loading…
Reference in New Issue
Block a user