From 50ee7fad49f75708d900a9737a77e3273127b6be Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 8 May 2021 16:31:41 +0100 Subject: [PATCH] Replace the unsafe getmodtime with safe posix calls (#1778) * Replace the unsafe getmodtime with the one from the posix package We don't need the 2X faster but unsafe getmodtime anymore since GetModificationTime is not called O(N) anymore, but only O(FOI) times, where N is the number of known targets and FOI is the number of files of interest * Fix Windows build * redundant imports * add a test --- ghcide/ghcide.cabal | 2 - ghcide/src/Development/IDE/Core/FileStore.hs | 53 +++++--------------- ghcide/src/Development/IDE/Core/RuleTypes.hs | 8 ++- ghcide/test/exe/Main.hs | 18 +++++++ 4 files changed, 34 insertions(+), 47 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index fb1c792053..7ba852f08b 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -108,8 +108,6 @@ library else build-depends: unix - c-sources: - cbits/getmodtime.c default-extensions: ApplicativeDo diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 5fc511d327..fb780c94b2 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -19,7 +19,8 @@ module Development.IDE.Core.FileStore( resetInterfaceStore, getModificationTimeImpl, addIdeGlobal, - getFileContentsImpl + getFileContentsImpl, + getModTime ) where import Control.Concurrent.STM (atomically) @@ -31,22 +32,22 @@ import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.Either.Extra import qualified Data.HashMap.Strict as HM -import Data.Int (Int64) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Rope.UTF16 as Rope import qualified Data.Text as T import Data.Time +import Data.Time.Clock.POSIX import Development.IDE.Core.OfInterest (OfInterestVar (..), getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.GHC.Orphans () +import Development.IDE.Graph import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import Development.IDE.Graph import HieDb.Create (deleteMissingRealFiles) import Ide.Plugin.Config (CheckParents (..)) import System.IO.Error @@ -54,14 +55,7 @@ import System.IO.Error #ifdef mingw32_HOST_OS import qualified System.Directory as Dir #else -import Data.Time.Clock.System (SystemTime (MkSystemTime), - systemToUTCTime) -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 +import System.Posix.Files ( getFileStatus, modificationTimeHiRes) #endif import qualified Development.IDE.Types.Logger as L @@ -126,7 +120,7 @@ getModificationTimeImpl :: VFSHandle (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) getModificationTimeImpl vfs isWatched missingFileDiags file = do let file' = fromNormalizedFilePath file - let wrap time@(l,s) = (Just $ LBS.toStrict $ B.encode time, ([], Just $ ModificationTime l s)) + let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file case mbVirtual of Just (virtualFileVersion -> ver) -> do @@ -192,38 +186,17 @@ resetFileStore ideState changes = mask $ \_ -> -- 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 (Int64, Int64) +getModTime :: FilePath -> IO POSIXTime getModTime f = #ifdef mingw32_HOST_OS - do time <- Dir.getModificationTime f - let !day = fromInteger $ toModifiedJulianDay $ utctDay time - !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time - pure (day, dayTime) + utcTimeToPOSIXSeconds <$> Dir.getModificationTime f #else - withCString f $ \f' -> - alloca $ \secPtr -> - alloca $ \nsecPtr -> do - Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr - CTime sec <- peek secPtr - CLong nsec <- peek nsecPtr - pure (sec, 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 + modificationTimeHiRes <$> getFileStatus f #endif modificationTime :: FileVersion -> Maybe UTCTime -modificationTime VFSVersion{} = Nothing -modificationTime (ModificationTime large small) = Just $ internalTimeToUTCTime large small - -internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime -internalTimeToUTCTime large small = -#ifdef mingw32_HOST_OS - UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small) -#else - systemToUTCTime $ MkSystemTime large (fromIntegral small) -#endif +modificationTime VFSVersion{} = Nothing +modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix getFileContentsRule :: VFSHandle -> Rules () getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file @@ -260,8 +233,8 @@ getFileContents f = do liftIO $ case foi of IsFOI Modified{} -> getCurrentTime _ -> do - (large,small) <- getModTime $ fromNormalizedFilePath f - pure $ internalTimeToUTCTime large small + posix <- getModTime $ fromNormalizedFilePath f + pure $ posixSecondsToUTCTime posix return (modTime, txt) fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index ff1282abdf..228a063cea 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -21,14 +21,15 @@ import Data.Aeson.Types (Value) import Data.Binary import Data.Hashable import qualified Data.Map as M +import Data.Time.Clock.POSIX import Data.Typeable import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util +import Development.IDE.Graph import Development.IDE.Import.DependencyInformation import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets -import Development.IDE.Graph import GHC.Generics (Generic) import HscTypes (HomeModInfo, @@ -39,7 +40,6 @@ import HscTypes (HomeModInfo, import qualified Data.Binary as B import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS -import Data.Int (Int64) import Data.Text (Text) import Data.Time import Development.IDE.Import.FindImports (ArtifactsLocation) @@ -295,9 +295,7 @@ type instance RuleResult GetModificationTime = FileVersion data FileVersion = VFSVersion !Int - | ModificationTime - !Int64 -- ^ Large unit (platform dependent, do not make assumptions) - !Int64 -- ^ Small unit (platform dependent, do not make assumptions) + | ModificationTime !POSIXTime deriving (Show, Generic) instance NFData FileVersion diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 00916920d9..707ea4e999 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -102,6 +102,9 @@ import Data.IORef.Extra (atomicModifyIORef_) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Text.Regex.TDFA ((=~)) import qualified Progress +import Development.IDE.Core.FileStore (getModTime) +import Control.Concurrent (threadDelay) +import Text.Printf (printf) waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -5492,9 +5495,24 @@ unitTests = do actualOrder <- liftIO $ readIORef orderRef liftIO $ actualOrder @?= reverse [(1::Int)..20] + , testCase "timestamps have millisecond resolution" $ do + resolution_us <- findResolution_us 1 + let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us + assertBool msg (resolution_us <= 1000) , Progress.tests ] +findResolution_us :: Int -> IO Int +findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" +findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do + writeFile f "" + threadDelay delay_us + writeFile f' "" + t <- getModTime f + t' <- getModTime f' + if t /= t' then return delay_us else findResolution_us (delay_us * 10) + + testIde :: IDE.Arguments -> Session () -> IO () testIde arguments session = do config <- getConfigFromEnv