diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index bbac124feb..3547e82e5d 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -49,7 +49,7 @@ jobs: ~/.cabal/store key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ hashFiles('cabal.project') }} restore-keys: | - ${{ runner.os }}-${{ matrix.ghc }}-bench-$${ hashFiles('cabal.project') }} + ${{ runner.os }}-${{ matrix.ghc }}-bench-${{ hashFiles('cabal.project') }} ${{ runner.os }}-${{ matrix.ghc }}-build- ${{ runner.os }}-${{ matrix.ghc }} diff --git a/ghcide/bench/config.yaml b/ghcide/bench/config.yaml index 26c179ab02..6748b339a5 100644 --- a/ghcide/bench/config.yaml +++ b/ghcide/bench/config.yaml @@ -14,20 +14,23 @@ examples: # Medium-sized project without TH - name: Cabal version: 3.0.0.0 - module: Distribution/Simple.hs + modules: + - Distribution/Simple.hs + - Distribution/Types/Module.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 + - name: lsp-types + version: 1.0.0.1 + modules: + - src/Language/LSP/VFS.hs + - src/Language/LSP/Types/Lens.hs # The set of experiments to execute experiments: - - hover - - edit - - getDefinition + - "edit" + - "hover" - "hover after edit" + - "getDefinition" + - "getDefinition after edit" - "completions after edit" - "code actions" - "code actions after edit" diff --git a/ghcide/bench/exe/Main.hs b/ghcide/bench/exe/Main.hs index 9b9ae1fac0..ad6460ded2 100644 --- a/ghcide/bench/exe/Main.hs +++ b/ghcide/bench/exe/Main.hs @@ -37,14 +37,23 @@ import Control.Exception.Safe import Experiments import Options.Applicative +import System.IO +import Control.Monad + +optsP :: Parser (Config, Bool) +optsP = (,) <$> configP <*> switch (long "no-clean") main :: IO () main = do - config <- execParser $ info (configP <**> helper) fullDesc + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc let ?config = config + hPrint stderr config + output "starting test" SetupResult{..} <- setup - runBenchmarks experiments `finally` cleanUp + runBenchmarks experiments `finally` unless noClean cleanUp diff --git a/ghcide/bench/hist/Main.hs b/ghcide/bench/hist/Main.hs index 2a9956631c..e9e87693b9 100644 --- a/ghcide/bench/hist/Main.hs +++ b/ghcide/bench/hist/Main.hs @@ -51,6 +51,7 @@ import Experiments.Types (Example, exampleToOptions) import qualified Experiments.Types as E import GHC.Generics (Generic) import Numeric.Natural (Natural) +import Development.Shake.Classes config :: FilePath @@ -70,7 +71,7 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do configStatic <- liftIO $ readConfigIO config let build = outputFolder configStatic buildRules build ghcideBuildRules - benchRules build resource (MkBenchRules (benchGhcide $ samples configStatic) "ghcide") + benchRules build resource (MkBenchRules (askOracle $ GetSamples ()) benchGhcide "ghcide") csvRules build svgRules build action $ allTargets build @@ -98,14 +99,18 @@ createBuildSystem userRules = do _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config - _ <- addOracle $ \GetExamples{} -> examples <$> readConfig config - _ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> 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 benchResource <- newResource "ghcide-bench" 1 userRules benchResource +newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult GetSamples = Natural + -------------------------------------------------------------------------------- buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action () @@ -130,9 +135,10 @@ buildGhcide Stack args out = benchGhcide :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action () -benchGhcide samples buildSystem args BenchProject{..} = +benchGhcide samples buildSystem args BenchProject{..} = do command_ args "ghcide-bench" $ [ "--timeout=3000", + "--no-clean", "-v", "--samples=" <> show samples, "--csv=" <> outcsv, diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 84ad2eaa42..1b4ee3649b 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -20,12 +20,10 @@ module Experiments , exampleToOptions ) where import Control.Applicative.Combinators (skipManyTill) -import Control.Concurrent import Control.Exception.Safe import Control.Monad.Extra import Control.Monad.IO.Class import Data.Aeson (Value(Null)) -import Data.Char (isDigit) import Data.List import Data.Maybe import qualified Data.Text as T @@ -44,93 +42,105 @@ import System.Process import System.Time.Extra import Text.ParserCombinators.ReadP (readP_to_S) -hygienicEdit :: (?hygienicP :: Position) => TextDocumentContentChangeEvent -hygienicEdit = +charEdit :: Position -> TextDocumentContentChangeEvent +charEdit p = TextDocumentContentChangeEvent - { _range = Just (Range ?hygienicP ?hygienicP), - _rangeLength = Nothing, - _text = " " + { _range = Just (Range p p), + _rangeLength = Nothing, + _text = "a" } -breakingEdit :: (?identifierP :: Position) => TextDocumentContentChangeEvent -breakingEdit = - TextDocumentContentChangeEvent - { _range = Just (Range ?identifierP ?identifierP), - _rangeLength = Nothing, - _text = "a" - } +data DocumentPositions = DocumentPositions { + identifierP :: Maybe Position, + stringLiteralP :: !Position, + doc :: !TextDocumentIdentifier +} --- | Experiments have access to these special positions: --- - hygienicP points to a string in the target file, convenient for hygienic edits --- - identifierP points to the middle of an identifier, convenient for goto-def, hover and completions -type HasPositions = (?hygienicP :: Position, ?identifierP :: Position) +allWithIdentifierPos :: Monad m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool +allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs) experiments :: [Bench] experiments = [ --------------------------------------------------------------------------------------- - bench "hover" 10 $ \doc -> - isJust <$> getHover doc ?identifierP, + bench "hover" 10 $ allWithIdentifierPos $ \DocumentPositions{..} -> + isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "edit" 10 $ \doc -> do - changeDoc doc [hygienicEdit] - waitForProgressDone + bench "edit" 10 $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + waitForProgressDone -- TODO check that this waits for all of them return True, --------------------------------------------------------------------------------------- - bench "hover after edit" 10 $ \doc -> do - changeDoc doc [hygienicEdit] - isJust <$> getHover doc ?identifierP, + bench "hover after edit" 10 $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + isJust <$> getHover doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + bench "getDefinition" 10 $ allWithIdentifierPos $ \DocumentPositions{..} -> + not . null <$> getDefinitions doc (fromJust identifierP), + --------------------------------------------------------------------------------------- + bench "getDefinition after edit" 10 $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + not . null <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "getDefinition" 10 $ \doc -> - not . null <$> getDefinitions doc ?identifierP, + bench "documentSymbols" 100 $ allM $ \DocumentPositions{..} -> do + fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, --------------------------------------------------------------------------------------- - bench "documentSymbols" 100 $ - fmap (either (not . null) (not . null)) . getDocumentSymbols, + bench "documentSymbols after edit" 100 $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allM docs $ \DocumentPositions{..} -> + either (not . null) (not . null) <$> getDocumentSymbols doc, --------------------------------------------------------------------------------------- - bench "documentSymbols after edit" 100 $ \doc -> do - changeDoc doc [hygienicEdit] - either (not . null) (not . null) <$> getDocumentSymbols doc, + bench "completions" 10 $ \docs -> do + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + not . null <$> getCompletions doc (fromJust identifierP), --------------------------------------------------------------------------------------- - bench "completions after edit" 10 $ \doc -> do - changeDoc doc [hygienicEdit] - not . null <$> getCompletions doc ?identifierP, + bench "completions after edit" 10 $ \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] + flip allWithIdentifierPos docs $ \DocumentPositions{..} -> + not . null <$> getCompletions doc (fromJust identifierP), --------------------------------------------------------------------------------------- benchWithSetup "code actions" 10 - ( \doc -> do - changeDoc doc [breakingEdit] + ( \docs -> do + unless (any (isJust . identifierP) docs) $ + error "None of the example modules is suitable for this experiment" + forM_ docs $ \DocumentPositions{..} -> + forM_ identifierP $ \p -> changeDoc doc [charEdit p] waitForProgressDone - return ?identifierP ) - ( \p doc -> do - not . null <$> getCodeActions doc (Range p p) + ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> + forM identifierP $ \p -> + getCodeActions doc (Range p p)) ), --------------------------------------------------------------------------------------- benchWithSetup "code actions after edit" 10 - ( \doc -> do - changeDoc doc [breakingEdit] - return ?identifierP + ( \docs -> do + unless (any (isJust . identifierP) docs) $ + error "None of the example modules is suitable for this experiment" + forM_ docs $ \DocumentPositions{..} -> + forM_ identifierP $ \p -> changeDoc doc [charEdit p] ) - ( \p doc -> do - changeDoc doc [hygienicEdit] + ( \docs -> do + forM_ docs $ \DocumentPositions{..} -> + changeDoc doc [charEdit stringLiteralP] waitForProgressDone - -- NOTE ghcide used to clear and reinstall the diagnostics here - -- new versions no longer do, but keep this logic around - -- to benchmark old versions sucessfully - diags <- getCurrentDiagnostics doc - when (null diags) $ - whileM (null <$> waitForDiagnostics) - not . null <$> getCodeActions doc (Range p p) + not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do + forM identifierP $ \p -> + getCodeActions doc (Range p p)) ) ] --------------------------------------------------------------------------------------------- -exampleModulePath :: HasConfig => FilePath -exampleModulePath = exampleModule (example ?config) - examplesPath :: FilePath examplesPath = "bench/example" @@ -160,14 +170,14 @@ configP = <*> 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") <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal") - <*> moduleOption + <*> (some moduleOption <|> pure ["Distribution/Simple.hs"]) <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) <|> UsePackage <$> strOption (long "example-path") - <*> moduleOption + <*> some moduleOption ) where - moduleOption = strOption (long "example-module" <> metavar "PATH" <> value "Distribution/Simple.hs") + moduleOption = strOption (long "example-module" <> metavar "PATH") versionP :: ReadM Version versionP = maybeReader $ extract . readP_to_S parseVersion @@ -179,15 +189,15 @@ output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn --------------------------------------------------------------------------------------- -type Experiment = TextDocumentIdentifier -> Session Bool +type Experiment = [DocumentPositions] -> Session Bool -data Bench = forall setup. +data Bench = Bench { name :: !String, enabled :: !Bool, samples :: !Natural, - benchSetup :: HasPositions => TextDocumentIdentifier -> Session setup, - experiment :: HasPositions => setup -> Experiment + benchSetup :: [DocumentPositions] -> Session (), + experiment :: Experiment } select :: HasConfig => Bench -> Bool @@ -199,18 +209,16 @@ select Bench {name, enabled} = benchWithSetup :: String -> Natural -> - (HasPositions => TextDocumentIdentifier -> Session p) -> - (HasPositions => p -> Experiment) -> + ([DocumentPositions] -> Session ()) -> + Experiment -> Bench benchWithSetup name samples benchSetup experiment = Bench {..} where enabled = True -bench :: String -> Natural -> (HasPositions => Experiment) -> Bench -bench name defSamples userExperiment = - benchWithSetup name defSamples (const $ pure ()) experiment - where - experiment () = userExperiment +bench :: String -> Natural -> Experiment -> Bench +bench name defSamples = + benchWithSetup name defSamples (const $ pure ()) runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO () runBenchmarksFun dir allBenchmarks = do @@ -221,9 +229,9 @@ runBenchmarksFun dir allBenchmarks = do whenJust (otMemoryProfiling ?config) $ \eventlogDir -> createDirectoryIfMissing True eventlogDir - results <- forM benchmarks $ \b@Bench{name} -> + results <- forM benchmarks $ \b@Bench{name} -> do let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir - in (b,) <$> runBench run b + (b,) <$> runBench run b -- output raw data as CSV let headers = @@ -235,8 +243,7 @@ runBenchmarksFun dir allBenchmarks = do , "userTime" , "delayedTime" , "totalTime" - , "maxResidency" - , "allocatedBytes"] + ] rows = [ [ name, show success, @@ -245,9 +252,7 @@ runBenchmarksFun dir allBenchmarks = do show runSetup', show userWaits, show delayedWork, - show runExperiment, - show maxResidency, - show allocations + show runExperiment ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup @@ -267,9 +272,7 @@ runBenchmarksFun dir allBenchmarks = do showDuration runSetup', showDuration userWaits, showDuration delayedWork, - showDuration runExperiment, - showMB maxResidency, - showMB allocations + showDuration runExperiment ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup @@ -278,14 +281,17 @@ runBenchmarksFun dir allBenchmarks = do outputRow $ (map . map) (const '-') paddedHeaders forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row where - cmd name dir = - unwords $ + ghcideCmd dir = [ ghcide ?config, "--lsp", "--test", "--cwd", - dir + dir, + "+RTS" ] + cmd name dir = + unwords $ + ghcideCmd dir ++ case otMemoryProfiling ?config of Just dir -> ["-l", "-ol" ++ (dir map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")] Nothing -> [] @@ -312,13 +318,11 @@ data BenchRun = BenchRun runExperiment :: !Seconds, userWaits :: !Seconds, delayedWork :: !Seconds, - success :: !Bool, - maxResidency :: !Int, - allocations :: !Int + success :: !Bool } badRun :: BenchRun -badRun = BenchRun 0 0 0 0 0 False 0 0 +badRun = BenchRun 0 0 0 0 0 False waitForProgressDone :: Session () waitForProgressDone = @@ -327,49 +331,31 @@ waitForProgressDone = runBench :: (?config :: Config) => (Session BenchRun -> IO BenchRun) -> - (HasPositions => Bench) -> + Bench -> IO BenchRun runBench runSess b = handleAny (\e -> print e >> return badRun) $ runSess $ do - doc <- openDoc exampleModulePath "haskell" - - -- Setup the special positions used by the experiments - lastLine <- length . T.lines <$> documentContents doc - changeDoc doc [TextDocumentContentChangeEvent - { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) - , _rangeLength = Nothing - , _text = T.unlines - [ "_hygienic = \"hygienic\"" - , "_identifier = _hygienic" - ] - }] - let - -- Points to a string in the target file, - -- convenient for hygienic edits - ?hygienicP = Position lastLine 15 - let - -- Points to the middle of an identifier, - -- convenient for requesting goto-def, hover and completions - ?identifierP = Position (lastLine+1) 15 - case b of Bench{..} -> do - (startup, _) <- duration $ do - waitForProgressDone + (startup, docs) <- duration $ do + (d, docs) <- duration $ setupDocumentContents ?config + output $ "Setting up document contents took " <> showDuration d -- wait again, as the progress is restarted once while loading the cradle -- make an edit, to ensure this doesn't block - changeDoc doc [hygienicEdit] + let DocumentPositions{..} = head docs + changeDoc doc [charEdit stringLiteralP] waitForProgressDone + return docs liftIO $ output $ "Running " <> name <> " benchmark" - (runSetup, userState) <- duration $ benchSetup doc + (runSetup, ()) <- duration $ benchSetup docs let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork) loop !userWaits !delayedWork n = do - (t, res) <- duration $ experiment userState doc + (t, res) <- duration $ experiment docs if not res then return Nothing - else do + else do output (showDuration t) -- Wait for the delayed actions to finish waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue @@ -384,15 +370,6 @@ runBench runSess b = handleAny (\e -> print e >> return badRun) (runExperiment, result) <- duration $ loop 0 0 samples let success = isJust result (userWaits, delayedWork) = fromMaybe (0,0) result - gcStats = escapeSpaces (name <> ".benchmark-gcStats") - - -- sleep to give ghcide a chance to GC - liftIO $ threadDelay 1100000 - - (maxResidency, allocations) <- liftIO $ - ifM (doesFileExist gcStats) - (parseMaxResidencyAndAllocations <$> readFile gcStats) - (pure (0,0)) return BenchRun {..} @@ -403,18 +380,25 @@ data SetupResult = SetupResult { cleanUp :: IO () } +callCommandLogging :: HasConfig => String -> IO () +callCommandLogging cmd = do + output cmd + callCommand cmd + setup :: HasConfig => IO SetupResult setup = do - alreadyExists <- doesDirectoryExist examplesPath - when alreadyExists $ removeDirectoryRecursive examplesPath +-- when alreadyExists $ removeDirectoryRecursive examplesPath benchDir <- case example ?config of UsePackage{..} -> return examplePath GetPackage{..} -> do let path = examplesPath package package = exampleName <> "-" <> showVersion exampleVersion - case buildTool ?config of + alreadySetup <- doesDirectoryExist path + unless alreadySetup $ + case buildTool ?config of Cabal -> do - callCommand $ "cabal get -v0 " <> package <> " -d " <> examplesPath + let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config)) + callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath writeFile (path "hie.yaml") ("cradle: {cabal: {component: " <> exampleName <> "}}") @@ -426,7 +410,11 @@ setup = do (path "cabal.project.local") "" Stack -> do - callCommand $ "stack --silent unpack " <> package <> " --to " <> examplesPath + let stackVerbosity = case verbosity ?config of + Quiet -> "--silent" + Normal -> "" + All -> "--verbose" + callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath -- Generate the stack descriptor to match the one used to build ghcide stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML" stack_yaml_lines <- lines <$> readFile stack_yaml @@ -457,28 +445,87 @@ setup = do return SetupResult{..} --------------------------------------------------------------------------------------------- +setupDocumentContents :: Config -> Session [DocumentPositions] +setupDocumentContents config = + forM (exampleModules $ example config) $ \m -> do + doc <- openDoc m "haskell" + + -- Setup the special positions used by the experiments + lastLine <- length . T.lines <$> documentContents doc + changeDoc doc [TextDocumentContentChangeEvent + { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) + , _rangeLength = Nothing + , _text = T.unlines [ "_hygienic = \"hygienic\"" ] + }] + let + -- Points to a string in the target file, + -- convenient for hygienic edits + stringLiteralP = Position lastLine 15 + + -- Find an identifier defined in another file in this project + symbols <- getDocumentSymbols doc + case symbols of + Left [DocumentSymbol{_children = Just (List symbols)}] -> do + let endOfImports = case symbols of + DocumentSymbol{_kind = SkModule, _name = "imports", _range } : _ -> + Position (succ $ _line $ _end _range) 4 + DocumentSymbol{_range} : _ -> _start _range + [] -> error "Module has no symbols" + contents <- documentContents doc + + identifierP <- searchSymbol doc contents endOfImports + + return $ DocumentPositions{..} + other -> + error $ "symbols: " <> show other --- Parse the max residency and allocations in RTS -s output -parseMaxResidencyAndAllocations :: String -> (Int, Int) -parseMaxResidencyAndAllocations input = - (f "maximum residency", f "bytes allocated in the heap") - where - inps = reverse $ lines input - f label = case find (label `isInfixOf`) inps of - Just l -> read $ filter isDigit $ head $ words l - Nothing -> -1 -escapeSpaces :: String -> String -escapeSpaces = map f - where - f ' ' = '_' - f x = x + +-------------------------------------------------------------------------------------------- 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" +-- | Search for a position where: +-- - get definition works and returns a uri other than this file +-- - get completions returns a non empty list +searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position) +searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do + -- this search is expensive, so we cache the result on disk + let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition" + cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath + case cachedRes of + Left _ -> do + result <- loop pos + liftIO $ writeFile cachedPath $ show result + return result + Right res -> + return res + where + loop pos + | _line pos >= lll = + return Nothing + | _character pos >= lengthOfLine (_line pos) = + loop (nextLine pos) + | otherwise = do + checks <- checkDefinitions pos &&^ checkCompletions pos + if checks + then return $ Just pos + else loop (nextIdent pos) + + nextIdent p = p{_character = _character p + 2} + nextLine p = Position (_line p + 1) 4 + + lengthOfLine n = if n >= lll then 0 else T.length (ll !! n) + ll = T.lines fileContents + lll = length ll + + checkDefinitions pos = do + defs <- getDefinitions doc pos + case defs of + [Location uri _] -> return $ uri /= _uri + _ -> return False + checkCompletions pos = + not . null <$> getCompletions doc pos diff --git a/ghcide/bench/lib/Experiments/Types.hs b/ghcide/bench/lib/Experiments/Types.hs index 350f89ad94..8232e9d7f4 100644 --- a/ghcide/bench/lib/Experiments/Types.hs +++ b/ghcide/bench/lib/Experiments/Types.hs @@ -32,8 +32,8 @@ data Config = Config deriving (Eq, Show) data Example - = GetPackage {exampleName, exampleModule :: String, exampleVersion :: Version} - | UsePackage {examplePath :: FilePath, exampleModule :: String} + = GetPackage {exampleName :: !String, exampleModules :: [FilePath], exampleVersion :: Version} + | UsePackage {examplePath :: FilePath, exampleModules :: [FilePath]} deriving (Eq, Generic, Show) deriving anyclass (Binary, Hashable, NFData) @@ -48,7 +48,8 @@ getExampleName GetPackage{exampleName, exampleVersion} = instance FromJSON Example where parseJSON = withObject "example" $ \x -> do - exampleModule <- x .: "module" + exampleModules <- x .: "modules" + path <- x .:? "path" case path of Just examplePath -> return UsePackage{..} @@ -61,9 +62,9 @@ exampleToOptions :: Example -> [String] exampleToOptions GetPackage{..} = ["--example-package-name", exampleName ,"--example-package-version", showVersion exampleVersion - ,"--example-module", exampleModule - ] + ] ++ + ["--example-module=" <> m | m <- exampleModules] exampleToOptions UsePackage{..} = ["--example-path", examplePath - ,"--example-module", exampleModule - ] + ] ++ + ["--example-module=" <> m | m <- exampleModules] diff --git a/shake-bench/src/Development/Benchmark/Rules.hs b/shake-bench/src/Development/Benchmark/Rules.hs index 6870aeb85c..2b78fcdac0 100644 --- a/shake-bench/src/Development/Benchmark/Rules.hs +++ b/shake-bench/src/Development/Benchmark/Rules.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ConstraintKinds #-} @@ -67,7 +68,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.!=), (.:?)) -import Data.List (find, transpose) +import Data.List (isInfixOf, find, transpose) import Data.List.Extra (lower) import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -88,6 +89,10 @@ import qualified Text.ParserCombinators.ReadP as P import Text.Read (Read (..), get, readMaybe, readP_to_Prec) +import Text.Printf +import Control.Monad.Extra +import qualified System.Directory as IO +import Data.Char (isDigit) newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show) newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show) @@ -194,8 +199,12 @@ buildRules build MkBuildRules{..} = do writeFile' ghcPath ghcLoc -------------------------------------------------------------------------------- -data MkBenchRules buildSystem example = MkBenchRules - { benchProject :: buildSystem -> [CmdOption] -> BenchProject example -> Action () +data MkBenchRules buildSystem example = forall setup. MkBenchRules + { + -- | Workaround for Shake not allowing to call 'askOracle' from 'benchProject + setupProject :: Action setup + -- | An action that invokes the executable to run the benchmark + , benchProject :: setup -> buildSystem -> [CmdOption] -> BenchProject example -> Action () -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules' , executableName :: String } @@ -222,6 +231,7 @@ benchRules build benchResource MkBenchRules{..} = do example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> askOracle (GetExample exampleName) buildSystem <- askOracle $ GetBuildSystem () + setupRes <- setupProject liftIO $ createDirectoryIfMissing True $ dropFileName outcsv let exePath = build "binaries" ver executableName exeExtraArgs = ["+RTS", "-I0.5", "-S" <> takeFileName outGc, "-RTS"] @@ -230,7 +240,7 @@ benchRules build benchResource MkBenchRules{..} = do need [exePath, ghcPath] ghcPath <- readFile' ghcPath withResource benchResource 1 $ do - benchProject buildSystem + benchProject setupRes buildSystem [ EchoStdout False, FileStdout outLog, RemEnv "NIX_GHC_LIBDIR", @@ -240,6 +250,43 @@ benchRules build benchResource MkBenchRules{..} = do BenchProject{..} cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv + -- extend csv output with allocation data + csvContents <- liftIO $ lines <$> readFile outcsv + let header = head csvContents + results = tail csvContents + header' = header <> ", maxResidency, allocatedBytes" + results' <- forM results $ \row -> do + -- assume that the gcStats file can be guessed from the row id + -- assume that the row id is the first column + let id = takeWhile (/= ',') row + let gcStatsPath = dropFileName outcsv escapeSpaces id <.> "benchmark-gcStats" + (maxResidency, allocations) <- liftIO $ + ifM (IO.doesFileExist gcStatsPath) + (parseMaxResidencyAndAllocations <$> readFile gcStatsPath) + (pure (0,0)) + return $ printf "%s, %s, %s" row (showMB maxResidency) (showMB allocations) + let csvContents' = header' : results' + writeFileLines outcsv csvContents' + where + escapeSpaces :: String -> String + escapeSpaces = map f where + f ' ' = '_' + f x = x + + showMB :: Int -> String + showMB x = show (x `div` 2^(20::Int)) <> "MB" + + +-- Parse the max residency and allocations in RTS -s output +parseMaxResidencyAndAllocations :: String -> (Int, Int) +parseMaxResidencyAndAllocations input = + (f "maximum residency", f "bytes allocated in the heap") + where + inps = reverse $ lines input + f label = case find (label `isInfixOf`) inps of + Just l -> read $ filter isDigit $ head $ words l + Nothing -> -1 + --------------------------------------------------------------------------------