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
This commit is contained in:
wz1000 2020-10-19 11:48:54 +05:30 committed by GitHub
parent cf143ea22d
commit 71c88dc521
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 172 additions and 109 deletions

View File

@ -645,7 +645,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions df = df {
ghcLink = LinkInMemory
, hscTarget = HscAsm
, hscTarget = HscNothing
, ghcMode = CompManager
}

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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