From 71c88dc521b639d20913c98a7e68443c9c8795c1 Mon Sep 17 00:00:00 2001 From: wz1000 Date: Mon, 19 Oct 2020 11:48:54 +0530 Subject: [PATCH] Switch back to bytecode (#873) * Switch back to bytecode * return a HomeModInfo even if we can't generate a linkable * set target to HscNothing * add rule for GetModIfaceWithoutLinkable * use IdeGlobal for compiled linkables --- session-loader/Development/IDE/Session.hs | 2 +- src/Development/IDE/Core/Compile.hs | 136 ++++++++++------------ src/Development/IDE/Core/RuleTypes.hs | 37 ++++-- src/Development/IDE/Core/Rules.hs | 93 +++++++++++---- src/Development/IDE/GHC/Compat.hs | 6 + src/Development/IDE/Plugin/Completions.hs | 2 +- test/exe/Main.hs | 5 +- 7 files changed, 172 insertions(+), 109 deletions(-) diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs index 94c140933..ce0471c46 100644 --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -645,7 +645,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do setLinkerOptions :: DynFlags -> DynFlags setLinkerOptions df = df { ghcLink = LinkInMemory - , hscTarget = HscAsm + , hscTarget = HscNothing , ghcMode = CompManager } diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index 87a9727f5..65be2d941 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -26,8 +26,7 @@ module Development.IDE.Core.Compile , getModSummaryFromImports , loadHieFile , loadInterface - , loadDepModule - , loadModuleHome + , loadModulesHome , setupFinderCache , getDocsBatch , lookupName @@ -71,7 +70,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 +91,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 +125,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 +138,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 +148,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,33 +184,28 @@ 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 - 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) - Just linkable -> do + let genLinkable = case ltype of + ObjectLinkable -> generateObjectCode + BCOLinkable -> generateByteCode + + (diags, linkable) <- genLinkable session ms guts #if MIN_GHC_API_VERSION(8,10,0) - let !partial_iface = force (mkPartialIface session details simplified_guts) - final_iface <- mkFullIface session partial_iface + let !partial_iface = force (mkPartialIface session details simplified_guts) + final_iface <- mkFullIface session partial_iface #else - (final_iface,_) <- mkIface session Nothing details simplified_guts + (final_iface,_) <- mkIface session Nothing details simplified_guts #endif - let mod_info = HomeModInfo final_iface details (Just linkable) - pure (diags, Just $! HiFileResult ms mod_info) + let mod_info = HomeModInfo final_iface details linkable + pure (diags, Just $! HiFileResult ms mod_info) + where dflags = hsc_dflags session' source = "compile" @@ -221,7 +218,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 +258,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 +273,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 +294,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 @@ -443,56 +446,44 @@ handleGenerationErrors' dflags source action = -- | Initialise the finder cache, dependencies should be topologically -- sorted. -setupFinderCache :: GhcMonad m => [ModSummary] -> m () -setupFinderCache mss = do - session <- getSession - - -- set the target and module graph in the session - let graph = mkModuleGraph mss - setSession session { hsc_mod_graph = graph } +setupFinderCache :: [ModSummary] -> HscEnv -> IO HscEnv +setupFinderCache mss session = do -- Make modules available for others that import them, -- by putting them in the finder cache. let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims + -- set the target and module graph in the session + graph = mkModuleGraph mss + -- We have to create a new IORef here instead of modifying the existing IORef as -- it is shared between concurrent compilations. - prevFinderCache <- liftIO $ readIORef $ hsc_FC session + prevFinderCache <- readIORef $ hsc_FC session let newFinderCache = foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache $ zip ims ifrs - newFinderCacheVar <- liftIO $ newIORef $! newFinderCache - modifySession $ \s -> s { hsc_FC = newFinderCacheVar } + newFinderCacheVar <- newIORef $! newFinderCache + + pure $ session { hsc_FC = newFinderCacheVar, hsc_mod_graph = graph } --- | Load a module, quickly. Input doesn't need to be desugared. +-- | Load modules, quickly. Input doesn't need to be desugared. -- A module must be loaded before dependent modules can be typechecked. -- This variant of loadModuleHome will *never* cause recompilation, it just -- modifies the session. --- -- The order modules are loaded is important when there are hs-boot files. -- In particular you should make sure to load the .hs version of a file after the -- .hs-boot version. -loadModuleHome - :: HomeModInfo +loadModulesHome + :: [HomeModInfo] -> HscEnv -> HscEnv -loadModuleHome mod_info e = - e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info } +loadModulesHome mod_infos e = + e { hsc_HPT = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] + , hsc_type_env_var = Nothing } where - mod_name = moduleName $ mi_module $ hm_iface mod_info - --- | Load module interface. -loadDepModuleIO :: HomeModInfo -> HscEnv -> IO HscEnv -loadDepModuleIO mod_info hsc = do - return $ loadModuleHome mod_info hsc - -loadDepModule :: GhcMonad m => HomeModInfo -> m () -loadDepModule mod_info = do - e <- getSession - e' <- liftIO $ loadDepModuleIO mod_info e - setSession e' + mod_name = moduleName . mi_module . hm_iface -- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's -- name and its imports. @@ -717,10 +708,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 +731,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..f7b779535 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 @@ -179,6 +185,10 @@ type instance RuleResult GetModIfaceFromDisk = HiFileResult -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult +-- | Get a module interface details, without the Linkable +-- For better early cuttoff +type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult + data FileOfInterestStatus = OnDisk | Modified deriving (Eq, Show, Typeable, Generic) instance Hashable FileOfInterestStatus @@ -213,11 +223,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) @@ -290,6 +303,12 @@ instance Hashable GetModIface instance NFData GetModIface instance Binary GetModIface +data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIfaceWithoutLinkable +instance NFData GetModIfaceWithoutLinkable +instance Binary GetModIfaceWithoutLinkable + data IsFileOfInterest = IsFileOfInterest deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterest diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index beaaddcfe..d9b367440 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 + compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction + 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 @@ -667,18 +682,22 @@ ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq) ghcSessionDepsDefinition file = do env <- use_ GhcSession file let hsc = hscEnv env + (ms,_) <- useWithStale_ GetModSummaryWithoutTimestamps file (deps,_) <- useWithStale_ GetDependencies file let tdeps = transitiveModuleDeps deps - ifaces <- uses_ GetModIface tdeps + uses_th_qq = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags + dflags = ms_hspp_opts ms + ifaces <- if uses_th_qq + then uses_ GetModIface tdeps + else uses_ GetModIfaceWithoutLinkable tdeps -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. -- Long-term we might just want to change the order returned by GetDependencies let inLoadOrder = reverse (map hirHomeMod ifaces) - (session',_) <- liftIO $ runGhcEnv hsc $ do - setupFinderCache (map hirModSummary ifaces) - mapM_ loadDepModule inLoadOrder + session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' [] return ([], Just res) @@ -691,8 +710,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 +735,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 +798,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 +817,29 @@ 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 + compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction + 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 +getModIfaceWithoutLinkableRule :: Rules () +getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do + mhfr <- use GetModIface f + let mhfr' = fmap (\x -> x{ hirHomeMod = (hirHomeMod x){ hm_linkable = Just (error msg) } }) mhfr + msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f + pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr')) + +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 +869,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 +889,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,24 +907,36 @@ 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 uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags +-- | Tracks which linkables are current, so we don't need to unload them +newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } +instance IsIdeGlobal CompiledLinkables + -- | A rule that wires per-file rules together mainRule :: Rules () mainRule = do + linkables <- liftIO $ newVar emptyModuleEnv + addIdeGlobal $ CompiledLinkables linkables getParsedModuleRule getLocatedImportsRule getDependencyInformationRule @@ -903,6 +947,7 @@ mainRule = do loadGhcSession getModIfaceFromDiskRule getModIfaceRule + getModIfaceWithoutLinkableRule getModSummaryRule isHiFileStableRule getModuleGraphRule @@ -910,7 +955,7 @@ mainRule = do getClientSettingsRule getHieAstsRule getBindingsRule - needsObjectCodeRule + needsCompilationRule generateCoreRule getImportMapRule 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 6c5a04c06..9c2b99eb9 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -2504,9 +2504,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 @@ -2566,6 +2566,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