Skip to content

Commit

Permalink
Fix performance of getFileExists (haskell/ghcide#322)
Browse files Browse the repository at this point in the history
* 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
  • Loading branch information
pepeiborra authored and cocreature committed Jan 21, 2020
1 parent 53e7bfc commit 281794e
Show file tree
Hide file tree
Showing 9 changed files with 270 additions and 54 deletions.
6 changes: 3 additions & 3 deletions exe/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand Down Expand Up @@ -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
Expand Down
13 changes: 13 additions & 0 deletions ghcide.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
187 changes: 187 additions & 0 deletions src/Development/IDE/Core/FileExists.hs
Original file line number Diff line number Diff line change
@@ -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] ]
37 changes: 5 additions & 32 deletions src/Development/IDE/Core/FileStore.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,8 @@
{-# LANGUAGE TypeFamilies #-}

module Development.IDE.Core.FileStore(
getFileExists, getFileContents,
getFileContents,
getVirtualFile,
setBufferModified,
setSomethingModified,
fileStoreRules,
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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


Expand Down
3 changes: 2 additions & 1 deletion src/Development/IDE/Core/Rules.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
10 changes: 7 additions & 3 deletions src/Development/IDE/Core/Service.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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
Expand All @@ -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 ()
Expand Down

0 comments on commit 281794e

Please sign in to comment.