diff --git a/.hlint.yaml b/.hlint.yaml index a04776b87f..17f0b0baa5 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -55,6 +55,7 @@ within: - Development.IDE.Core.Shake - Development.IDE.GHC.Util + - Development.IDE.Core.FileStore - Development.IDE.Plugin.CodeAction.Util - Development.IDE.Graph.Internal.Database - Development.IDE.Graph.Internal.Paths diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 82addbdf12..d491766cc2 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -70,7 +70,7 @@ import Data.Time (UTCTime (..)) import Data.Tuple.Extra (dupe) import Data.Unique as Unique import Debug.Trace -import Development.IDE.Core.FileStore (resetInterfaceStore) +import Development.IDE.Core.FileStore (resetInterfaceStore, shareFilePath) import Development.IDE.Core.Preprocessor import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake @@ -435,6 +435,30 @@ tcRnModule hsc_env tc_helpers pmod = do -- anywhere. So we zero it out. -- The field is not serialized or deserialised from disk, so we don't need to remove it -- while reading an iface from disk, only if we just generated an iface in memory +-- + + + +-- | See https://github.com/haskell/haskell-language-server/issues/3450 +-- GHC's recompilation avoidance in the presense of TH is less precise than +-- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information +-- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH] +filterUsages :: [Usage] -> [Usage] +#if MIN_VERSION_ghc(9,3,0) +filterUsages = filter $ \case UsageHomeModuleInterface{} -> False + _ -> True +#else +filterUsages = id +#endif + +-- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744 +shareUsages :: ModIface -> ModIface +shareUsages iface = iface {mi_usages = usages} + where usages = map go (mi_usages iface) + go usg@UsageFile{} = usg {usg_file_path = fp} + where !fp = shareFilePath (usg_file_path usg) + go usg = usg + mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do @@ -444,7 +468,7 @@ mkHiFileResultNoCompile session tcm = do details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv iface' <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv - let iface = iface' { mi_globals = Nothing } -- See Note [Clearing mi_globals after generating an iface] + let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface] pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing mkHiFileResultCompile @@ -486,7 +510,7 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface' <- mkFullIface session partial_iface #endif - let final_iface = final_iface' {mi_globals = Nothing} -- See Note [Clearing mi_globals after generating an iface] + let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface] -- Write the core file now core_file <- case mguts of @@ -1462,7 +1486,8 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do regenerate linkableNeeded case (mb_checked_iface, recomp_iface_reqd) of - (Just iface, UpToDate) -> do + (Just iface', UpToDate) -> do + let iface = shareUsages iface' details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface -- parse the runtime dependencies from the annotations let runtime_deps diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 860ad11939..f3906ced6b 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -18,6 +18,7 @@ module Development.IDE.Core.FileStore( getModTime, isWatchSupported, registerFileWatches, + shareFilePath, Log(..) ) where @@ -28,6 +29,8 @@ import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HashMap +import Data.IORef import qualified Data.Text as T import qualified Data.Text.Utf16.Rope as Rope import Data.Time @@ -76,6 +79,7 @@ import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Capabilities as LSP import Language.LSP.VFS import System.FilePath +import System.IO.Unsafe data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath @@ -297,3 +301,17 @@ isWatchSupported = do , Just True <- _dynamicRegistration -> True | otherwise -> False + +filePathMap :: IORef (HashMap.HashMap FilePath FilePath) +filePathMap = unsafePerformIO $ newIORef HashMap.empty +{-# NOINLINE filePathMap #-} + +shareFilePath :: FilePath -> FilePath +shareFilePath k = unsafePerformIO $ do + atomicModifyIORef' filePathMap $ \km -> + let new_key = HashMap.lookup k km + in case new_key of + Just v -> (km, v) + Nothing -> (HashMap.insert k k km, k) +{-# NOINLINE shareFilePath #-} + diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 83195acd2a..49f2869a3b 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -43,6 +43,8 @@ module Development.IDE.GHC.Compat( myCoreToStgExpr, #endif + Usage(..), + FastStringCompat, bytesFS, mkFastStringByteString, @@ -167,9 +169,9 @@ import GHC.Runtime.Context (icInteractiveModule) import GHC.Unit.Home.ModInfo (HomePackageTable, lookupHpt) #if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods)) +import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..)) #else -import GHC.Unit.Module.Deps (Dependencies(dep_mods)) +import GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..)) #endif #else import GHC.CoreToByteCode (coreExprToBCOs)