From 2b8a6dcc0c0a24f7728cc1cdbed85f4cfd5a835e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Fri, 12 Jun 2020 19:46:55 +0100 Subject: [PATCH] More benchmarks (haskell/ghcide#625) * Add a benchmark to track startup times * Benchmark automation disable benchmarks easily save GC stats to file cradle, rts, filter and samples options path to ghcide configurable example --help more detailed CSV output hover after edit pause for GC configurable timeout upgrade extra (required to build bench) Include max residency in BenchRun Include all details on output * reduce threadDelay to avoid upsetting lsp-test * Fix startup time measurement * Added new edit experiment * fix doc comment * hlints * Upgrade to lsp-test 0.11.0.2 * Flag failed experiments * Update ghcide.cabal --- bench/Main.hs | 301 +++++++++++++++++++++--------- ghcide.cabal | 2 +- src/Development/IDE/Core/Shake.hs | 2 +- stack.yaml | 3 +- stack810.yaml | 3 +- stack84.yaml | 4 +- stack88.yaml | 4 +- 7 files changed, 222 insertions(+), 97 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index 22bb0d5066..29d3aa48ac 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -28,7 +28,7 @@ How to run: 1. `cabal bench` - 2. `cabal exec -- ghcide-bench-options` + 2. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options` Note that the package database influences the response times of certain actions, e.g. code actions, and therefore the two methods above do not necessarily @@ -36,12 +36,11 @@ -} -import Control.Applicative.Combinators +import Control.Applicative.Combinators (skipManyTill) import Control.Concurrent import Control.Exception.Safe import Control.Monad.Extra import Control.Monad.IO.Class -import Data.Aeson import Data.List import Data.Maybe import Data.Version @@ -54,12 +53,30 @@ import System.Directory import System.FilePath (()) import System.Process import System.Time.Extra +import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Char (isDigit) -- Points to a string in the target file, -- convenient for hygienic edits hygienicP :: Position hygienicP = Position 854 23 +hygienicEdit :: TextDocumentContentChangeEvent +hygienicEdit = + TextDocumentContentChangeEvent + { _range = Just (Range hygienicP hygienicP), + _rangeLength = Nothing, + _text = " " + } + +breakingEdit :: TextDocumentContentChangeEvent +breakingEdit = + TextDocumentContentChangeEvent + { _range = Just (Range identifierP identifierP), + _rangeLength = Nothing, + _text = "a" + } + -- Points to the middle of an identifier, -- convenient for requesting goto-def, hover and completions identifierP :: Position @@ -67,7 +84,7 @@ identifierP = Position 853 12 main :: IO () main = do - config <- execParser $ info configP fullDesc + config <- execParser $ info (configP <**> helper) fullDesc let ?config = config output "starting test" @@ -79,6 +96,15 @@ main = do bench "hover" 10 $ \doc -> isJust <$> getHover doc identifierP, --------------------------------------------------------------------------------------- + bench "edit" 10 $ \doc -> do + changeDoc doc [hygienicEdit] + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + return True, + --------------------------------------------------------------------------------------- + bench "hover after edit" 10 $ \doc -> do + changeDoc doc [hygienicEdit] + isJust <$> getHover doc identifierP, + --------------------------------------------------------------------------------------- bench "getDefinition" 10 $ \doc -> not . null <$> getDefinitions doc identifierP, --------------------------------------------------------------------------------------- @@ -86,92 +112,104 @@ main = do fmap (either (not . null) (not . null)) . getDocumentSymbols, --------------------------------------------------------------------------------------- bench "documentSymbols after edit" 100 $ \doc -> do - let change = - TextDocumentContentChangeEvent - { _range = Just (Range hygienicP hygienicP), - _rangeLength = Nothing, - _text = " " - } - changeDoc doc [change] + changeDoc doc [hygienicEdit] either (not . null) (not . null) <$> getDocumentSymbols doc, --------------------------------------------------------------------------------------- bench "completions after edit" 10 $ \doc -> do - let change = - TextDocumentContentChangeEvent - { _range = Just (Range hygienicP hygienicP), - _rangeLength = Nothing, - _text = " " - } - changeDoc doc [change] + changeDoc doc [hygienicEdit] not . null <$> getCompletions doc identifierP, --------------------------------------------------------------------------------------- benchWithSetup "code actions" 10 ( \doc -> do - let p = identifierP - let change = - TextDocumentContentChangeEvent - { _range = Just (Range p p), - _rangeLength = Nothing, - _text = "a" - } - changeDoc doc [change] + changeDoc doc [breakingEdit] void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) - return p + return identifierP ) ( \p doc -> do not . null <$> getCodeActions doc (Range p p) ), --------------------------------------------------------------------------------------- bench "code actions after edit" 10 $ \doc -> do - let p = identifierP - let change = - TextDocumentContentChangeEvent - { _range = Just (Range p p), - _rangeLength = Nothing, - _text = "a" - } - changeDoc doc [change] + changeDoc doc [breakingEdit] void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) - not . null <$> getCodeActions doc (Range p p) + not . null <$> getCodeActions doc (Range identifierP identifierP) ] `finally` cleanUp --------------------------------------------------------------------------------------------- -examplePackageName :: String -examplePackageName = "Cabal" - -examplePackageVersion :: Version -examplePackageVersion = makeVersion [3, 2, 0, 0] +examplePackageName :: HasConfig => String +examplePackageName = name + where + (name, _, _) = examplePackageUsed ?config -examplePackage :: String -examplePackage = examplePackageName <> "-" <> showVersion examplePackageVersion +examplePackage :: HasConfig => String +examplePackage = name <> "-" <> showVersion version + where + (name, version, _) = examplePackageUsed ?config -exampleModulePath :: FilePath -exampleModulePath = "Distribution" "Simple.hs" +exampleModulePath :: HasConfig => FilePath +exampleModulePath = path + where + (_,_, path) = examplePackageUsed ?config examplesPath :: FilePath examplesPath = "bench/example" +data Verbosity = Quiet | Normal | All + deriving (Eq, Show) data Config = Config - { verbose :: !Bool, + { verbosity :: !Verbosity, -- For some reason, the Shake profile files are truncated and won't load shakeProfiling :: !(Maybe FilePath), - outputCSV :: !Bool + outputCSV :: !FilePath, + cradle :: !Cradle, + rtsOptions :: ![String], + matches :: ![String], + repetitions :: Maybe Natural, + ghcide :: FilePath, + timeoutLsp :: Int, + examplePackageUsed :: (String, Version, String) } + deriving (Eq, Show) + +quiet, verbose :: Config -> Bool +verbose = (== All) . verbosity +quiet = (== Quiet) . verbosity + +data Cradle = Cabal | Stack + deriving (Eq, Show) type HasConfig = (?config :: Config) configP :: Parser Config -configP = Config - <$> (not <$> switch (long "quiet")) +configP = + Config + <$> (flag' All (short 'v' <> long "verbose") + <|> flag' Quiet (short 'q' <> long "quiet") + <|> pure Normal + ) <*> optional (strOption (long "shake-profiling" <> metavar "PATH")) - <*> switch (long "csv") + <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault) + <*> flag Cabal Stack (long "stack" <> help "Use a stack cradle") + <*> many (strOption (long "rts" <> help "additional RTS options for ghcide")) + <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run")) + <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count")) + <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide") + <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") + <*> ( (,,) <$> strOption (long "example-package-name" <> value "Cabal") + <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) + <*> strOption (long "example-package-module" <> metavar "PATH" <> value "Distribution/Simple.hs")) + +versionP :: ReadM Version +versionP = maybeReader $ extract . readP_to_S parseVersion + where + extract parses = listToMaybe [ res | (res,"") <- parses] output :: (MonadIO m, HasConfig) => String -> m () -output = if verbose ?config then liftIO . putStrLn else (\_ -> pure ()) +output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn --------------------------------------------------------------------------------------- @@ -180,52 +218,107 @@ type Experiment = TextDocumentIdentifier -> Session Bool data Bench = forall setup. Bench { name :: !String, + enabled :: !Bool, samples :: !Natural, benchSetup :: TextDocumentIdentifier -> Session setup, experiment :: setup -> Experiment } -bench :: String -> Natural -> Experiment -> Bench -bench name samples userExperiment = Bench {..} +select :: HasConfig => Bench -> Bool +select Bench {name, enabled} = + enabled && (null mm || name `elem` mm) where - experiment () = userExperiment - benchSetup _ = return () + mm = matches ?config benchWithSetup :: + HasConfig => String -> Natural -> (TextDocumentIdentifier -> Session p) -> (p -> Experiment) -> Bench -benchWithSetup = Bench +benchWithSetup name defSamples benchSetup experiment = Bench {..} + where + enabled = True + samples = fromMaybe defSamples (repetitions ?config) + +bench :: HasConfig => String -> Natural -> Experiment -> Bench +bench name defSamples userExperiment = + benchWithSetup name defSamples (const $ pure ()) experiment + where + experiment () = userExperiment runBenchmarks :: HasConfig => [Bench] -> IO () -runBenchmarks benchmarks = do +runBenchmarks (filter select -> benchmarks) = do results <- forM benchmarks $ \b -> (b,) <$> runBench b - forM_ results $ \(Bench {name, samples}, duration) -> - output $ - "TOTAL " - <> name - <> " = " - <> showDuration duration - <> " (" - <> show samples - <> " repetitions)" - - when (outputCSV ?config) $ do - putStrLn $ intercalate ", " $ map name benchmarks - putStrLn $ intercalate ", " $ map (showDuration . snd) results - -runBench :: HasConfig => Bench -> IO Seconds -runBench Bench {..} = handleAny (\e -> print e >> return (-1)) + -- output raw data as CSV + let headers = ["name", "success", "samples", "startup", "setup", "experiment", "maxResidency"] + rows = + [ [ name, + show success, + show samples, + show startup, + show runSetup', + show runExperiment, + showMB maxResidency + ] + | (Bench {name, samples}, BenchRun {..}) <- results, + let runSetup' = if runSetup < 0.01 then 0 else runSetup + ] + csv = unlines $ map (intercalate ", ") (headers : rows) + writeFile (outputCSV ?config) csv + + -- print a nice table + let pads = map (maximum . map length) (transpose (headers : rowsHuman)) + paddedHeaders = zipWith pad pads headers + outputRow = putStrLn . intercalate " | " + rowsHuman = + [ [ name, + show success, + show samples, + showDuration startup, + showDuration runSetup', + showDuration runExperiment, + showMB maxResidency + ] + | (Bench {name, samples}, BenchRun {..}) <- results, + let runSetup' = if runSetup < 0.01 then 0 else runSetup + ] + outputRow paddedHeaders + outputRow $ (map . map) (const '-') paddedHeaders + forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row + +data BenchRun = BenchRun + { startup :: !Seconds, + runSetup :: !Seconds, + runExperiment :: !Seconds, + success :: !Bool, + maxResidency :: !Int + } + +badRun :: BenchRun +badRun = BenchRun 0 0 0 False 0 + +waitForProgressDone :: Session () +waitForProgressDone = + void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + +runBench :: HasConfig => Bench -> IO BenchRun +runBench Bench {..} = handleAny (\e -> print e >> return badRun) $ runSessionWithConfig conf cmd lspTestCaps dir $ do doc <- openDoc exampleModulePath "haskell" - void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + (startup, _) <- duration $ do + waitForProgressDone + -- wait again, as the progress is restarted once while loading the cradle + -- make an edit, to ensure this doesn't block + changeDoc doc [hygienicEdit] + waitForProgressDone + liftIO $ output $ "Running " <> name <> " benchmark" - userState <- benchSetup doc + (runSetup, userState) <- duration $ benchSetup doc let loop 0 = return True loop n = do (t, res) <- duration $ experiment userState doc @@ -235,24 +328,28 @@ runBench Bench {..} = handleAny (\e -> print e >> return (-1)) output (showDuration t) loop (n -1) - (t, res) <- duration $ loop samples + (runExperiment, success) <- duration $ loop samples + + -- sleep to give ghcide a chance to GC + liftIO $ threadDelay 1100000 - exitServer - -- sleeep to give ghcide a chance to print the RTS stats - liftIO $ threadDelay 50000 + maxResidency <- liftIO $ parseMaxResidency <$> readFile gcStats - return $ if res then t else -1 + return BenchRun {..} where + gcStats = escapeSpaces (name <> ".benchmark-gcStats") cmd = unwords $ - [ "ghcide", + [ ghcide ?config, "--lsp", "--cwd", dir, "+RTS", - "-S", - "-RTS" + "-S" <> gcStats ] + ++ rtsOptions ?config + ++ [ "-RTS" + ] ++ concat [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config] @@ -263,8 +360,9 @@ runBench Bench {..} = handleAny (\e -> print e >> return (-1)) conf = defaultConfig { logStdErr = verbose ?config, - logMessages = False, - logColor = False + logMessages = verbose ?config, + logColor = False, + messageTimeout = timeoutLsp ?config } setup :: HasConfig => IO (IO ()) @@ -274,14 +372,37 @@ setup = do callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath writeFile (examplesPath examplePackage "hie.yaml") - ("cradle: {cabal: {component: " <> show examplePackageName <> "}}") + exampleCradle whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True return $ removeDirectoryRecursive examplesPath --- | Asks the server to shutdown and exit politely -exitServer :: Session () -exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams - -------------------------------------------------------------------------------------------- + +-- Parse the max residency in RTS -s output +parseMaxResidency :: String -> Int +parseMaxResidency input = + case find ("maximum residency" `isInfixOf`) (reverse $ lines input) of + Just l -> read $ filter isDigit $ head (words l) + Nothing -> -1 + + +escapeSpaces :: String -> String +escapeSpaces = map f + where + f ' ' = '_' + f x = x + +exampleCradle :: HasConfig => String +exampleCradle = case cradle ?config of + Cabal -> "cradle: {cabal: {component: " <> show examplePackageName <> "}}" + Stack -> "cradle: {stack: {component: " <> show (examplePackageName <> ":lib") <> "}}" + +pad :: Int -> String -> String +pad n [] = replicate n ' ' +pad 0 _ = error "pad" +pad n (x:xx) = x : pad (n-1) xx + +showMB :: Int -> String +showMB x = show (x `div` 2^(20::Int)) <> "MB" diff --git a/ghcide.cabal b/ghcide.cabal index 529f94f86e..57a6a4bfdf 100644 --- a/ghcide.cabal +++ b/ghcide.cabal @@ -319,7 +319,7 @@ benchmark ghcide-bench extra, filepath, ghcide, - lsp-test < 0.12, + lsp-test >= 0.11.0.2 && < 0.12, optparse-applicative, parser-combinators, process, diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs index aa9b2fb913..de63fc4f31 100644 --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -440,7 +440,7 @@ shakeEnqueue :: IdeState -> Action a -> IO (IO a) shakeEnqueue IdeState{shakeSession} act = withMVar shakeSession $ \s -> runInShakeSession s act --- Set up a new 'ShakeSession' with a set of initial system and user actions +-- | Set up a new 'ShakeSession' with a set of initial system and user actions -- Will crash if there is an existing 'ShakeSession' running. -- Progress is reported only on the system actions. -- Only user actions will get re-enqueued diff --git a/stack.yaml b/stack.yaml index 70ecc9740a..161bce4738 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,7 @@ packages: extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 -- lsp-test-0.11.0.1 +- lsp-test-0.11.0.2 - hie-bios-0.5.0 - fuzzy-0.1.0.0 - regex-pcre-builtin-0.95.1.1.8.43 @@ -15,5 +15,6 @@ extra-deps: - haddock-library-1.8.0 - tasty-rerun-1.1.17 - ghc-check-0.5.0.1 +- extra-1.7.2 nix: packages: [zlib] diff --git a/stack810.yaml b/stack810.yaml index eadbc62748..554889b983 100644 --- a/stack810.yaml +++ b/stack810.yaml @@ -6,13 +6,14 @@ packages: extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 -- lsp-test-0.11.0.1 +- lsp-test-0.11.0.2 - ghc-check-0.5.0.1 - hie-bios-0.5.0 # for ghc-8.10 - Cabal-3.2.0.0 - lens-4.19.1 +- extra-1.7.2 nix: packages: [zlib] diff --git a/stack84.yaml b/stack84.yaml index 886485cff0..a76782e487 100644 --- a/stack84.yaml +++ b/stack84.yaml @@ -7,7 +7,7 @@ extra-deps: - base-orphans-0.8.2 - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 -- lsp-test-0.11.0.1 +- lsp-test-0.11.0.2 - rope-utf16-splay-0.3.1.0 - filepattern-0.1.1 - js-dgtable-0.5.2 @@ -23,11 +23,13 @@ extra-deps: - file-embed-0.0.11.2 - heaps-0.3.6.1 - ghc-check-0.5.0.1 +- extra-1.7.2 # For tasty-retun - ansi-terminal-0.10.3 - ansi-wl-pprint-0.6.9 - tasty-1.2.3 - tasty-rerun-1.1.17 + nix: packages: [zlib] diff --git a/stack88.yaml b/stack88.yaml index 3bf6d99a27..c6f7a1f0af 100644 --- a/stack88.yaml +++ b/stack88.yaml @@ -4,9 +4,9 @@ packages: extra-deps: - haskell-lsp-0.22.0.0 - haskell-lsp-types-0.22.0.0 -- lsp-test-0.11.0.1 +- lsp-test-0.11.0.2 - ghc-check-0.5.0.1 - hie-bios-0.5.0 - +- extra-1.7.2 nix: packages: [zlib]