mirror of
https://github.com/haskell/ghcide.git
synced 2024-12-02 08:53:07 +03:00
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
GitHub
parent
cf143ea22d
commit
71c88dc521
@ -645,7 +645,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
|
||||
setLinkerOptions :: DynFlags -> DynFlags
|
||||
setLinkerOptions df = df {
|
||||
ghcLink = LinkInMemory
|
||||
, hscTarget = HscAsm
|
||||
, hscTarget = HscNothing
|
||||
, ghcMode = CompManager
|
||||
}
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user