From 281794e854759c831923bb6e2aa465f0fa0221bf Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 21 Jan 2020 08:05:58 +0000 Subject: [PATCH] Fix performance of getFileExists (haskell/ghcide#322) * Improve hover performance by speeding up getFileExists We touch the file system only the first time. After that, we rely on the lsp client to tell us if a file is created or deleted Fixes haskell/ghcide#101 --- exe/Main.hs | 6 +- ghcide.cabal | 13 ++ src/Development/IDE/Core/FileExists.hs | 187 +++++++++++++++++++++++ src/Development/IDE/Core/FileStore.hs | 37 +---- src/Development/IDE/Core/Rules.hs | 3 +- src/Development/IDE/Core/Service.hs | 10 +- src/Development/IDE/Core/Shake.hs | 14 +- src/Development/IDE/LSP/Notifications.hs | 41 +++-- test/exe/Main.hs | 13 +- 9 files changed, 270 insertions(+), 54 deletions(-) create mode 100644 src/Development/IDE/Core/FileExists.hs diff --git a/exe/Main.hs b/exe/Main.hs index afcd09c281..48bc36923e 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -93,10 +93,10 @@ main = do -- very important we only call loadSession once, and it's fast, so just do it before starting session <- loadSession dir let options = (defaultIdeOptions $ return session) - { optReportProgress = clientSupportsProgress caps + { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling } - initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs + initialise caps (mainRule >> action kick) getLspId event (logger minBound) options vfs else do putStrLn $ "Ghcide setup tester in " ++ dir ++ "." putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues" @@ -125,7 +125,7 @@ main = do let grab file = fromMaybe (head sessions) $ do cradle <- Map.lookup file filesToCradles Map.lookup cradle cradlesToSessions - ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs putStrLn "\nStep 6/6: Type checking the files" setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files diff --git a/ghcide.cabal b/ghcide.cabal index 014251aa7e..deeebbe559 100644 --- a/ghcide.cabal +++ b/ghcide.cabal @@ -121,6 +121,7 @@ library Development.IDE.Core.Debouncer Development.IDE.Core.Compile Development.IDE.Core.Preprocessor + Development.IDE.Core.FileExists Development.IDE.GHC.Compat Development.IDE.GHC.CPP Development.IDE.GHC.Error @@ -230,4 +231,16 @@ test-suite ghcide-tests Development.IDE.Test Development.IDE.Test.Runfiles default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs new file mode 100644 index 0000000000..6738e13189 --- /dev/null +++ b/src/Development/IDE/Core/FileExists.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Development.IDE.Core.FileExists + ( fileExistsRules + , modifyFileExists + , getFileExists + ) +where + +import Control.Concurrent.Extra +import Control.Exception +import Control.Monad.Extra +import qualified Data.Aeson as A +import Data.Binary +import qualified Data.ByteString as BS +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Core.FileStore +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Development.Shake +import Development.Shake.Classes +import GHC.Generics +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +import qualified System.Directory as Dir + +-- | A map for tracking the file existence +type FileExistsMap = (Map NormalizedFilePath Bool) + +-- | A wrapper around a mutable 'FileExistsMap' +newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap) + +instance IsIdeGlobal FileExistsMapVar + +-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency +getFileExistsMapUntracked :: Action FileExistsMap +getFileExistsMapUntracked = do + FileExistsMapVar v <- getIdeGlobalAction + liftIO $ readVar v + +-- | Modify the global store of file exists +modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action () +modifyFileExistsAction f = do + FileExistsMapVar var <- getIdeGlobalAction + liftIO $ modifyVar_ var f + +-- | Modify the global store of file exists +modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO () +modifyFileExists state changes = do + FileExistsMapVar var <- getIdeGlobalState state + changesMap <- evaluate $ Map.fromList changes + + -- Masked to ensure that the previous values are flushed together with the map update + mask $ \_ -> do + -- update the map + modifyVar_ var $ evaluate . Map.union changesMap + -- flush previous values + mapM_ (deleteValue state GetFileExists . fst) changes + +------------------------------------------------------------------------------------- + +type instance RuleResult GetFileExists = Bool + +data GetFileExists = GetFileExists + deriving (Eq, Show, Typeable, Generic) + +instance NFData GetFileExists +instance Hashable GetFileExists +instance Binary GetFileExists + +-- | Returns True if the file exists +-- Note that a file is not considered to exist unless it is saved to disk. +-- In particular, VFS existence is not enough. +-- Consider the following example: +-- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest +-- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing +-- 2. The editor creates a new buffer @B.hs@ +-- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up +-- Most editors, e.g. VSCode, only send the event when the file is saved to disk. +getFileExists :: NormalizedFilePath -> Action Bool +getFileExists fp = use_ GetFileExists fp + +-- | Installs the 'getFileExists' rules. +-- Provides a fast implementation if client supports dynamic watched files. +-- Creates a global state as a side effect in that case. +fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules () +fileExistsRules getLspId ClientCapabilities{_workspace} + | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + = fileExistsRulesFast getLspId + | otherwise = fileExistsRulesSlow + +-- Requires an lsp client that provides WatchedFiles notifications. +fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules () +fileExistsRulesFast getLspId vfs = do + addIdeGlobal . FileExistsMapVar =<< liftIO (newVar []) + defineEarlyCutoff $ \GetFileExists file -> do + fileExistsMap <- getFileExistsMapUntracked + let mbFilesWatched = Map.lookup file fileExistsMap + case mbFilesWatched of + Just fv -> pure (summarizeExists fv, ([], Just fv)) + Nothing -> do + exist <- liftIO $ getFileExistsVFS vfs file + ShakeExtras { eventer } <- getShakeExtras + + -- add a listener for VFS Create/Delete file events, + -- taking the FileExistsMap lock to prevent race conditions + -- that would lead to multiple listeners for the same path + modifyFileExistsAction $ \x -> do + case Map.insertLookupWithKey (\_ x _ -> x) file exist x of + (Nothing, x') -> do + -- if the listener addition fails, we never recover. This is a bug. + addListener eventer file + return x' + (Just _, _) -> + -- if the key was already there, do nothing + return x + + pure (summarizeExists exist, ([], Just exist)) + where + addListener eventer fp = do + reqId <- getLspId + let + req = RequestMessage "2.0" reqId ClientRegisterCapability regParams + fpAsId = T.pack $ fromNormalizedFilePath fp + regParams = RegistrationParams (List [registration]) + registration = Registration fpAsId + WorkspaceDidChangeWatchedFiles + (Just (A.toJSON regOptions)) + regOptions = + DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] } + watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp + , kind = Just 5 -- Create and Delete events only + } + + eventer $ ReqRegisterCapability req + +summarizeExists :: Bool -> Maybe BS.ByteString +summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty + +fileExistsRulesSlow:: VFSHandle -> Rules () +fileExistsRulesSlow vfs = do + defineEarlyCutoff $ \GetFileExists file -> do + alwaysRerun + exist <- liftIO $ getFileExistsVFS vfs file + pure (summarizeExists exist, ([], Just exist)) + +getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool +getFileExistsVFS vfs file = do + -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute + -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly + -- cached 'No' rather than an exception in the wrong place + handle (\(_ :: IOException) -> return False) $ + (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^ + Dir.doesFileExist (fromNormalizedFilePath file) + +-------------------------------------------------------------------------------------------------- +-- The message definitions below probably belong in haskell-lsp-types + +data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions + { watchers :: List FileSystemWatcher + } + +instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where + toJSON DidChangeWatchedFilesRegistrationOptions {..} = + A.object ["watchers" A..= watchers] + +data FileSystemWatcher = FileSystemWatcher + { -- | The glob pattern to watch. + -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles + globPattern :: String + -- | The kind of event to subscribe to. Defaults to all. + -- Defined as a bitmap of Create(1), Change(2), and Delete(4) + , kind :: Maybe Int + } + +instance A.ToJSON FileSystemWatcher where + toJSON FileSystemWatcher {..} = + A.object + $ ["globPattern" A..= globPattern] + ++ [ "kind" A..= x | Just x <- [kind] ] diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs index 197a658f4a..ebdaac25aa 100644 --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -4,7 +4,8 @@ {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.FileStore( - getFileExists, getFileContents, + getFileContents, + getVirtualFile, setBufferModified, setSomethingModified, fileStoreRules, @@ -20,16 +21,14 @@ import Fingerprint import StringBuffer import Development.IDE.GHC.Orphans() import Development.IDE.GHC.Util - +import Development.IDE.Core.Shake import Control.Concurrent.Extra import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T import Control.Monad.Extra -import qualified System.Directory as Dir import Development.Shake import Development.Shake.Classes -import Development.IDE.Core.Shake import Control.Exception import GHC.Generics import Data.Either.Extra @@ -90,17 +89,8 @@ makeLSPVFSHandle lspFuncs = VFSHandle -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer) --- | Does the file exist. -type instance RuleResult GetFileExists = Bool - type instance RuleResult FingerprintSource = Fingerprint -data GetFileExists = GetFileExists - deriving (Eq, Show, Generic) -instance Hashable GetFileExists -instance NFData GetFileExists -instance Binary GetFileExists - data GetFileContents = GetFileContents deriving (Eq, Show, Generic) instance Hashable GetFileContents @@ -122,16 +112,6 @@ fingerprintSourceRule = pure ([], Just fingerprint) where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len -getFileExistsRule :: VFSHandle -> Rules () -getFileExistsRule vfs = - defineEarlyCutoff $ \GetFileExists file -> do - alwaysRerun - res <- liftIO $ handle (\(_ :: IOException) -> return False) $ - (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^ - Dir.doesFileExist (fromNormalizedFilePath file) - return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res)) - - getModificationTimeRule :: VFSHandle -> Rules () getModificationTimeRule vfs = defineEarlyCutoff $ \GetModificationTime file -> do @@ -154,6 +134,8 @@ getModificationTimeRule vfs = -- time spent checking file modifications (which happens on every change) -- from > 0.5s to ~0.15s. -- We might also want to try speeding this up on Windows at some point. + -- TODO leverage DidChangeWatchedFile lsp notifications on clients that + -- support them, as done for GetFileExists getModTime :: FilePath -> IO BS.ByteString getModTime f = #ifdef mingw32_HOST_OS @@ -198,20 +180,11 @@ ideTryIOException fp act = getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer) getFileContents = use_ GetFileContents -getFileExists :: NormalizedFilePath -> Action Bool -getFileExists = - -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute - -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly - -- cached 'No' rather than an exception in the wrong place - use_ GetFileExists - - fileStoreRules :: VFSHandle -> Rules () fileStoreRules vfs = do addIdeGlobal vfs getModificationTimeRule vfs getFileContentsRule vfs - getFileExistsRule vfs fingerprintSourceRule diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index b0b5c5c126..4b17efc882 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -37,7 +37,8 @@ import Development.IDE.Types.Options import Development.IDE.Spans.Calculate import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports -import Development.IDE.Core.FileStore +import Development.IDE.Core.FileExists +import Development.IDE.Core.FileStore (getFileContents, getSourceFingerprint) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.GHC.Util diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs index 971ea52919..fb4028cb64 100644 --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -23,13 +23,15 @@ import Control.Concurrent.Async import Data.Maybe import Development.IDE.Types.Options (IdeOptions(..)) import Control.Monad -import Development.IDE.Core.FileStore +import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules) +import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest import Development.IDE.Types.Logger import Development.Shake import Data.Either.Extra import qualified Language.Haskell.LSP.Messages as LSP import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Types.Capabilities as LSP import Development.IDE.Core.Shake @@ -42,14 +44,15 @@ instance IsIdeGlobal GlobalIdeOptions -- Exposed API -- | Initialise the Compiler Service. -initialise :: Rules () +initialise :: LSP.ClientCapabilities + -> Rules () -> IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Logger -> IdeOptions -> VFSHandle -> IO IdeState -initialise mainRule getLspId toDiags logger options vfs = +initialise caps mainRule getLspId toDiags logger options vfs = shakeOpen getLspId toDiags @@ -63,6 +66,7 @@ initialise mainRule getLspId toDiags logger options vfs = addIdeGlobal $ GlobalIdeOptions options fileStoreRules vfs ofInterestRules + fileExistsRules getLspId caps vfs mainRule writeProfile :: IdeState -> FilePath -> IO () diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs index a2d5377b34..47440d511f 100644 --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -20,6 +20,7 @@ -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake( IdeState, + ShakeExtras(..), getShakeExtras, IdeRule, IdeResult, GetModificationTime(..), shakeOpen, shakeShut, shakeRun, @@ -38,7 +39,8 @@ module Development.IDE.Core.Shake( FileVersion(..), Priority(..), updatePositionMapping, - OnDiskRule(..) + deleteValue, + OnDiskRule(..), ) where import Development.Shake hiding (ShakeValue, doesFileExist) @@ -257,6 +259,16 @@ setValues state key file val = modifyVar_ state $ \vals -> do -- Force to make sure the old HashMap is not retained evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals +-- | Delete the value stored for a given ide build key +deleteValue + :: (Typeable k, Hashable k, Eq k, Show k) + => IdeState + -> k + -> NormalizedFilePath + -> IO () +deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals -> + evaluate $ HMap.delete (file, Key key) vals + -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v)) getValues state key file = do diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs index 9a16b438d1..7aaa3c25a2 100644 --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -2,26 +2,30 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.LSP.Notifications ( setHandlersNotifications ) where -import Language.Haskell.LSP.Types import Development.IDE.LSP.Server -import qualified Language.Haskell.LSP.Core as LSP -import qualified Language.Haskell.LSP.Types as LSP +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as LSP -import Development.IDE.Types.Logger -import Development.IDE.Core.Service -import Development.IDE.Types.Location +import Development.IDE.Core.Service +import Development.IDE.Types.Location +import Development.IDE.Types.Logger -import Control.Monad.Extra -import qualified Data.Set as S +import Control.Monad.Extra +import Data.Foldable as F +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Text as Text -import Development.IDE.Core.FileStore -import Development.IDE.Core.OfInterest +import Development.IDE.Core.FileStore (setSomethingModified) +import Development.IDE.Core.FileExists (modifyFileExists) +import Development.IDE.Core.OfInterest whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () @@ -52,4 +56,17 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x whenUriFile _uri $ \file -> do modifyFilesOfInterest ide (S.delete file) logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri - } + ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $ + \_ ide (DidChangeWatchedFilesParams fileEvents) -> do + let events = + mapMaybe + (\(FileEvent uri ev) -> + (, ev /= FcDeleted) . toNormalizedFilePath + <$> LSP.uriToFilePath uri + ) + ( F.toList fileEvents ) + let msg = Text.pack $ show events + logInfo (ideLogger ide) $ "Files created or deleted: " <> msg + modifyFileExists ide events + setSomethingModified ide + } \ No newline at end of file diff --git a/test/exe/Main.hs b/test/exe/Main.hs index d5a1c63f11..4b6a9246ad 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -20,7 +20,8 @@ import qualified Data.Text as T import Development.IDE.Test import Development.IDE.Test.Runfiles import Development.IDE.Types.Location -import Language.Haskell.LSP.Test +import qualified Language.Haskell.LSP.Test as LSPTest +import Language.Haskell.LSP.Test hiding (openDoc') import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import System.Environment.Blank (setEnv) @@ -1583,7 +1584,8 @@ run s = withTempDir $ \dir -> do -- HIE calls getXgdDirectory which assumes that HOME is set. -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False - runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s + let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + runSessionWithConfig conf cmd lspTestCaps dir s where conf = defaultConfig -- If you uncomment this you can see all logging @@ -1626,3 +1628,10 @@ unitTests = do [ testCase "empty file path" $ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "" ] + +-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events +openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier +openDoc' fp name contents = do + res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents + sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated]) + return res \ No newline at end of file