mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
* add performance diff `resultDiff.csv` showing the performance different between two version * add resultDiff CI --------- Co-authored-by: Michael Peyton Jones <me@michaelpj.com> Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com>
282 lines
12 KiB
Haskell
282 lines
12 KiB
Haskell
|
|
{- Bench history
|
|
|
|
A Shake script to analyze the performance of HLS over the git history of the project
|
|
|
|
Driven by a config file `bench/config.yaml` containing the list of Git references to analyze.
|
|
|
|
Builds each one of them and executes a set of experiments using the ghcide-bench suite.
|
|
|
|
The results of the benchmarks and the analysis are recorded in the file
|
|
system with the following structure:
|
|
|
|
bench-results
|
|
├── <git-reference>
|
|
│ ├── ghc.path - path to ghc used to build the binary
|
|
│ └── haskell-language-server - binary for this version
|
|
├─ <example>
|
|
│ ├── results.csv - aggregated results for all the versions
|
|
│ └── <git-reference>
|
|
| └── <HLS plugin>
|
|
│ ├── <experiment>.gcStats.log - 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
|
|
|
|
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`.
|
|
|
|
To execute the script:
|
|
|
|
> cabal/stack bench
|
|
|
|
To build a specific analysis, enumerate the desired file artifacts
|
|
|
|
> stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"
|
|
> cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"
|
|
|
|
-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# OPTIONS -Wno-orphans #-}
|
|
|
|
import Control.Lens (preview, (^.))
|
|
import Control.Monad.Extra
|
|
import Data.Aeson (Value (..), encode)
|
|
import Data.Aeson.Lens
|
|
import Data.Default
|
|
import Data.Foldable (find)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe
|
|
import Data.Text (unpack)
|
|
import Data.Yaml (FromJSON (..), ToJSON (toJSON),
|
|
decodeFileThrow)
|
|
import Development.Benchmark.Rules hiding (parallelism)
|
|
import Development.Shake (Action,
|
|
Change (ChangeModtimeAndDigestInput),
|
|
CmdOption (Cwd, StdinBS),
|
|
RuleResult, Rules,
|
|
ShakeOptions (shakeChange, shakeThreads),
|
|
actionBracket, addOracle,
|
|
askOracle, command, command_,
|
|
getDirectoryFiles, liftIO, need,
|
|
newCache, shakeArgsWith,
|
|
shakeOptions, versioned, want)
|
|
import Development.Shake.Classes
|
|
import Experiments.Types (Example (exampleName),
|
|
exampleToOptions)
|
|
import GHC.Exts (toList)
|
|
import GHC.Generics (Generic)
|
|
import HlsPlugins (idePlugins)
|
|
import qualified Ide.Plugin.Config as Plugin
|
|
import Ide.Types hiding (Config)
|
|
import Numeric.Natural (Natural)
|
|
import System.Console.GetOpt
|
|
import System.Directory
|
|
import System.FilePath
|
|
import System.IO.Error (tryIOError)
|
|
|
|
configPath :: FilePath
|
|
configPath = "bench/config.yaml"
|
|
|
|
configOpt :: OptDescr (Either String FilePath)
|
|
configOpt = Option [] ["config"] (ReqArg Right configPath) "config file"
|
|
|
|
binaryName :: String
|
|
binaryName = "haskell-language-server"
|
|
|
|
-- | Read the config without dependency
|
|
readConfigIO :: FilePath -> IO (Config BuildSystem)
|
|
readConfigIO = decodeFileThrow
|
|
|
|
instance IsExample Example where getExampleName = exampleName
|
|
type instance RuleResult GetExample = Maybe Example
|
|
type instance RuleResult GetExamples = [Example]
|
|
|
|
shakeOpts :: ShakeOptions
|
|
shakeOpts =
|
|
shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0}
|
|
|
|
main :: IO ()
|
|
main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do
|
|
let config = fromMaybe configPath $ listToMaybe configs
|
|
_configStatic <- createBuildSystem config
|
|
case wants of
|
|
[] -> want ["all"]
|
|
_ -> want wants
|
|
|
|
hlsBuildRules :: MkBuildRules BuildSystem
|
|
hlsBuildRules = MkBuildRules findGhcForBuildSystem binaryName projectDepends buildHls
|
|
where
|
|
recordDepends path =
|
|
need . map (path </>) =<< getDirectoryFiles path ["//*.hs"]
|
|
projectDepends = do
|
|
recordDepends "src"
|
|
recordDepends "exe"
|
|
recordDepends "plugins"
|
|
recordDepends "ghcide/session-loader"
|
|
recordDepends "ghcide/src"
|
|
recordDepends "hls-graph/src"
|
|
recordDepends "hls-plugin-api/src"
|
|
need =<< getDirectoryFiles "." ["*.cabal"]
|
|
|
|
--------------------------------------------------------------------------------
|
|
data Config buildSystem = Config
|
|
{ experiments :: [Unescaped String],
|
|
configurations :: [ConfigurationDescriptor],
|
|
examples :: [Example],
|
|
samples :: Natural,
|
|
versions :: [GitCommit],
|
|
-- | Output folder ('foo' works, 'foo/bar' does not)
|
|
outputFolder :: String,
|
|
buildTool :: buildSystem,
|
|
profileInterval :: Maybe Double,
|
|
parallelism :: Natural
|
|
}
|
|
deriving (Generic, Show)
|
|
deriving anyclass (FromJSON)
|
|
|
|
createBuildSystem :: FilePath -> Rules (Config BuildSystem)
|
|
createBuildSystem config = do
|
|
readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)
|
|
|
|
_ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config
|
|
_ <- addOracle $ \GetVersions {} -> versions <$> readConfig config
|
|
_ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config
|
|
_ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config
|
|
_ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config
|
|
_ <- addOracle $ \GetSamples{} -> samples <$> readConfig config
|
|
_ <- addOracle $ \GetConfigurations{} -> do
|
|
Config{configurations} <- readConfig config
|
|
return [ Configuration confName (encode $ disableAllPluginsBut (`elem` confPlugins))
|
|
| ConfigurationDescriptor{..} <- configurations
|
|
]
|
|
|
|
configStatic <- liftIO $ readConfigIO config
|
|
let build = outputFolder configStatic
|
|
|
|
buildRules build hlsBuildRules
|
|
benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchHls warmupHls "haskell-language-server" (parallelism configStatic))
|
|
addGetParentOracle
|
|
csvRules build
|
|
svgRules build
|
|
heapProfileRules build
|
|
phonyRules "" binaryName NoProfiling build (examples configStatic)
|
|
|
|
whenJust (profileInterval configStatic) $ \i -> do
|
|
phonyRules "profiled-" binaryName (CheapHeapProfiling i) build (examples configStatic)
|
|
|
|
return configStatic
|
|
|
|
disableAllPluginsBut :: (PluginId -> Bool) -> Plugin.Config
|
|
disableAllPluginsBut pred = def {Plugin.plugins = pluginsMap} where
|
|
pluginsMap = Map.fromList
|
|
[ (plugin, def { Plugin.plcGlobalOn = globalOn})
|
|
| PluginDescriptor{pluginId = plugin} <- plugins
|
|
, let globalOn =
|
|
-- ghcide-core is required, nothing works without it
|
|
plugin == "ghcide-core"
|
|
-- document symbols is required by the benchmark suite
|
|
|| plugin == "ghcide-hover-and-symbols"
|
|
|| pred plugin
|
|
]
|
|
IdePlugins plugins = idePlugins mempty
|
|
|
|
newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
|
type instance RuleResult GetSamples = Natural
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
buildHls :: BuildSystem -> ProjectRoot -> OutputFolder -> Action ()
|
|
buildHls Cabal root out = actionBracket
|
|
(do
|
|
projectLocalExists <- liftIO $ doesFileExist projectLocal
|
|
when projectLocalExists $ liftIO $ do
|
|
void $ tryIOError $ removeFile (projectLocal <.> "restore-after-benchmark")
|
|
renameFile projectLocal (projectLocal <.> "restore-after-benchmark")
|
|
liftIO $ writeFile projectLocal $ unlines
|
|
["package haskell-language-server"
|
|
," ghc-options: -eventlog -rtsopts"
|
|
]
|
|
return projectLocalExists)
|
|
(\projectLocalExists -> do
|
|
removeFile projectLocal
|
|
when projectLocalExists $
|
|
renameFile (projectLocal <.> "restore-after-benchmark") projectLocal
|
|
) $ \_ -> command_ [Cwd root] "cabal"
|
|
["install"
|
|
,"haskell-language-server:exe:haskell-language-server"
|
|
,"--installdir=" ++ out
|
|
,"--install-method=copy"
|
|
,"--overwrite-policy=always"
|
|
]
|
|
where
|
|
projectLocal = root </> "cabal.project.local"
|
|
|
|
buildHls Stack root out =
|
|
command_ [Cwd root] "stack"
|
|
["--local-bin-path=" <> out
|
|
,"build"
|
|
,"haskell-language-server:haskell-language-server"
|
|
,"--copy-bins"
|
|
,"--ghc-options=-rtsopts"
|
|
,"--ghc-options=-eventlog"
|
|
]
|
|
|
|
benchHls
|
|
:: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()
|
|
benchHls samples buildSystem args BenchProject{..} = do
|
|
command_ ([StdinBS configuration] ++ args) "ghcide-bench" $
|
|
[ "--timeout=300",
|
|
"--no-clean",
|
|
"-v",
|
|
"--samples=" <> show samples,
|
|
"--csv=" <> outcsv,
|
|
"--ghcide=" <> exePath,
|
|
"--select",
|
|
unescaped (unescapeExperiment experiment),
|
|
"--lsp-config"
|
|
] ++
|
|
exampleToOptions example exeExtraArgs ++
|
|
[ "--stack" | Stack == buildSystem
|
|
]
|
|
|
|
warmupHls :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action ()
|
|
warmupHls buildSystem exePath args example = do
|
|
command args "ghcide-bench" $
|
|
[ "--no-clean",
|
|
"-v",
|
|
"--samples=1",
|
|
"--ghcide=" <> exePath,
|
|
"--select=hover"
|
|
] ++
|
|
exampleToOptions example [] ++
|
|
[ "--stack" | Stack == buildSystem
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
data ConfigurationDescriptor = ConfigurationDescriptor
|
|
{ confName :: String
|
|
, confPlugins :: [PluginId]
|
|
}
|
|
deriving Show
|
|
|
|
instance FromJSON ConfigurationDescriptor where
|
|
parseJSON (String s) = pure $ ConfigurationDescriptor (unpack s) [PluginId s]
|
|
parseJSON o@Object{} = do
|
|
let keymap = o ^. _Object
|
|
matchKey = preview _String . toJSON
|
|
case toList keymap of
|
|
-- excuse the aeson 2.0 compatibility hack
|
|
[(matchKey -> Just name, Array values)] -> do
|
|
pluginIds <- traverse parseJSON values
|
|
pure $ ConfigurationDescriptor (unpack name) (map PluginId $ toList pluginIds)
|
|
other -> fail $ "Expected object with name and array of plugin ids: " <> show other
|
|
parseJSON _ = fail "Expected plugin id or object with name and array of plugin ids"
|