diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index d71bdbeef3..ef51c971a9 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -208,11 +208,11 @@ jobs: name: Test hls-explicit-imports-plugin test suite run: cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS" || cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-explicit-imports-plugin --test-options="$TEST_OPTS" - - if: matrix.test + - if: matrix.test && matrix.os != 'windows-latest' name: Test hls-call-hierarchy-plugin test suite run: cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS" || cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS" - - if: matrix.test + - if: matrix.test && matrix.os != 'windows-latest' name: Test hls-rename-plugin test suite run: cabal test hls-rename-plugin --test-options="$TEST_OPTS" || cabal test hls-rename-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-rename-plugin --test-options="$TEST_OPTS" diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index f76577da13..6679e2cda1 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -17,8 +17,7 @@ import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (. isWorkspaceFile) import Development.IDE.Core.OfInterest as X (getFilesOfInterestUntracked) import Development.IDE.Core.RuleTypes as X -import Development.IDE.Core.Rules as X (IsHiFileStable (..), - getClientConfigAction, +import Development.IDE.Core.Rules as X (getClientConfigAction, getParsedModule) import Development.IDE.Core.Service as X (runAction) import Development.IDE.Core.Shake as X (FastResult (..), diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index fb519121e8..99938bd430 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -26,14 +26,56 @@ module Development.IDE.Core.Compile , getModSummaryFromImports , loadHieFile , loadInterface + , RecompilationInfo(..) , loadModulesHome , getDocsBatch , lookupName - ,mergeEnvs) where + , mergeEnvs + ) where +import Control.Concurrent.Extra +import Control.Concurrent.STM.Stats hiding (orElse) +import Control.DeepSeq (force, liftRnf, rnf, rwhnf) +import Control.Exception (evaluate) +import Control.Exception.Safe +import Control.Lens hiding (List) +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Trans.Except +import Data.Aeson (toJSON) +import Data.Bifunctor (first, second) +import Data.Binary +import qualified Data.Binary as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce +import qualified Data.DList as DL +import Data.Functor +import qualified Data.HashMap.Strict as HashMap +import Data.IORef +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List.Extra +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Time (UTCTime (..), + getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Tuple.Extra (dupe) +import Data.Unique as Unique +import Debug.Trace import Development.IDE.Core.Preprocessor import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake +import Development.IDE.Core.Tracing (withTrace) +import Development.IDE.GHC.Compat hiding (loadInterface, + parseHeader, parseModule, + tcRnModule, writeHieFile) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util @@ -42,26 +84,25 @@ import Development.IDE.Spans.Common import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options - -import Development.IDE.GHC.Compat hiding (loadInterface, - parseHeader, parseModule, - tcRnModule, writeHieFile) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as GHC -import qualified Development.IDE.GHC.Compat.Util as Util - +import GHC (ForeignHValue, + GetDocsFailure (..), + mgModSummaries, + parsedSource) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Serialized import HieDb - +import qualified Language.LSP.Server as LSP import Language.LSP.Types (DiagnosticTag (..)) +import qualified Language.LSP.Types as LSP +import System.Directory +import System.FilePath +import System.IO.Extra (fixIO, newTempFileWithin) +import Unsafe.Coerce -#if MIN_VERSION_ghc(8,10,0) -import Control.DeepSeq (force, liftRnf, rnf, rwhnf) -#else -import Control.DeepSeq (liftRnf, rnf, rwhnf) +#if !MIN_VERSION_ghc(8,10,0) import ErrUtils #endif - #if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice #else @@ -69,60 +110,17 @@ import TcSplice #endif #if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Types.Error as Error -#endif - -import Control.Exception (evaluate) -import Control.Exception.Safe -import Control.Lens hiding (List) -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.Trans.Except -import Data.Bifunctor (first, second) -import qualified Data.ByteString as BS -import qualified Data.DList as DL -import Data.IORef -import qualified Data.IntMap.Strict as IntMap -import Data.List.Extra -import qualified Data.Map.Strict as Map -import Data.Maybe -import qualified Data.Text as T -import Data.Time (UTCTime, getCurrentTime) -import qualified GHC.LanguageExtensions as LangExt -import System.Directory -import System.FilePath -import System.IO.Extra (fixIO, newTempFileWithin) - --- GHC API imports --- GHC API imports -#if MIN_VERSION_ghc(9,2,0) +import Development.IDE.GHC.Compat.Util (emptyUDFM, fsLit, + plusUDFM_C) import GHC (Anchor (anchor), EpaComment (EpaComment), EpaCommentTok (EpaBlockComment, EpaLineComment), epAnnComments, priorComments) +import qualified GHC as G import GHC.Hs (LEpaComment) +import qualified GHC.Types.Error as Error #endif -import GHC (GetDocsFailure (..), - mgModSummaries, - parsedSource) - -import Control.Concurrent.Extra -import Control.Concurrent.STM.Stats hiding (orElse) -import Data.Aeson (toJSON) -import Data.Binary -import Data.Coerce -import Data.Functor -import qualified Data.HashMap.Strict as HashMap -import Data.IntMap (IntMap) -import Data.Map (Map) -import Data.Tuple.Extra (dupe) -import Data.Unique as Unique -import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM_C) -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP -import Unsafe.Coerce -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule @@ -151,7 +149,7 @@ computePackageDeps env pkg = do typecheckModule :: IdeDefer -> HscEnv - -> [Linkable] -- ^ linkables not to unload + -> ModuleEnv UTCTime -- ^ linkables not to unload -> ParsedModule -> IO (IdeResult TcModuleResult) typecheckModule (IdeDefer defer) hsc keep_lbls pm = do @@ -179,16 +177,110 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id --- | Add a Hook to the DynFlags which captures and returns the --- typechecked splices before they are run. This information --- is used for hover. -captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices) -captureSplices env k = do +-- | Install hooks to capture the splices as well as the runtime module dependencies +captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName) +captureSplicesAndDeps env k = do splice_ref <- newIORef mempty - res <- k (hscSetHooks (addSpliceHook splice_ref (hsc_hooks env)) env) + dep_ref <- newIORef emptyUniqSet + res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env) splices <- readIORef splice_ref - return (res, splices) + needed_mods <- readIORef dep_ref + return (res, splices, needed_mods) where + addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks + addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) } + + -- We want to record exactly which linkables/modules the typechecker needed at runtime + -- This is useful for recompilation checking. + -- See Note [Recompilation avoidance in the presence of TH] + -- + -- From hscCompileCoreExpr' in GHC + -- To update, copy hscCompileCoreExpr' (the implementation of + -- hscCompileCoreExprHook) verbatim, and add code to extract all the free + -- names in the compiled bytecode, recording the modules that those names + -- come from in the IORef,, as these are the modules on whose implementation + -- we depend. + -- + -- Only compute direct dependencies instead of transitive dependencies. + -- It is much cheaper to store the direct dependencies, we can compute + -- the transitive ones when required. + -- Also only record dependencies from the home package + compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue + compile_bco_hook var hsc_env srcspan ds_expr + = do { let dflags = hsc_dflags hsc_env + + {- Simplify it -} + ; simpl_expr <- simplifyExpr dflags hsc_env ds_expr + + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + + +#if MIN_VERSION_ghc(9,2,0) + ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", + ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", + ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } + ; let ictxt = hsc_IC hsc_env + + ; (binding_id, stg_expr, _, _) <- + myCoreToStgExpr (hsc_logger hsc_env) + (hsc_dflags hsc_env) + ictxt + (icInteractiveModule ictxt) + iNTERACTIVELoc + prepd_expr + + {- Convert to BCOs -} + ; bcos <- byteCodeGen hsc_env + (icInteractiveModule ictxt) + stg_expr + [] Nothing + ; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos + , Just mod <- [nameModule_maybe n] -- Names from other modules + , not (isWiredInName n) -- Exclude wired-in names + , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package + ] + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + {- load it -} + ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos + ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs) +#else + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs hsc_env + (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + + ; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos) + , Just mod <- [nameModule_maybe n] -- Names from other modules + , not (isWiredInName n) -- Exclude wired-in names + , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package + ] + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos +#endif + + ; modifyIORef' var (unionUniqSets needed_mods) + ; return hval } + + + -- | Add a Hook to the DynFlags which captures and returns the + -- typechecked splices before they are run. This information + -- is used for hover. addSpliceHook :: IORef Splices -> Hooks -> Hooks addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } @@ -216,15 +308,20 @@ captureSplices env k = do pure $ f aw' -tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult +tcRnModule + :: HscEnv + -> ModuleEnv UTCTime -- ^ Program linkables not to unload + -> ParsedModule + -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do let ms = pm_mod_summary pmod hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env + hpt = hsc_HPT hsc_env - unload hsc_env_tmp keep_lbls + unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls - ((tc_gbl_env, mrn_info), splices) - <- liftIO $ captureSplices hsc_env_tmp $ \hsc_env_tmp -> + ((tc_gbl_env', mrn_info), splices, mods) + <- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp -> do hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, @@ -232,7 +329,29 @@ tcRnModule hsc_env keep_lbls pmod = do let rn_info = case mrn_info of Just x -> x Nothing -> error "no renamed info tcRnModule" - pure (TcModuleResult pmod rn_info tc_gbl_env splices False) + + -- Compute the transitive set of linkables required + mods_transitive = go emptyUniqSet mods + where + go seen new + | isEmptyUniqSet new = seen + | otherwise = go seen' new' + where + seen' = seen `unionUniqSets` new + new' = new_deps `minusUniqSet` seen' + new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info + | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)] + + -- The linkables we depend on at runtime are the transitive closure of 'mods' + -- restricted to the home package + -- See Note [Recompilation avoidance in the presence of TH] + mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported + + -- Serialize mod_env so we can read it from the interface + mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time)) + (moduleEnvToList mod_env) + tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } + pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env) mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do @@ -247,7 +366,7 @@ mkHiFileResultNoCompile session tcm = do (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv #endif let mod_info = HomeModInfo iface details Nothing - pure $! mkHiFileResult ms mod_info + pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm) mkHiFileResultCompile :: HscEnv @@ -285,7 +404,7 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do (final_iface,_) <- mkIface session Nothing details simplified_guts #endif let mod_info = HomeModInfo final_iface details linkable - pure (diags, Just $! mkHiFileResult ms mod_info) + pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)) where dflags = hsc_dflags session' @@ -940,55 +1059,210 @@ loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile loadHieFile ncu f = do GHC.hie_file_result <$> GHC.readHieFile ncu f + +{- Note [Recompilation avoidance in the presence of TH] + +Most versions of GHC we currently support don't have a working implementation of +code unloading for object code, and no version of GHC supports this on certain +platforms like Windows. This makes it completely infeasible for interactive use, +as symbols from previous compiles will shadow over all future compiles. + +This means that we need to use bytecode when generating code for Template +Haskell. Unfortunately, we can't serialize bytecode, so we will always need +to recompile when the IDE starts. However, we can put in place a much tighter +recompilation avoidance scheme for subsequent compiles: + +1. If the source file changes, then we always need to recompile + a. For files of interest, we will get explicit `textDocument/change` events + that will let us invalidate our build products + b. For files we read from disk, we can detect source file changes by + comparing the `mtime` of the source file with the build product (.hi/.o) file + on disk. +2. If GHC's recompilation avoidance scheme based on interface file hashes says + that we need to recompile, the we need to recompile. +3. If the file in question requires code generation then, we need to recompile + if we don't have the appropriate kind of build products. + a. If we already have the build products in memory, and the conditions 1 and + 2 above hold, then we don't need to recompile + b. If we are generating object code, then we can also search for it on + disk and ensure it is up to date. Notably, we did _not_ previously re-use + old bytecode from memory when `hls-graph`/`shake` decided to rebuild the + `HiFileResult` for some reason + +4. If the file in question used Template Haskell on the previous compile, then + we need to recompile if any `Linkable` in its transitive closure changed. This + sounds bad, but it is possible to make some improvements. + In particular, we only need to recompile if any of the `Linkable`s actually used during the previous compile change. + +How can we tell if a `Linkable` was actually used while running some TH? + +GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as +it is being compiled and linked. We can inspect the bytecode to see which +`Linkable` dependencies it requires, and record this for use in +recompilation checking. +We record all the home package modules of the free names that occur in the +bytecode. The `Linkable`s required are then the transitive closure of these +modules in the home-package environment. This is the same scheme as used by +GHC to find the correct things to link in before running bytecode. + +This works fine if we already have previous build products in memory, but +what if we are reading an interface from disk? Well, we can smuggle in the +necessary information (linkable `Module`s required as well as the time they +were generated) using `Annotation`s, which provide a somewhat general purpose +way to serialise arbitrary information along with interface files. + +Then when deciding whether to recompile, we need to check that the versions +of the linkables used during a previous compile match whatever is currently +in the HPT. +-} + +data RecompilationInfo m + = RecompilationInfo + { source_version :: FileVersion + , old_value :: Maybe (HiFileResult, FileVersion) + , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion) + , regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface + } + -- | Retuns an up-to-date module interface, regenerating if needed. -- Assumes file exists. -- Requires the 'HscEnv' to be set up with dependencies +-- See Note [Recompilation avoidance in the presence of TH] loadInterface :: (MonadIO m, MonadMask m) => HscEnv -> ModSummary - -> SourceModified -> Maybe LinkableType - -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface + -> RecompilationInfo m -> m ([FileDiagnostic], Maybe HiFileResult) -loadInterface session ms sourceMod linkableNeeded regen = do +loadInterface session ms linkableNeeded RecompilationInfo{..} = do let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session - res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing - case res of - (UpToDate, Just iface) - -- If the module used TH splices when it was last - -- compiled, then the recompilation check is not - -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481) - -- and we must ignore - -- it. However, if the module is stable (none of - -- the modules it depends on, directly or - -- indirectly, changed), then we *can* skip - -- recompilation. This is why the SourceModified - -- type contains SourceUnmodifiedAndStable, and - -- it's pretty important: otherwise ghc --make - -- would always recompile TH modules, even if - -- nothing at all has changed. Stability is just - -- the same check that make is doing for us in - -- one-shot mode. - | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod - -> do - linkable <- case linkableNeeded of - Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms) - _ -> pure Nothing - - -- We don't need to regenerate if the object is up do date, or we don't need one - let objUpToDate = isNothing linkableNeeded || case linkable of - Nothing -> False - Just (LM obj_time _ _) -> obj_time > ms_hs_date ms - if objUpToDate - then do - hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable - return ([], Just $ mkHiFileResult ms hmi) - else regen linkableNeeded - (_reason, _) -> withTrace "regenerate interface" $ \setTag -> do - setTag "Module" $ moduleNameString $ moduleName $ ms_mod ms - setTag "Reason" $ showReason _reason - regen linkableNeeded + mb_old_iface = hm_iface . hirHomeMod . fst <$> old_value + mb_old_version = snd <$> old_value + + obj_file = ml_obj_file (ms_location ms) + + !mod = ms_mod ms + + mb_dest_version <- case mb_old_version of + Just ver -> pure $ Just ver + Nothing -> get_file_version $ toNormalizedFilePath' $ case linkableNeeded of + Just ObjectLinkable -> ml_obj_file (ms_location ms) + _ -> ml_hi_file (ms_location ms) + + -- The source is modified if it is newer than the destination + let sourceMod = case mb_dest_version of + Nothing -> SourceModified -- desitination file doesn't exist, assume modified source + Just dest_version + | source_version <= dest_version -> SourceUnmodified + | otherwise -> SourceModified + + -- If mb_old_iface is nothing then checkOldIface will load it for us + (recomp_iface_reqd, mb_checked_iface) + <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface + + + let + (recomp_obj_reqd, mb_linkable) = case linkableNeeded of + Nothing -> (UpToDate, Nothing) + Just linkableType -> case old_value of + -- We don't have an old result + Nothing -> recompMaybeBecause "missing" + -- We have an old result + Just (old_hir, old_file_version) -> + case hm_linkable $ hirHomeMod old_hir of + Nothing -> recompMaybeBecause "missing [not needed before]" + Just old_lb + | Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used + , old_file_version /= source_version -> recompMaybeBecause "out of date" + + -- Check if it is the correct type + -- Ideally we could use object-code in case we already have + -- it when we are generating bytecode, but this is difficult because something + -- below us may be bytecode, and object code can't depend on bytecode + | ObjectLinkable <- linkableType, isObjectLinkable old_lb + -> (UpToDate, Just old_lb) + + | BCOLinkable <- linkableType , not (isObjectLinkable old_lb) + -> (UpToDate, Just old_lb) + + | otherwise -> recompMaybeBecause "missing [wrong type]" + where + recompMaybeBecause msg = case linkableType of + BCOLinkable -> (RecompBecause ("bytecode "++ msg), Nothing) + ObjectLinkable -> case mb_dest_version of -- The destination file should be the object code + Nothing -> (RecompBecause ("object code "++ msg), Nothing) + Just disk_obj_version@(ModificationTime t) -> + -- If we make it this far, assume that the object code on disk is up to date + -- This assertion works because of the sourceMod check + assert (disk_obj_version >= source_version) + (UpToDate, Just $ LM (posixSecondsToUTCTime t) mod [DotO obj_file]) + Just (VFSVersion _) -> error "object code in vfs" + + let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do + setTag "Module" $ moduleNameString $ moduleName mod + setTag "Reason" $ showReason _reason + liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason) + regenerate linkableNeeded + + case (mb_checked_iface, recomp_iface_reqd <> recomp_obj_reqd) of + (Just iface, UpToDate) -> do + -- Force it because we don't want to retain old modsummaries or linkables + lb <- liftIO $ evaluate $ force mb_linkable + + -- If we have an old value, just return it + case old_value of + Just (old_hir, _) + | Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir) + -> do_regenerate msg + | otherwise -> return ([], Just old_hir) + Nothing -> do + hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb + -- parse the runtime dependencies from the annotations + let runtime_deps + | not (mi_used_th iface) = emptyModuleEnv + | otherwise = parseRuntimeDeps (md_anns (hm_details hmi)) + return ([], Just $ mkHiFileResult ms hmi runtime_deps) + (_, _reason) -> do_regenerate _reason + +-- | ModDepTime is stored as an annotation in the iface to +-- keep track of runtime dependencies +newtype ModDepTime = ModDepTime UTCTime + +deserializeModDepTime :: [Word8] -> ModDepTime +deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of + (a,b) -> UTCTime (toEnum a) (toEnum b) + +serializeModDepTime :: ModDepTime -> [Word8] +serializeModDepTime (ModDepTime l) = LBS.unpack $ + B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l) + +-- | Find the runtime dependencies by looking at the annotations +-- serialized in the iface +parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime +parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns + where + go (Annotation (ModuleTarget mod) payload) + | Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload + = Just (mod, t) + go _ = Nothing + +-- | checkLinkableDependencies compares the linkables in the home package to +-- the runtime dependencies of the module, to check if any of them are out of date +-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH +-- See Note [Recompilation avoidance in the presence of TH] +checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired +checkLinkableDependencies hpt runtime_deps + | isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile + | otherwise = Just $ + RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date)) + where + out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of + Nothing -> False + Just hm -> case hm_linkable hm of + Nothing -> False + Just lm -> linkableTime lm /= time) + runtime_deps showReason :: RecompileRequired -> String showReason UpToDate = "UpToDate" diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index c6e9430cdb..3683104745 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -138,6 +138,9 @@ data TcModuleResult = TcModuleResult -- ^ Typechecked splice information , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? + , tmrRuntimeModules :: !(ModuleEnv UTCTime) + -- ^ Which modules did we need at runtime while compiling this file? + -- Used for recompilation checking in the presence of TH } instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed @@ -158,13 +161,15 @@ data HiFileResult = HiFileResult -- ^ Fingerprint for the ModIface , hirLinkableFp :: ByteString -- ^ Fingerprint for the Linkable + , hirRuntimeModules :: !(ModuleEnv UTCTime) + -- ^ same as tmrRuntimeModules } hiFileFingerPrint :: HiFileResult -> ByteString hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp -mkHiFileResult :: ModSummary -> HomeModInfo -> HiFileResult -mkHiFileResult hirModSummary hirHomeMod = HiFileResult{..} +mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult +mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..} where hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes hirLinkableFp = case hm_linkable hirHomeMod of diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index d4a51dd97d..29325813d5 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -30,7 +30,6 @@ module Development.IDE.Core.Rules( usePropertyAction, -- * Rules CompiledLinkables(..), - IsHiFileStable(..), getParsedModuleRule, getParsedModuleWithCommentsRule, getLocatedImportsRule, @@ -42,7 +41,6 @@ module Development.IDE.Core.Rules( getModIfaceFromDiskRule, getModIfaceRule, getModSummaryRule, - isHiFileStableRule, getModuleGraphRule, knownFilesRule, getClientSettingsRule, @@ -100,7 +98,7 @@ import Data.Tuple.Extra import Development.IDE.Core.Compile import Development.IDE.Core.FileExists hiding (LogShake, Log) import Development.IDE.Core.FileStore (getFileContents, - resetInterfaceStore, modificationTime) + resetInterfaceStore) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (LogShake, Log) import Development.IDE.Core.PositionMapping @@ -121,7 +119,6 @@ import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph -import Development.IDE.Graph.Classes import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports import qualified Development.IDE.Spans.AtPoint as AtPoint @@ -131,7 +128,6 @@ import Development.IDE.Types.Diagnostics as Diag import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC.Generics (Generic) import qualified GHC.LanguageExtensions as LangExt import qualified HieDb import Ide.Plugin.Config @@ -156,8 +152,9 @@ import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriori import qualified Development.IDE.Core.Shake as Shake import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) import qualified Development.IDE.Types.Logger as Logger +import qualified Development.IDE.Types.Shake as Shake -data Log +data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath | LogLoadingHieFile !NormalizedFilePath @@ -407,7 +404,7 @@ type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Act execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) execRawDepM act = execStateT act - ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty + ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty , IntMap.empty ) @@ -434,6 +431,11 @@ rawDependencyInformation fs = do let al = modSummaryToArtifactsLocation f msum -- Get a fresh FilePathId for the new file fId <- getFreshFid al + -- Record this module and its location + whenJust msum $ \ms -> + modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId) + (ShowableModuleName (moduleName $ ms_mod ms)) + (rawModuleNameMap rd)}) -- Adding an edge to the bootmap so we can make sure to -- insert boot nodes before the real files. addBootMap al fId @@ -684,13 +686,10 @@ typeCheckRuleDefinition hsc pm = do -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. -- Doesn't actually contain the code, since we don't need it to unload -currentLinkables :: Action [Linkable] +currentLinkables :: Action (ModuleEnv UTCTime) currentLinkables = do compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction - hm <- liftIO $ readVar compiledLinkables - pure $ map go $ moduleEnvToList hm - where - go (mod, time) = LM time mod [] + liftIO $ readVar compiledLinkables loadGhcSession :: Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules () loadGhcSession recorder ghcSessionDepsConfig = do @@ -768,15 +767,25 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. getModIfaceFromDiskRule :: Recorder (WithPriority Log) -> Rules () -getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIfaceFromDisk f -> do +getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithOldValue $ \GetModIfaceFromDisk f old -> do ms <- msrModSummary <$> use_ GetModSummary f mb_session <- use GhcSessionDeps f case mb_session of Nothing -> return (Nothing, ([], Nothing)) Just session -> do - sourceModified <- use_ IsHiFileStable f linkableType <- getLinkableType f - r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms) + ver <- use_ GetModificationTime f + let m_old = case old of + Shake.Succeeded (Just old_version) v -> Just (v, old_version) + Shake.Stale _ (Just old_version) v -> Just (v, old_version) + _ -> Nothing + recompInfo = RecompilationInfo + { source_version = ver + , old_value = m_old + , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} + , regenerate = regenerateHiFile session f ms + } + r <- loadInterface (hscEnv session) ms linkableType recompInfo case r of (diags, Nothing) -> return (Nothing, (diags, Nothing)) (diags, Just x) -> do @@ -827,31 +836,6 @@ getModIfaceFromDiskAndIndexRule recorder = return (Just x) -isHiFileStableRule :: Recorder (WithPriority Log) -> Rules () -isHiFileStableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsHiFileStable f -> do - ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f - let hiFile = toNormalizedFilePath' - $ Compat.ml_hi_file $ ms_location ms - mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile - modVersion <- use_ GetModificationTime f - sourceModified <- case mbHiVersion of - Nothing -> pure SourceModified - Just x -> - if modificationTime x < modificationTime modVersion - then pure SourceModified - else do - fileImports <- use_ GetLocatedImports f - let imports = fmap artifactFilePath . snd <$> fileImports - deps <- uses_ IsHiFileStable (catMaybes imports) - pure $ if all (== SourceUnmodifiedAndStable) deps - then SourceUnmodifiedAndStable - else SourceUnmodified - return (Just (summarize sourceModified), Just sourceModified) - where - summarize SourceModified = BS.singleton 1 - summarize SourceUnmodified = BS.singleton 2 - summarize SourceUnmodifiedAndStable = BS.singleton 3 - displayTHWarning :: LspT c IO () displayTHWarning | not isWindows && not hostIsDynamic = do @@ -1148,7 +1132,6 @@ mainRule recorder RulesConfig{..} = do getModIfaceFromDiskAndIndexRule recorder getModIfaceRule recorder getModSummaryRule recorder - isHiFileStableRule recorder getModuleGraphRule recorder knownFilesRule recorder getClientSettingsRule recorder @@ -1170,13 +1153,3 @@ mainRule recorder RulesConfig{..} = do persistentHieFileRule recorder persistentDocMapRule persistentImportMapRule - --- | Given the path to a module src file, this rule returns True if the --- corresponding `.hi` file is stable, that is, if it is newer --- than the src file, and all its dependencies are stable too. -data IsHiFileStable = IsHiFileStable - deriving (Eq, Show, Typeable, Generic) -instance Hashable IsHiFileStable -instance NFData IsHiFileStable - -type instance RuleResult IsHiFileStable = SourceModified diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b3b0b9adde..10056da603 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1034,6 +1034,7 @@ data RuleBody k v { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v) } + | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) -- | Define a new Rule with early cutoff defineEarlyCutoff @@ -1046,12 +1047,12 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe let diagnostics diags = do traceDiagnostics diags updateFileDiagnostics recorder file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags - defineEarlyCutoff' diagnostics (==) key file old mode $ op key file + defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics diags = do traceDiagnostics diags mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags - defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file + defineEarlyCutoff' diagnostics (==) key file old mode $ const $ second (mempty,) <$> op key file defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \ traceDiagnostics -> do @@ -1059,7 +1060,13 @@ defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = traceDiagnostics diags mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags defineEarlyCutoff' diagnostics newnessCheck key file old mode $ - second (mempty,) <$> build key file + const $ second (mempty,) <$> build key file +defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do + extras <- getShakeExtras + let diagnostics diags = do + traceDiagnostics diags + updateFileDiagnostics recorder file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + defineEarlyCutoff' diagnostics (==) key file old mode $ op key file defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do @@ -1080,7 +1087,7 @@ defineEarlyCutoff' -> NormalizedFilePath -> Maybe BS.ByteString -> RunMode - -> Action (Maybe BS.ByteString, IdeResult v) + -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics cmp key file old mode action = do ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras @@ -1103,8 +1110,13 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do res <- case val of Just res -> return res Nothing -> do + staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case + Nothing -> Failed False + Just (Succeeded ver v, _) -> Stale Nothing ver v + Just (Stale d ver v, _) -> Stale d ver v + Just (Failed b, _) -> Failed b (bs, (diags, res)) <- actionCatch - (do v <- action; liftIO $ evaluate $ force v) $ + (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) @@ -1116,11 +1128,6 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do (bs, res) <- case res of Nothing -> do - staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case - Nothing -> Failed False - Just (Succeeded ver v, _) -> Stale Nothing ver v - Just (Stale d ver v, _) -> Stale d ver v - Just (Failed b, _) -> Failed b pure (toShakeValue ShakeStale bs, staleV) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded modTime v) liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 76c5c055dd..61a679d287 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -20,6 +20,7 @@ module Development.IDE.GHC.Compat( reLocA, getMessages', pattern PFailedWithErrorMessages, + isObjectLinkable, #if !MIN_VERSION_ghc(9,0,1) RefMap, @@ -28,6 +29,7 @@ module Development.IDE.GHC.Compat( #if MIN_VERSION_ghc(9,2,0) extendModSummaryNoDeps, emsModSummary, + myCoreToStgExpr, #endif nodeInfo', @@ -69,6 +71,39 @@ module Development.IDE.GHC.Compat( Option (..), runUnlit, runPp, + + -- * Recompilation avoidance + hscCompileCoreExprHook, + CoreExpr, + simplifyExpr, + tidyExpr, + emptyTidyEnv, + corePrepExpr, + lintInteractiveExpr, + icInteractiveModule, + HomePackageTable, + lookupHpt, + Dependencies(dep_mods), + bcoFreeNames, + ModIfaceAnnotation, + pattern Annotation, + AnnTarget(ModuleTarget), + extendAnnEnvList, + module UniqDSet, + module UniqSet, + module UniqDFM, + getDependentMods, +#if MIN_VERSION_ghc(9,2,0) + loadExpr, + byteCodeGen, + bc_bcos, + loadDecls, + hscInterp, + expectJust, +#else + coreExprToBCOs, + linkExpr, +#endif ) where import Development.IDE.GHC.Compat.Core @@ -84,7 +119,48 @@ import Development.IDE.GHC.Compat.Util import GHC hiding (HasSrcSpan, ModLocation, RealSrcSpan, getLoc, - lookupName) + lookupName, exprType) +#if MIN_VERSION_ghc(9,0,0) +import GHC.Driver.Hooks (hscCompileCoreExprHook) +import GHC.Core (CoreExpr, CoreProgram) +import qualified GHC.Core.Opt.Pipeline as GHC +import GHC.Core.Tidy (tidyExpr) +import GHC.Types.Var.Env (emptyTidyEnv) +import qualified GHC.CoreToStg.Prep as GHC +import GHC.Core.Lint (lintInteractiveExpr) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable) +import GHC.Runtime.Context (icInteractiveModule) +import GHC.Unit.Module.Deps (Dependencies(dep_mods)) +import GHC.Linker.Types (isObjectLinkable) +import GHC.Linker.Loader (loadExpr) +#else +import GHC.CoreToByteCode (coreExprToBCOs) +import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable) +import GHC.Runtime.Linker (linkExpr) +#endif +import GHC.ByteCode.Asm (bcoFreeNames) +import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) +import GHC.Types.Unique.DSet as UniqDSet +import GHC.Types.Unique.Set as UniqSet +import GHC.Types.Unique.DFM as UniqDFM +#else +import Hooks (hscCompileCoreExprHook) +import CoreSyn (CoreExpr) +import qualified SimplCore as GHC +import CoreTidy (tidyExpr) +import VarEnv (emptyTidyEnv) +import CorePrep (corePrepExpr) +import CoreLint (lintInteractiveExpr) +import ByteCodeGen (coreExprToBCOs) +import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods)) +import Linker (linkExpr) +import ByteCodeAsm (bcoFreeNames) +import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) +import UniqDSet +import UniqSet +import UniqDFM +#endif #if MIN_VERSION_ghc(9,0,0) import GHC.Data.StringBuffer @@ -142,6 +218,67 @@ import qualified Data.Set as S import Bag (unitBag) #endif +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.CostCentre +import GHC.Stg.Syntax +import GHC.Types.IPE +import GHC.Stg.Syntax +import GHC.Types.IPE +import GHC.Types.CostCentre +import GHC.Core +import GHC.Builtin.Uniques +import GHC.Runtime.Interpreter +import GHC.StgToByteCode +import GHC.Stg.Pipeline +import GHC.ByteCode.Types +import GHC.Linker.Loader (loadDecls) +import GHC.Data.Maybe +import GHC.CoreToStg +#endif + +type ModIfaceAnnotation = Annotation + +#if MIN_VERSION_ghc(9,2,0) +myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext + -> Module -> ModLocation -> CoreExpr + -> IO ( Id + , [StgTopBinding] + , InfoTableProvMap + , CollectedCCs ) +myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do + {- Create a temporary binding (just because myCoreToStg needs a + binding for the stg2stg step) -} + let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") + (mkPseudoUniqueE 0) + Many + (exprType prepd_expr) + (stg_binds, prov_map, collected_ccs) <- + myCoreToStg logger + dflags + ictxt + this_mod + ml + [NonRec bco_tmp_id prepd_expr] + return (bco_tmp_id, stg_binds, prov_map, collected_ccs) + +myCoreToStg :: Logger -> DynFlags -> InteractiveContext + -> Module -> ModLocation -> CoreProgram + -> IO ( [StgTopBinding] -- output program + , InfoTableProvMap + , CollectedCCs ) -- CAF cost centre info (declared and used) +myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do + let (stg_binds, denv, cost_centre_info) + = {-# SCC "Core2Stg" #-} + coreToStg dflags this_mod ml prepd_binds + + stg_binds2 + <- {-# SCC "Stg2Stg" #-} + stg2stg logger dflags ictxt this_mod stg_binds + + return (stg_binds2, denv, cost_centre_info) +#endif + + #if !MIN_VERSION_ghc(9,2,0) reLoc :: Located a -> Located a reLoc = id @@ -150,6 +287,23 @@ reLocA :: Located a -> Located a reLocA = id #endif +getDependentMods :: ModIface -> [ModuleName] +#if MIN_VERSION_ghc(9,0,0) +getDependentMods = map gwib_mod . dep_mods . mi_deps +#else +getDependentMods = map fst . dep_mods . mi_deps +#endif + +simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +#if MIN_VERSION_ghc(9,0,0) +simplifyExpr _ = GHC.simplifyExpr + +corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +corePrepExpr _ = GHC.corePrepExpr +#else +simplifyExpr df _ = GHC.simplifyExpr df +#endif + #if !MIN_VERSION_ghc(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 3c28900a26..4eae21c2a3 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -39,6 +39,11 @@ import Data.Aeson import Data.Bifunctor (Bifunctor (..)) import Data.Hashable import Data.String (IsString (fromString)) +#if MIN_VERSION_ghc(9,0,0) +import GHC.ByteCode.Types +#else +import ByteCodeTypes +#endif -- Orphan instances for types from the GHC API. instance Show CoreModule where show = prettyPrint @@ -49,7 +54,12 @@ instance Show ModDetails where show = const "" instance NFData ModDetails where rnf = rwhnf instance NFData SafeHaskellMode where rnf = rwhnf instance Show Linkable where show = prettyPrint -instance NFData Linkable where rnf = rwhnf +instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c +instance NFData Unlinked where + rnf (DotO f) = rnf f + rnf (DotA f) = rnf f + rnf (DotDLL f) = rnf f + rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b instance Show PackageFlag where show = prettyPrint instance Show InteractiveImport where show = prettyPrint instance Show PackageName where show = prettyPrint diff --git a/ghcide/src/Development/IDE/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs index b1d261f16d..cc621764eb 100644 --- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs +++ b/ghcide/src/Development/IDE/Import/DependencyInformation.hs @@ -129,6 +129,7 @@ data RawDependencyInformation = RawDependencyInformation -- need to add edges between .hs-boot and .hs so that the .hs files -- appear later in the sort. , rawBootMap :: !BootIdMap + , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName) } deriving Show data DependencyInformation = @@ -220,15 +221,12 @@ processDependencyInformation RawDependencyInformation{..} = { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps , depReverseModuleDeps = reverseModuleDeps - , depModuleNames = IntMap.fromList $ coerce moduleNames + , depModuleNames = rawModuleNameMap , depPathIdMap = rawPathIdMap , depBootMap = rawBootMap } where resultGraph = buildResultGraph rawImports (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph - moduleNames :: [(FilePathId, ModuleName)] - moduleNames = - [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports] successEdges :: [(FilePathId, [FilePathId])] successEdges = map diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 22c8e66901..6444b8869e 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -33,7 +33,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, isNothing, mapMaybe) import qualified Data.Text as T -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (Annotation) import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.Common diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index dc58fd9d0b..905a386cda 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -31,7 +31,6 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics import HieDb.Types (HieDb) -import Language.LSP.Types import qualified StmContainers.Map as STM import Type.Reflection (SomeTypeRep (SomeTypeRep), pattern App, pattern Con,