|
| 1 | + |
| 2 | +{- Bench history |
| 3 | +
|
| 4 | + A Shake script to analyze the performance of HLS over the git history of the project |
| 5 | +
|
| 6 | + Driven by a config file `bench/config.yaml` containing the list of Git references to analyze. |
| 7 | +
|
| 8 | + Builds each one of them and executes a set of experiments using the ghcide-bench suite. |
| 9 | +
|
| 10 | + The results of the benchmarks and the analysis are recorded in the file |
| 11 | + system with the following structure: |
| 12 | +
|
| 13 | + bench-results |
| 14 | + ├── <git-reference> |
| 15 | + │ ├── ghc.path - path to ghc used to build the binary |
| 16 | + │ └── haskell-language-server - binary for this version |
| 17 | + ├─ <example> |
| 18 | + │ ├── results.csv - aggregated results for all the versions |
| 19 | + │ └── <git-reference> |
| 20 | + | └── <HLS plugin> |
| 21 | + │ ├── <experiment>.gcStats.log - RTS -s output |
| 22 | + │ ├── <experiment>.csv - stats for the experiment |
| 23 | + │ ├── <experiment>.svg - Graph of bytes over elapsed time |
| 24 | + │ ├── <experiment>.diff.svg - idem, including the previous version |
| 25 | + │ ├── <experiment>.log - ghcide-bench output |
| 26 | + │ └── results.csv - results of all the experiments for the example |
| 27 | + ├── results.csv - aggregated results of all the experiments and versions |
| 28 | + └── <experiment>.svg - graph of bytes over elapsed time, for all the included versions |
| 29 | +
|
| 30 | + For diff graphs, the "previous version" is the preceding entry in the list of versions |
| 31 | + in the config file. A possible improvement is to obtain this info via `git rev-list`. |
| 32 | +
|
| 33 | + To execute the script: |
| 34 | +
|
| 35 | + > cabal/stack bench |
| 36 | +
|
| 37 | + To build a specific analysis, enumerate the desired file artifacts |
| 38 | +
|
| 39 | + > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" |
| 40 | + > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg" |
| 41 | +
|
| 42 | + -} |
| 43 | +{-# LANGUAGE DeriveAnyClass #-} |
| 44 | +{-# LANGUAGE DerivingStrategies #-} |
| 45 | +{-# LANGUAGE TypeFamilies #-} |
| 46 | +{-# OPTIONS -Wno-orphans #-} |
| 47 | +{-# LANGUAGE PackageImports #-} |
| 48 | + |
| 49 | +import Control.Lens (preview, (^.)) |
| 50 | +import Control.Monad.Extra |
| 51 | +import Data.Aeson (Value (..), encode) |
| 52 | +import Data.Aeson.Lens |
| 53 | +import Data.Default |
| 54 | +import Data.Foldable (find) |
| 55 | +import qualified Data.Map.Strict as Map |
| 56 | +import Data.Maybe |
| 57 | +import Data.Text (pack, unpack) |
| 58 | +import Data.Yaml (FromJSON (..), ToJSON (toJSON), |
| 59 | + decodeFileThrow) |
| 60 | +import Development.Benchmark.Rules hiding (parallelism) |
| 61 | +import Development.Shake (Action, |
| 62 | + Change (ChangeModtimeAndDigestInput), |
| 63 | + CmdOption (Cwd, StdinBS), |
| 64 | + RuleResult, Rules, |
| 65 | + ShakeOptions (shakeChange, shakeThreads), |
| 66 | + actionBracket, addOracle, |
| 67 | + askOracle, command, command_, |
| 68 | + getDirectoryFiles, liftIO, need, |
| 69 | + newCache, shakeArgsWith, |
| 70 | + shakeOptions, versioned, want) |
| 71 | +import Development.Shake.Classes |
| 72 | +import Experiments.Types (Example (exampleName), |
| 73 | + exampleToOptions) |
| 74 | +import GHC.Exts (toList) |
| 75 | +import GHC.Generics (Generic) |
| 76 | +import HlsPlugins (idePlugins) |
| 77 | +import qualified Ide.Plugin.Config as Plugin |
| 78 | +import Ide.Types |
| 79 | +import Numeric.Natural (Natural) |
| 80 | +import System.Console.GetOpt |
| 81 | +import System.Directory |
| 82 | +import System.FilePath |
| 83 | +import System.IO.Error (tryIOError) |
| 84 | + |
| 85 | +configPath :: FilePath |
| 86 | +configPath = "bench/config.yaml" |
| 87 | + |
| 88 | +configOpt :: OptDescr (Either String FilePath) |
| 89 | +configOpt = Option [] ["config"] (ReqArg Right configPath) "config file" |
| 90 | + |
| 91 | +binaryName :: String |
| 92 | +binaryName = "haskell-language-server" |
| 93 | + |
| 94 | +-- | Read the config without dependency |
| 95 | +readConfigIO :: FilePath -> IO (Config BuildSystem) |
| 96 | +readConfigIO = decodeFileThrow |
| 97 | + |
| 98 | +instance IsExample Example where getExampleName = exampleName |
| 99 | +type instance RuleResult GetExample = Maybe Example |
| 100 | +type instance RuleResult GetExamples = [Example] |
| 101 | + |
| 102 | +shakeOpts :: ShakeOptions |
| 103 | +shakeOpts = |
| 104 | + shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0} |
| 105 | + |
| 106 | +main :: IO () |
| 107 | +main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do |
| 108 | + let config = fromMaybe configPath $ listToMaybe configs |
| 109 | + _configStatic <- createBuildSystem config |
| 110 | + case wants of |
| 111 | + [] -> want ["all"] |
| 112 | + _ -> want wants |
| 113 | + |
| 114 | +hlsBuildRules :: MkBuildRules BuildSystem |
| 115 | +hlsBuildRules = MkBuildRules findGhcForBuildSystem binaryName projectDepends buildHls |
| 116 | + where |
| 117 | + recordDepends path = |
| 118 | + need . map (path </>) =<< getDirectoryFiles path ["//*.hs"] |
| 119 | + projectDepends = do |
| 120 | + recordDepends "src" |
| 121 | + recordDepends "exe" |
| 122 | + recordDepends "plugins" |
| 123 | + recordDepends "ghcide/session-loader" |
| 124 | + recordDepends "ghcide/src" |
| 125 | + recordDepends "hls-graph/src" |
| 126 | + recordDepends "hls-plugin-api/src" |
| 127 | + need =<< getDirectoryFiles "." ["*.cabal"] |
| 128 | + |
| 129 | +-------------------------------------------------------------------------------- |
| 130 | +data Config buildSystem = Config |
| 131 | + { experiments :: [Unescaped String], |
| 132 | + configurations :: [ConfigurationDescriptor], |
| 133 | + examples :: [Example], |
| 134 | + samples :: Natural, |
| 135 | + versions :: [GitCommit], |
| 136 | + -- | Output folder ('foo' works, 'foo/bar' does not) |
| 137 | + outputFolder :: String, |
| 138 | + buildTool :: buildSystem, |
| 139 | + profileInterval :: Maybe Double, |
| 140 | + parallelism :: Natural |
| 141 | + } |
| 142 | + deriving (Generic, Show) |
| 143 | + deriving anyclass (FromJSON) |
| 144 | + |
| 145 | +createBuildSystem :: FilePath -> Rules (Config BuildSystem) |
| 146 | +createBuildSystem config = do |
| 147 | + readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp) |
| 148 | + |
| 149 | + _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config |
| 150 | + _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config |
| 151 | + _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config |
| 152 | + _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config |
| 153 | + _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config |
| 154 | + _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config |
| 155 | + _ <- addOracle $ \GetConfigurations{} -> do |
| 156 | + Config{configurations} <- readConfig config |
| 157 | + return [ Configuration confName (encode $ disableAllPluginsBut (`elem` confPlugins)) |
| 158 | + | ConfigurationDescriptor{..} <- configurations |
| 159 | + ] |
| 160 | + |
| 161 | + configStatic <- liftIO $ readConfigIO config |
| 162 | + let build = outputFolder configStatic |
| 163 | + |
| 164 | + buildRules build hlsBuildRules |
| 165 | + benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchHls warmupHls "haskell-language-server" (parallelism configStatic)) |
| 166 | + csvRules build |
| 167 | + svgRules build |
| 168 | + heapProfileRules build |
| 169 | + phonyRules "" binaryName NoProfiling build (examples configStatic) |
| 170 | + |
| 171 | + whenJust (profileInterval configStatic) $ \i -> do |
| 172 | + phonyRules "profiled-" binaryName (CheapHeapProfiling i) build (examples configStatic) |
| 173 | + |
| 174 | + return configStatic |
| 175 | + |
| 176 | +disableAllPluginsBut :: (PluginId -> Bool) -> Plugin.Config |
| 177 | +disableAllPluginsBut pred = def {Plugin.plugins = pluginsMap} where |
| 178 | + pluginsMap = Map.fromList |
| 179 | + [ (p, def { Plugin.plcGlobalOn = globalOn}) |
| 180 | + | PluginDescriptor{pluginId = plugin@(PluginId p)} <- plugins |
| 181 | + , let globalOn = |
| 182 | + -- ghcide-core is required, nothing works without it |
| 183 | + plugin == PluginId (pack "ghcide-core") |
| 184 | + -- document symbols is required by the benchmark suite |
| 185 | + || plugin == PluginId (pack "ghcide-hover-and-symbols") |
| 186 | + || pred plugin |
| 187 | + ] |
| 188 | + IdePlugins plugins = idePlugins mempty |
| 189 | + |
| 190 | +newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) |
| 191 | +type instance RuleResult GetSamples = Natural |
| 192 | + |
| 193 | +-------------------------------------------------------------------------------- |
| 194 | + |
| 195 | +buildHls :: BuildSystem -> ProjectRoot -> OutputFolder -> Action () |
| 196 | +buildHls Cabal root out = actionBracket |
| 197 | + (do |
| 198 | + projectLocalExists <- liftIO $ doesFileExist projectLocal |
| 199 | + when projectLocalExists $ liftIO $ do |
| 200 | + void $ tryIOError $ removeFile (projectLocal <.> "restore-after-benchmark") |
| 201 | + renameFile projectLocal (projectLocal <.> "restore-after-benchmark") |
| 202 | + liftIO $ writeFile projectLocal $ unlines |
| 203 | + ["package haskell-language-server" |
| 204 | + ," ghc-options: -eventlog -rtsopts" |
| 205 | + ,"package ghcide" |
| 206 | + ," flags: +ekg" |
| 207 | + ] |
| 208 | + return projectLocalExists) |
| 209 | + (\projectLocalExists -> do |
| 210 | + removeFile projectLocal |
| 211 | + when projectLocalExists $ |
| 212 | + renameFile (projectLocal <.> "restore-after-benchmark") projectLocal |
| 213 | + ) $ \_ -> command_ [Cwd root] "cabal" |
| 214 | + ["install" |
| 215 | + ,"haskell-language-server:exe:haskell-language-server" |
| 216 | + ,"--installdir=" ++ out |
| 217 | + ,"--install-method=copy" |
| 218 | + ,"--overwrite-policy=always" |
| 219 | + ] |
| 220 | + where |
| 221 | + projectLocal = root </> "cabal.project.local" |
| 222 | + |
| 223 | +buildHls Stack root out = |
| 224 | + command_ [Cwd root] "stack" |
| 225 | + ["--local-bin-path=" <> out |
| 226 | + ,"build" |
| 227 | + ,"haskell-language-server:haskell-language-server" |
| 228 | + ,"--copy-bins" |
| 229 | + ,"--ghc-options=-rtsopts" |
| 230 | + ,"--ghc-options=-eventlog" |
| 231 | + ] |
| 232 | + |
| 233 | +benchHls |
| 234 | + :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action () |
| 235 | +benchHls samples buildSystem args BenchProject{..} = do |
| 236 | + command_ ([StdinBS configuration] ++ args) "ghcide-bench" $ |
| 237 | + [ "--timeout=300", |
| 238 | + "--no-clean", |
| 239 | + "-v", |
| 240 | + "--samples=" <> show samples, |
| 241 | + "--csv=" <> outcsv, |
| 242 | + "--ghcide=" <> exePath, |
| 243 | + "--select", |
| 244 | + unescaped (unescapeExperiment experiment), |
| 245 | + "--lsp-config" |
| 246 | + ] ++ |
| 247 | + exampleToOptions example exeExtraArgs ++ |
| 248 | + [ "--stack" | Stack == buildSystem |
| 249 | + ] |
| 250 | + |
| 251 | +warmupHls :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action () |
| 252 | +warmupHls buildSystem exePath args example = do |
| 253 | + command args "ghcide-bench" $ |
| 254 | + [ "--no-clean", |
| 255 | + "-v", |
| 256 | + "--samples=1", |
| 257 | + "--ghcide=" <> exePath, |
| 258 | + "--select=hover" |
| 259 | + ] ++ |
| 260 | + exampleToOptions example [] ++ |
| 261 | + [ "--stack" | Stack == buildSystem |
| 262 | + ] |
| 263 | + |
| 264 | +-------------------------------------------------------------------------------- |
| 265 | +data ConfigurationDescriptor = ConfigurationDescriptor |
| 266 | + { confName :: String |
| 267 | + , confPlugins :: [PluginId] |
| 268 | + } |
| 269 | + deriving Show |
| 270 | + |
| 271 | +instance FromJSON ConfigurationDescriptor where |
| 272 | + parseJSON (String s) = pure $ ConfigurationDescriptor (unpack s) [PluginId s] |
| 273 | + parseJSON o@Object{} = do |
| 274 | + let keymap = o ^. _Object |
| 275 | + matchKey = preview _String . toJSON |
| 276 | + case toList keymap of |
| 277 | + -- excuse the aeson 2.0 compatibility hack |
| 278 | + [(matchKey -> Just name, Array values)] -> do |
| 279 | + pluginIds <- traverse parseJSON values |
| 280 | + pure $ ConfigurationDescriptor (unpack name) (map PluginId $ toList pluginIds) |
| 281 | + other -> fail $ "Expected object with name and array of plugin ids: " <> show other |
| 282 | + parseJSON _ = fail "Expected plugin id or object with name and array of plugin ids" |
0 commit comments