diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index 87a9727f5..19e416c59 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -71,7 +71,7 @@ import qualified HeaderInfo as Hdr import HscMain (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive) import MkIface import StringBuffer as SB -import TcRnMonad (finalSafeMode, TcGblEnv, tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins, tcg_binds) +import TcRnMonad import TcIface (typecheckIface) import TidyPgm @@ -92,8 +92,8 @@ import System.IO.Extra import Control.Exception (evaluate) import Exception (ExceptionMonad) import TcEnv (tcLookup) -import Data.Time (UTCTime) - +import Data.Time (UTCTime, getCurrentTime) +import Linker (unload) -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule @@ -126,9 +126,10 @@ computePackageDeps env pkg = do typecheckModule :: IdeDefer -> HscEnv + -> Maybe [Linkable] -- ^ linkables not to unload, if Nothing don't unload anything -> ParsedModule -> IO (IdeResult (HscEnv, TcModuleResult)) -typecheckModule (IdeDefer defer) hsc pm = do +typecheckModule (IdeDefer defer) hsc keep_lbls pm = do fmap (\(hsc, res) -> case res of Left d -> (d,Nothing); Right (d,res) -> (d,fmap (hsc,) res)) $ runGhcEnv hsc $ catchSrcErrors "typecheck" $ do @@ -138,9 +139,9 @@ typecheckModule (IdeDefer defer) hsc pm = do modSummary' <- initPlugins modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - tcRnModule $ enableTopLevelWarnings - $ enableUnnecessaryAndDeprecationWarnings - $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + tcRnModule keep_lbls $ enableTopLevelWarnings + $ enableUnnecessaryAndDeprecationWarnings + $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags @@ -148,13 +149,15 @@ typecheckModule (IdeDefer defer) hsc pm = do where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id -tcRnModule :: GhcMonad m => ParsedModule -> m TcModuleResult -tcRnModule pmod = do +tcRnModule :: GhcMonad m => Maybe [Linkable] -> ParsedModule -> m TcModuleResult +tcRnModule keep_lbls pmod = do let ms = pm_mod_summary pmod hsc_env <- getSession let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } (tc_gbl_env, mrn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ + <- liftIO $ do + whenJust keep_lbls $ unload hsc_env_tmp + hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod } @@ -182,24 +185,22 @@ mkHiFileResultCompile :: HscEnv -> TcModuleResult -> ModGuts + -> LinkableType -- ^ use object code or byte code? -> IO (IdeResult HiFileResult) -mkHiFileResultCompile session' tcm simplified_guts = catchErrs $ do +mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do let session = session' { hsc_dflags = ms_hspp_opts ms } ms = pm_mod_summary $ tmrParsed tcm -- give variables unique OccNames (guts, details) <- tidyProgram session simplified_guts - (diags, obj_res) <- generateObjectCode session ms guts - case obj_res of + let genLinkable = case ltype of + ObjectLinkable -> generateObjectCode + BCOLinkable -> generateByteCode + + (diags, res) <- genLinkable session ms guts + case res of Nothing -> do -#if MIN_GHC_API_VERSION(8,10,0) - let !partial_iface = force (mkPartialIface session details simplified_guts) - final_iface <- mkFullIface session partial_iface -#else - (final_iface,_) <- mkIface session Nothing details simplified_guts -#endif - let mod_info = HomeModInfo final_iface details Nothing - pure (diags, Just $ HiFileResult ms mod_info) + pure (diags, Nothing) Just linkable -> do #if MIN_GHC_API_VERSION(8,10,0) let !partial_iface = force (mkPartialIface session details simplified_guts) @@ -221,7 +222,7 @@ mkHiFileResultCompile session' tcm simplified_guts = catchErrs $ do initPlugins :: GhcMonad m => ModSummary -> m ModSummary initPlugins modSummary = do session <- getSession - dflags <- liftIO $ initializePlugins session (ms_hspp_opts modSummary) + dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary return modSummary{ms_hspp_opts = dflags} -- | Whether we should run the -O0 simplifier when generating core. @@ -261,7 +262,8 @@ generateObjectCode hscEnv summary guts = do catchSrcErrors "object" $ do session <- getSession let dot_o = ml_obj_file (ms_location summary) - let session' = session { hsc_dflags = (hsc_dflags session) { outputFile = Just dot_o }} + mod = ms_mod summary + session' = session { hsc_dflags = (hsc_dflags session) { outputFile = Just dot_o }} fp = replaceExtension dot_o "s" liftIO $ createDirectoryIfMissing True (takeDirectory fp) (warnings, dot_o_fp) <- @@ -275,7 +277,10 @@ generateObjectCode hscEnv summary guts = do fp compileFile session' StopLn (outputFilename, Just (As False)) let unlinked = DotO dot_o_fp - let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked] + -- Need time to be the modification time for recompilation checking + t <- liftIO $ getModificationTime dot_o_fp + let linkable = LM t mod [unlinked] + pure (map snd warnings, linkable) generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) @@ -293,7 +298,9 @@ generateByteCode hscEnv summary guts = do (_tweak summary) #endif let unlinked = BCOs bytecode sptEntries - let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked] + time <- liftIO getCurrentTime + let linkable = LM time (ms_mod summary) [unlinked] + pure (map snd warnings, linkable) demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule @@ -479,7 +486,7 @@ loadModuleHome -> HscEnv -> HscEnv loadModuleHome mod_info e = - e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info } + e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info, hsc_type_env_var = Nothing } where mod_name = moduleName $ mi_module $ hm_iface mod_info @@ -717,10 +724,10 @@ loadInterface :: MonadIO m => HscEnv -> ModSummary -> SourceModified - -> Bool - -> (Bool -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface + -> Maybe LinkableType + -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface -> m ([FileDiagnostic], Maybe HiFileResult) -loadInterface session ms sourceMod objNeeded regen = do +loadInterface session ms sourceMod linkableNeeded regen = do res <- liftIO $ checkOldIface session ms sourceMod Nothing case res of (UpToDate, Just iface) @@ -740,19 +747,20 @@ loadInterface session ms sourceMod objNeeded regen = do -- one-shot mode. | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod -> do - linkable <- - if objNeeded - then liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms) - else pure Nothing - let objUpToDate = not objNeeded || case linkable of + 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 session iface linkable return ([], Just $ HiFileResult ms hmi) - else regen objNeeded - (_reason, _) -> regen objNeeded + else regen linkableNeeded + (_reason, _) -> regen linkableNeeded mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo mkDetailsFromIface session iface linkable = do diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs index 733d80f26..580b7053b 100644 --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -27,7 +27,7 @@ import Development.Shake import GHC.Generics (Generic) import Module (InstalledUnitId) -import HscTypes (ModGuts, hm_iface, HomeModInfo) +import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings @@ -35,6 +35,10 @@ import Development.IDE.Import.FindImports (ArtifactsLocation) import Data.ByteString (ByteString) import Language.Haskell.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) +import qualified Data.ByteString.Char8 as BS + +data LinkableType = ObjectLinkable | BCOLinkable + deriving (Eq,Ord,Show) -- NOTATION -- Foo+ means Foo for the dependencies @@ -54,9 +58,6 @@ type instance RuleResult GetDependencies = TransitiveDependencies type instance RuleResult GetModuleGraph = DependencyInformation --- | Does this module need object code? -type instance RuleResult NeedsObjectCode = Bool - data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets @@ -111,7 +112,12 @@ data HiFileResult = HiFileResult } hiFileFingerPrint :: HiFileResult -> ByteString -hiFileFingerPrint = fingerprintToBS . getModuleHash . hirModIface +hiFileFingerPrint hfr = ifaceBS <> linkableBS + where + ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes + linkableBS = case hm_linkable $ hirHomeMod hfr of + Nothing -> "" + Just l -> BS.pack $ show $ linkableTime l hirModIface :: HiFileResult -> ModIface hirModIface = hm_iface . hirHomeMod @@ -213,11 +219,14 @@ instance Hashable GetLocatedImports instance NFData GetLocatedImports instance Binary GetLocatedImports -data NeedsObjectCode = NeedsObjectCode +-- | Does this module need to be compiled? +type instance RuleResult NeedsCompilation = Bool + +data NeedsCompilation = NeedsCompilation deriving (Eq, Show, Typeable, Generic) -instance Hashable NeedsObjectCode -instance NFData NeedsObjectCode -instance Binary NeedsObjectCode +instance Hashable NeedsCompilation +instance NFData NeedsCompilation +instance Binary NeedsCompilation data GetDependencyInformation = GetDependencyInformation deriving (Eq, Show, Typeable, Generic) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index beaaddcfe..c2bfcb537 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -96,6 +96,8 @@ import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HM import TcRnMonad (tcg_dependent_files) import Data.IORef +import Control.Concurrent.Extra +import Module -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -606,8 +608,11 @@ typeCheckRuleDefinition typeCheckRuleDefinition hsc pm = do setPriority priorityTypeCheck IdeOptions { optDefer = defer } <- getIdeOptions + + linkables_to_keep <- currentLinkables + addUsageDependencies $ fmap (second (fmap snd)) $ liftIO $ - typecheckModule defer hsc pm + typecheckModule defer hsc (Just linkables_to_keep) pm where addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) addUsageDependencies a = do @@ -617,6 +622,16 @@ typeCheckRuleDefinition hsc pm = do void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) return r +-- | 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 = do + ShakeExtras{compiledLinkables} <- getShakeExtras + hm <- liftIO $ readVar compiledLinkables + pure $ map go $ moduleEnvToList hm + where + go (mod, time) = LM time mod [] + -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 @@ -691,8 +706,8 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do Nothing -> return (Nothing, (diags_session, Nothing)) Just session -> do sourceModified <- use_ IsHiFileStable f - needsObj <- use_ NeedsObjectCode f - r <- loadInterface (hscEnv session) ms sourceModified needsObj (regenerateHiFile session f) + linkableType <- getLinkableType f + r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f) case r of (diags, Just x) -> do let fp = Just (hiFileFingerPrint x) @@ -716,8 +731,8 @@ isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do let imports = fmap artifactFilePath . snd <$> fileImports deps <- uses_ IsHiFileStable (catMaybes imports) pure $ if all (== SourceUnmodifiedAndStable) deps - then SourceUnmodifiedAndStable - else SourceUnmodified + then SourceUnmodifiedAndStable + else SourceUnmodified return (Just (BS.pack $ show sourceModified), ([], Just sourceModified)) getModSummaryRule :: Rules () @@ -779,14 +794,14 @@ getModIfaceRule :: Rules () getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do #if !defined(GHC_LIB) fileOfInterest <- use_ IsFileOfInterest f - case fileOfInterest of + res@(_,(_,mhmi)) <- case fileOfInterest of IsFOI status -> do -- Never load from disk for files of interest tmr <- use_ TypeCheck f - needsObj <- use_ NeedsObjectCode f + linkableType <- getLinkableType f hsc <- hscEnv <$> use_ GhcSessionDeps f let compile = fmap ([],) $ use GenerateCore f - (diags, !hiFile) <- compileToObjCodeIfNeeded hsc needsObj compile tmr + (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr let fp = hiFileFingerPrint <$> hiFile hiDiags <- case hiFile of Just hiFile @@ -798,16 +813,22 @@ getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do hiFile <- use GetModIfaceFromDisk f let fp = hiFileFingerPrint <$> hiFile return (fp, ([], hiFile)) + + -- Record the linkable so we know not to unload it + whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do + ShakeExtras{compiledLinkables} <- getShakeExtras + liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time + pure res #else tm <- use_ TypeCheck f hsc <- hscEnv <$> use_ GhcSessionDeps f - (diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc False (error "can't compile with ghc-lib") tm + (diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc Nothing (error "can't compile with ghc-lib") tm let fp = hiFileFingerPrint <$> hiFile return (fp, (diags, hiFile)) #endif -regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Bool -> Action ([FileDiagnostic], Maybe HiFileResult) -regenerateHiFile sess f objNeeded = do +regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) +regenerateHiFile sess f compNeeded = do let hsc = hscEnv sess -- After parsing the module remove all package imports referring to -- these packages as we have already dealt with what they map to. @@ -837,7 +858,7 @@ regenerateHiFile sess f objNeeded = do let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr -- Bang pattern is important to avoid leaking 'tmr' - (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc objNeeded compile tmr + (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of @@ -857,16 +878,16 @@ regenerateHiFile sess f objNeeded = do type CompileMod m = m (IdeResult ModGuts) -- | HscEnv should have deps included already -compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Bool -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult) -compileToObjCodeIfNeeded hsc False _ tmr = liftIO $ do +compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult) +compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do res <- mkHiFileResultNoCompile hsc tmr pure ([], Just $! res) -compileToObjCodeIfNeeded hsc True getGuts tmr = do +compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do (diags, mguts) <- getGuts case mguts of Nothing -> pure (diags, Nothing) Just guts -> do - (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts + (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType pure (diags++diags', res) getClientSettingsRule :: Rules () @@ -875,15 +896,21 @@ getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do settings <- clientSettings <$> getIdeConfiguration return (BS.pack . show . hash $ settings, settings) -needsObjectCodeRule :: Rules () -needsObjectCodeRule = defineEarlyCutoff $ \NeedsObjectCode file -> do +-- | For now we always use bytecode +getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) +getLinkableType f = do + needsComp <- use_ NeedsCompilation f + pure $ if needsComp then Just BCOLinkable else Nothing + +needsCompilationRule :: Rules () +needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do (ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file -- A file needs object code if it uses TH or any file that depends on it uses TH res <- if uses_th_qq ms then pure True -- Treat as False if some reverse dependency header fails to parse - else anyM (fmap (fromMaybe False) . use NeedsObjectCode) . maybe [] (immediateReverseDependencies file) + else anyM (fmap (fromMaybe False) . use NeedsCompilation) . maybe [] (immediateReverseDependencies file) =<< useNoFile GetModuleGraph pure (Just $ BS.pack $ show $ hash res, ([], Just res)) where @@ -910,7 +937,7 @@ mainRule = do getClientSettingsRule getHieAstsRule getBindingsRule - needsObjectCodeRule + needsCompilationRule generateCoreRule getImportMapRule diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs index a1d57e7ae..d0b5e9764 100644 --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -126,6 +126,7 @@ import UniqSupply import PrelInfo import Data.Int (Int64) import qualified Data.HashSet as HSet +import Module (ModuleEnv, emptyModuleEnv) -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras @@ -164,6 +165,8 @@ data ShakeExtras = ShakeExtras ,exportsMap :: Var ExportsMap -- | A work queue for actions added via 'runInShakeSession' ,actionQueue :: ActionQueue + -- | Tracks which linkables are current, so we don't need to unload them + ,compiledLinkables :: Var (ModuleEnv UTCTime) } -- | A mapping of module name to known files @@ -434,6 +437,8 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer actionQueue <- newQueue + compiledLinkables <- newVar emptyModuleEnv + pure (ShakeExtras{..}, cancel progressAsync) (shakeDbM, shakeClose) <- shakeOpenDatabase diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs index 25a8deb65..5b4143124 100644 --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -47,9 +47,11 @@ module Development.IDE.GHC.Compat( #if MIN_GHC_API_VERSION(8,10,0) module GHC.Hs.Extension, + module LinkerTypes, #else module HsExtension, noExtField, + linkableTime, #endif module GHC, @@ -65,6 +67,10 @@ module Development.IDE.GHC.Compat( ) where +#if MIN_GHC_API_VERSION(8,10,0) +import LinkerTypes +#endif + import StringBuffer import DynFlags import Fingerprint (Fingerprint) diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs index 7f8cd29b5..ed6fd53b8 100644 --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -90,7 +90,7 @@ produceCompletions = do , pm_extra_src_files = [] -- src imports not allowed , pm_annotations = mempty } - tm <- liftIO $ typecheckModule (IdeDefer True) env pm + tm <- liftIO $ typecheckModule (IdeDefer True) env Nothing pm case tm of (_, Just (_,tcm)) -> do cdata <- liftIO $ cacheDataProducer env tcm parsedDeps diff --git a/test/exe/Main.hs b/test/exe/Main.hs index ddd1ca317..2db10b969 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -2472,9 +2472,9 @@ thTests = _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB return () - , ignoreInWindowsForGHC88 (thReloadingTest `xfail` "expect broken (#672)") + , thReloadingTest -- Regression test for https://github.com/digital-asset/ghcide/issues/614 - , thLinkingTest `xfail` "expect broken" + , thLinkingTest , testSessionWait "findsTHIdentifiers" $ do let sourceA = T.unlines @@ -2534,6 +2534,7 @@ thReloadingTest = testCase "reloading-th-test" $ withoutStackEnv $ runWithExtraF expectDiagnostics [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")]) ] closeDoc adoc