mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-19 04:37:25 +03:00
d0e3e0fe3f
* extract ghcide:experiments-types * extract haskell-language-server:plugins and let go of examples The main goal here is to move the Plugins module into an internal library so that it can be reused from the benchmark suite. In order to make that easier, and since they hardly serve a purpose in a repository with 25 plugins, I delete the Example and Example2 plugin descriptors and their dependencies. * HLS benchmark suite Port the ghcide benchmark suite to HLS and benchmark plugin "configurations" independently. This includes the following changes to the ghcide benchmark suite and HLS: - Support for "configurations" which are defined as sets of plugin ids. The benchmark will be run with only these plugins enabled and all others disabled - Support for configurable concurrency. This relies on RTS -ol and -po flags to place the RTS traces in the target location rather than in the cwd This change requires two commits, the next one places ghcide/bench/hist/Main.hs into its final location to help 'git' recognize the change as a file move * ghcide/bench/hist/Main.hs -> bench/Main.hs * CI - fix artifact names for uniqueness * disable shorten HLS step * Do not store eventlogs to avoid out of disk space * render durations up to milliseconds * shorten titles Goal is to display the formatted CSV (via column) one row per line * exclude formatting plugin configurations * Extract ghcide-bench to a standalone package * ghcide-bench: fix stderr capturing * Fix mem stats We parse maxResidency and allocatedBytes from the RTS -S output, but runSessionWithHandles kills the server without waiting for it to exit and these stats don't get logged. The solution is to use runSessionWithHandles', but unfortunately it is internal and not exposed. I have raised a PR to expose it and in the meantime we need a source repo package. * feedbacks * delete Example plugins
283 lines
12 KiB
Haskell
283 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 TypeFamilies #-}
|
|
{-# OPTIONS -Wno-orphans #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
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 (pack, 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
|
|
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))
|
|
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
|
|
[ (p, def { Plugin.plcGlobalOn = globalOn})
|
|
| PluginDescriptor{pluginId = plugin@(PluginId p)} <- plugins
|
|
, let globalOn =
|
|
-- ghcide-core is required, nothing works without it
|
|
plugin == PluginId (pack "ghcide-core")
|
|
-- document symbols is required by the benchmark suite
|
|
|| plugin == PluginId (pack "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"
|
|
,"package ghcide"
|
|
," flags: +ekg"
|
|
]
|
|
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"
|