Speed up file modification checks (#2317)

Speed up file modification checks

Summary: `getModificationTime` from the `directory` package is really
slow. The `unix` package is faster but still slow. This PR brings the
time spent checking file modifications (which is required on every
change) from ~0.5s to ~0.15s.

BUILD.bazel

@@ -39,7 +39,7 @@ depends = [
     "transformers",
     "unordered-containers",
     "utf8-string",
-]
+] + ([] if is_windows else ["unix"])
 
 hidden = [
     "Development.IDE.Core.Compile",
@@ -69,8 +69,19 @@ da_haskell_library(
     hidden_modules = hidden,
     src_strip_prefix = "src",
     visibility = ["//visibility:public"],
+    deps = [] if is_windows else [":getmodtime"],
 )
 
+# Used in getModificationTimeRule in Development.IDE.Core.FileStore
+cc_library(
+    name = "getmodtime",
+    srcs = glob(["cbits/getmodtime.c"]),
+    copts = [
+        "-Wall",
+        "-Werror",
+    ],
+) if not is_windows else None
+
 da_haskell_library(
     name = "hie-core-public",
     srcs = glob(["src/**/*.hs"]),
@@ -89,6 +100,7 @@ da_haskell_library(
     ],
     src_strip_prefix = "src",
     visibility = ["//visibility:public"],
+    deps = [] if is_windows else [":getmodtime"],
 )
 
 da_haskell_binary(

cbits/getmodtime.c

@@ -0,0 +1,21 @@
+// Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+// SPDX-License-Identifier: Apache-2.0
+
+#include <sys/stat.h>
+#include <time.h>
+int getmodtime(const char* pathname, time_t* sec, long* nsec) {
+    struct stat s;
+    int r = stat(pathname, &s);
+    if (r != 0) {
+        return r;
+    }
+#ifdef __APPLE__
+    *sec = s.st_mtimespec.tv_sec;
+    *nsec = s.st_mtimespec.tv_nsec;
+#else
+    *sec = s.st_mtim.tv_sec;
+    *nsec = s.st_mtim.tv_nsec;
+#endif
+    return 0;
+}
+

src/Development/IDE/Core/FileStore.hs

@@ -1,6 +1,6 @@
 -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
-
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Development.IDE.Core.FileStore(
@@ -21,7 +21,6 @@ import Control.Concurrent.Extra
 import qualified Data.Map.Strict as Map
 import Data.Maybe
 import qualified Data.Text as T
-import           Data.Time.Clock
 import           Control.Monad.Extra
 import qualified System.Directory as Dir
 import           Development.Shake
@@ -35,7 +34,17 @@ import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import qualified Data.Rope.UTF16 as Rope
-import           Data.Time
+
+#ifdef mingw32_HOST_OS
+import Data.Time
+#else
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.Marshal (alloca)
+import Foreign.Ptr
+import Foreign.Storable
+import qualified System.Posix.Error as Posix
+#endif
 
 import Language.Haskell.LSP.Core
 import Language.Haskell.LSP.VFS
@@ -102,24 +111,46 @@ getFileExistsRule vfs =
         return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
 
 
-showTimePrecise :: UTCTime -> String
-showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
-
 getModificationTimeRule :: VFSHandle -> Rules ()
 getModificationTimeRule vfs =
     defineEarlyCutoff $ \GetModificationTime file -> do
         let file' = fromNormalizedFilePath file
-        let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
+        let wrap time = (Just time, ([], Just $ ModificationTime time))
         alwaysRerun
         mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
         case mbVirtual of
             Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
-            Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file')
+            Nothing -> liftIO $ fmap wrap (getModTime file')
               `catch` \(e :: IOException) -> do
                 let err | isDoesNotExistError e = "File does not exist: " ++ file'
                         | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
                 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
+  where
+    -- Dir.getModificationTime is surprisingly slow since it performs
+    -- a ton of conversions. Since we do not actually care about
+    -- the format of the time, we can get away with something cheaper.
+    -- For now, we only try to do this on Unix systems where it seems to get the
+    -- 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.
+    getModTime :: FilePath -> IO BS.ByteString
+    getModTime f =
+#ifdef mingw32_HOST_OS
+        do time <- Dir.getModificationTime f
+           pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
+#else
+        withCString f $ \f' ->
+        alloca $ \secPtr ->
+        alloca $ \nsecPtr -> do
+            Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
+            sec <- peek secPtr
+            nsec <- peek nsecPtr
+            pure $! BS.pack $ show sec <> "." <> show nsec
 
+-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
+-- as doing the FFI call ourselves :(.
+foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
+#endif
 
 getFileContentsRule :: VFSHandle -> Rules ()
 getFileContentsRule vfs =

src/Development/IDE/Core/Shake.hs

@@ -582,7 +582,10 @@ instance NFData   GetModificationTime
 -- | Get the modification time of a file.
 type instance RuleResult GetModificationTime = FileVersion
 
-data FileVersion = VFSVersion Int | ModificationTime UTCTime
+-- | We store the modification time as a ByteString since we need
+-- a ByteString anyway for Shake and we do not care about how times
+-- are represented.
+data FileVersion = VFSVersion Int | ModificationTime BS.ByteString
     deriving (Show, Generic)
 
 instance NFData FileVersion