mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-10-26 17:32:57 +03:00
Generate bytecode/object code on demand
Adds a new rule `GetLinkable` which is called on demand by hscCompileCoreExprHook whenever a linkable is required for a splice. Adds a MonadUnliftIO instance for Action to faciliate the above We write Core Files whenever a linkable could potentially be required for a file (i.e it is in the transitive closure of a module that uses TH/compile time code execution) However, we only generate byte/object code when such a linkable is really required by a splice (i.e. the module is in the transitive closure of any symbol called from a splice). No linkables are stored in `HiFileResult`. If a linkable is required, then it must be obtained via a call to `GetLinkable`. Also use hashes to do fine grained recompilation checking for TH instead of mod times. This simplifies recompilation checking quite a bit.
This commit is contained in:
parent
ae3d178fc3
commit
c047b052b1
@ -31,6 +31,9 @@ module Development.IDE.Core.Compile
|
||||
, getDocsBatch
|
||||
, lookupName
|
||||
, mergeEnvs
|
||||
, ml_core_file
|
||||
, coreFileToLinkable
|
||||
, TypecheckHelpers(..)
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Extra
|
||||
@ -45,9 +48,7 @@ import Control.Monad.Trans.Except
|
||||
import Data.Aeson (toJSON)
|
||||
import Data.Bifunctor (first, second)
|
||||
import Data.Binary
|
||||
import qualified Data.Binary as B
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Coerce
|
||||
import qualified Data.DList as DL
|
||||
import Data.Functor
|
||||
@ -60,9 +61,7 @@ import Data.Map (Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (UTCTime (..),
|
||||
getCurrentTime)
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
||||
import Data.Time (UTCTime (..))
|
||||
import Data.Tuple.Extra (dupe)
|
||||
import Data.Unique as Unique
|
||||
import Debug.Trace
|
||||
@ -81,14 +80,12 @@ import Development.IDE.GHC.Error
|
||||
import Development.IDE.GHC.Orphans ()
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.GHC.Warnings
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.GHC.CoreFile
|
||||
import GHC (ForeignHValue,
|
||||
GetDocsFailure (..),
|
||||
mgModSummaries,
|
||||
parsedSource)
|
||||
import qualified GHC.LanguageExtensions as LangExt
|
||||
import GHC.Serialized
|
||||
@ -121,8 +118,6 @@ import TcSplice
|
||||
import HscTypes
|
||||
#endif
|
||||
|
||||
import Development.IDE.GHC.Compat.Util (emptyUDFM, fsLit,
|
||||
plusUDFM_C)
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC (Anchor (anchor),
|
||||
EpaComment (EpaComment),
|
||||
@ -133,6 +128,7 @@ import qualified GHC as G
|
||||
import GHC.Hs (LEpaComment)
|
||||
import qualified GHC.Types.Error as Error
|
||||
#endif
|
||||
import GHC (ModuleGraph, mgLookupModule, mgModSummaries)
|
||||
import qualified Control.Monad.Trans.State.Strict as S
|
||||
import Data.Generics.Schemes
|
||||
import Data.Generics.Aliases
|
||||
@ -162,12 +158,18 @@ computePackageDeps env pkg = do
|
||||
T.pack $ "unknown package: " ++ show pkg]
|
||||
Just pkgInfo -> return $ Right $ unitDepends pkgInfo
|
||||
|
||||
data TypecheckHelpers
|
||||
= TypecheckHelpers
|
||||
{ getLinkablesToKeep :: !(IO (ModuleEnv UTCTime))
|
||||
, getLinkables :: !([NormalizedFilePath] -> IO [LinkableResult])
|
||||
}
|
||||
|
||||
typecheckModule :: IdeDefer
|
||||
-> HscEnv
|
||||
-> ModuleEnv UTCTime -- ^ linkables not to unload
|
||||
-> TypecheckHelpers
|
||||
-> ParsedModule
|
||||
-> IO (IdeResult TcModuleResult)
|
||||
typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
|
||||
typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
|
||||
let modSummary = pm_mod_summary pm
|
||||
dflags = ms_hspp_opts modSummary
|
||||
mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"
|
||||
@ -182,7 +184,7 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
|
||||
mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}
|
||||
in
|
||||
catchSrcErrors (hsc_dflags hsc) "typecheck" $ do
|
||||
tcRnModule session keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
|
||||
tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
|
||||
let errorPipeline = unDefer . hideDiag dflags . tagDiag
|
||||
diags = map errorPipeline warnings
|
||||
deferedError = any fst diags
|
||||
@ -193,16 +195,16 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
|
||||
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
|
||||
|
||||
-- | Install hooks to capture the splices as well as the runtime module dependencies
|
||||
captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)
|
||||
captureSplicesAndDeps env k = do
|
||||
captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString)
|
||||
captureSplicesAndDeps TypecheckHelpers{..} env k = do
|
||||
splice_ref <- newIORef mempty
|
||||
dep_ref <- newIORef emptyUniqSet
|
||||
dep_ref <- newIORef emptyModuleEnv
|
||||
res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)
|
||||
splices <- readIORef splice_ref
|
||||
needed_mods <- readIORef dep_ref
|
||||
return (res, splices, needed_mods)
|
||||
where
|
||||
addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks
|
||||
addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks
|
||||
addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }
|
||||
|
||||
-- We want to record exactly which linkables/modules the typechecker needed at runtime
|
||||
@ -215,12 +217,7 @@ captureSplicesAndDeps env k = do
|
||||
-- names in the compiled bytecode, recording the modules that those names
|
||||
-- come from in the IORef,, as these are the modules on whose implementation
|
||||
-- we depend.
|
||||
--
|
||||
-- Only compute direct dependencies instead of transitive dependencies.
|
||||
-- It is much cheaper to store the direct dependencies, we can compute
|
||||
-- the transitive ones when required.
|
||||
-- Also only record dependencies from the home package
|
||||
compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
|
||||
compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
|
||||
compile_bco_hook var hsc_env srcspan ds_expr
|
||||
= do { let dflags = hsc_dflags hsc_env
|
||||
|
||||
@ -257,41 +254,76 @@ captureSplicesAndDeps env k = do
|
||||
(icInteractiveModule ictxt)
|
||||
stg_expr
|
||||
[] Nothing
|
||||
; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos
|
||||
, Just mod <- [nameModule_maybe n] -- Names from other modules
|
||||
, not (isWiredInName n) -- Exclude wired-in names
|
||||
, moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package
|
||||
]
|
||||
-- Exclude wired-in names because we may not have read
|
||||
-- their interface files, so getLinkDeps will fail
|
||||
-- All wired-in names are in the base package, which we link
|
||||
-- by default, so we can safely ignore them here.
|
||||
|
||||
{- load it -}
|
||||
; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
|
||||
; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)
|
||||
#else
|
||||
{- Convert to BCOs -}
|
||||
; bcos <- coreExprToBCOs hsc_env
|
||||
(icInteractiveModule (hsc_IC hsc_env)) prepd_expr
|
||||
#endif
|
||||
|
||||
; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos)
|
||||
, Just mod <- [nameModule_maybe n] -- Names from other modules
|
||||
, not (isWiredInName n) -- Exclude wired-in names
|
||||
, moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package
|
||||
]
|
||||
-- Exclude wired-in names because we may not have read
|
||||
-- their interface files, so getLinkDeps will fail
|
||||
-- All wired-in names are in the base package, which we link
|
||||
-- by default, so we can safely ignore them here.
|
||||
|
||||
-- Find the linkables for the modules we need
|
||||
; let needed_mods = mkUniqSet [ moduleName mod
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
| n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos
|
||||
#else
|
||||
| n <- uniqDSetToList (bcoFreeNames bcos)
|
||||
#endif
|
||||
, Just mod <- [nameModule_maybe n] -- Names from other modules
|
||||
, not (isWiredInName n) -- Exclude wired-in names
|
||||
, moduleUnitId mod == uid -- Only care about stuff from the home package
|
||||
]
|
||||
hpt = hsc_HPT hsc_env
|
||||
uid = homeUnitId_ dflags
|
||||
mods_transitive = getTransitiveMods hpt needed_mods
|
||||
-- Non det OK as we will put it into maps later anyway
|
||||
mods_transitive_list = nonDetEltsUniqSet mods_transitive
|
||||
|
||||
; lbs <- getLinkables [toNormalizedFilePath' file | mod <- mkHomeModule
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
(hscHomeUnit hsc_env)
|
||||
#else
|
||||
uid
|
||||
#endif
|
||||
<$> mods_transitive_list
|
||||
, let ms = fromJust $ mgLookupModule (hsc_mod_graph hsc_env) mod
|
||||
, let file = fromJust $ ml_hs_file $ ms_location ms
|
||||
]
|
||||
; let hsc_env' = hsc_env { hsc_HPT = addListToHpt hpt [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] }
|
||||
|
||||
-- Essential to do this here after we load the linkables
|
||||
; keep_lbls <- getLinkablesToKeep
|
||||
|
||||
; unload hsc_env' $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
{- load it -}
|
||||
; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos
|
||||
; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)
|
||||
#else
|
||||
{- link it -}
|
||||
; hval <- linkExpr hsc_env srcspan bcos
|
||||
; hval <- linkExpr hsc_env' srcspan bcos
|
||||
#endif
|
||||
|
||||
; modifyIORef' var (unionUniqSets needed_mods)
|
||||
; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])
|
||||
; return hval }
|
||||
|
||||
-- Compute the transitive set of linkables required
|
||||
getTransitiveMods hpt needed_mods = go emptyUniqSet needed_mods
|
||||
where
|
||||
go seen new
|
||||
| isEmptyUniqSet new = seen
|
||||
| otherwise = go seen' new'
|
||||
where
|
||||
seen' = seen `unionUniqSets` new
|
||||
new' = new_deps `minusUniqSet` seen'
|
||||
new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info
|
||||
| mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]
|
||||
|
||||
|
||||
|
||||
-- | Add a Hook to the DynFlags which captures and returns the
|
||||
-- typechecked splices before they are run. This information
|
||||
@ -325,18 +357,15 @@ captureSplicesAndDeps env k = do
|
||||
|
||||
tcRnModule
|
||||
:: HscEnv
|
||||
-> ModuleEnv UTCTime -- ^ Program linkables not to unload
|
||||
-> TypecheckHelpers -- ^ Program linkables not to unload
|
||||
-> ParsedModule
|
||||
-> IO TcModuleResult
|
||||
tcRnModule hsc_env keep_lbls pmod = do
|
||||
tcRnModule hsc_env tc_helpers pmod = do
|
||||
let ms = pm_mod_summary pmod
|
||||
hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env
|
||||
hpt = hsc_HPT hsc_env
|
||||
|
||||
unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls
|
||||
|
||||
((tc_gbl_env', mrn_info), splices, mods)
|
||||
<- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp ->
|
||||
((tc_gbl_env', mrn_info), splices, mod_env)
|
||||
<- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hsc_env_tmp ->
|
||||
do hscTypecheckRename hsc_env_tmp ms $
|
||||
HsParsedModule { hpm_module = parsedSource pmod,
|
||||
hpm_src_files = pm_extra_src_files pmod,
|
||||
@ -345,25 +374,8 @@ tcRnModule hsc_env keep_lbls pmod = do
|
||||
Just x -> x
|
||||
Nothing -> error "no renamed info tcRnModule"
|
||||
|
||||
-- Compute the transitive set of linkables required
|
||||
mods_transitive = go emptyUniqSet mods
|
||||
where
|
||||
go seen new
|
||||
| isEmptyUniqSet new = seen
|
||||
| otherwise = go seen' new'
|
||||
where
|
||||
seen' = seen `unionUniqSets` new
|
||||
new' = new_deps `minusUniqSet` seen'
|
||||
new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info
|
||||
| mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]
|
||||
|
||||
-- The linkables we depend on at runtime are the transitive closure of 'mods'
|
||||
-- restricted to the home package
|
||||
-- See Note [Recompilation avoidance in the presence of TH]
|
||||
mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported
|
||||
|
||||
-- Serialize mod_env so we can read it from the interface
|
||||
mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time))
|
||||
mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)
|
||||
(moduleEnvToList mod_env)
|
||||
tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
|
||||
pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)
|
||||
@ -380,36 +392,30 @@ mkHiFileResultNoCompile session tcm = do
|
||||
#else
|
||||
(iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv
|
||||
#endif
|
||||
let mod_info = HomeModInfo iface details Nothing
|
||||
pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)
|
||||
pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing
|
||||
|
||||
mkHiFileResultCompile
|
||||
:: ShakeExtras
|
||||
-> HscEnv
|
||||
-> TcModuleResult
|
||||
-> ModGuts
|
||||
-> LinkableType -- ^ use object code or byte code?
|
||||
-> IO (IdeResult HiFileResult)
|
||||
mkHiFileResultCompile se session' tcm simplified_guts ltype = catchErrs $ do
|
||||
mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
|
||||
let session = hscSetFlags (ms_hspp_opts ms) session'
|
||||
ms = pm_mod_summary $ tmrParsed tcm
|
||||
tcGblEnv = tmrTypechecked tcm
|
||||
|
||||
let genLinkable = case ltype of
|
||||
ObjectLinkable -> generateObjectCode
|
||||
BCOLinkable -> generateByteCode se WriteCoreFile
|
||||
|
||||
(linkable, details, mguts, diags) <-
|
||||
(details, mguts) <-
|
||||
if mg_hsc_src simplified_guts == HsBootFile
|
||||
then do
|
||||
-- give variables unique OccNames
|
||||
details <- mkBootModDetailsTc session tcGblEnv
|
||||
pure (Nothing, details, Nothing, [])
|
||||
pure (details, Nothing)
|
||||
else do
|
||||
-- write core file
|
||||
-- give variables unique OccNames
|
||||
(guts, details) <- tidyProgram session simplified_guts
|
||||
(diags, linkable) <- genLinkable session ms guts
|
||||
pure (linkable, details, Just guts, diags)
|
||||
pure (details, Just guts)
|
||||
|
||||
#if MIN_VERSION_ghc(9,0,1)
|
||||
let !partial_iface = force (mkPartialIface session details simplified_guts)
|
||||
final_iface <- mkFullIface session partial_iface Nothing
|
||||
@ -419,53 +425,73 @@ mkHiFileResultCompile se session' tcm simplified_guts ltype = catchErrs $ do
|
||||
#else
|
||||
(final_iface,_) <- mkIface session Nothing details simplified_guts
|
||||
#endif
|
||||
let mod_info = HomeModInfo final_iface details linkable
|
||||
|
||||
-- Write the core file now
|
||||
core_file <- case mguts of
|
||||
Nothing -> pure Nothing -- no guts, likely boot file
|
||||
Just guts -> do
|
||||
let core_fp = ml_core_file $ ms_location ms
|
||||
core_file = codeGutsToCoreFile iface_hash guts
|
||||
iface_hash = getModuleHash final_iface
|
||||
core_hash1 <- atomicFileWrite se core_fp $ \fp ->
|
||||
writeBinCoreFile fp core_file
|
||||
-- We want to drop references to guts and read in a serialized, compact version
|
||||
-- of the core file from disk (as it is deserialised lazily)
|
||||
-- This is because we don't want to keep the guts in memeory for every file in
|
||||
-- the project as it becomes prohibitively expensive
|
||||
-- The serialized file however is much more compact and only requires a few
|
||||
-- hundred megabytes of memory total even in a large project with 1000s of
|
||||
-- modules
|
||||
(core_file, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp
|
||||
pure $ assert (core_hash1 == core_hash2)
|
||||
$ Just (core_file, fingerprintToBS core_hash2)
|
||||
|
||||
-- Verify core file by rountrip testing and comparison
|
||||
IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se
|
||||
when (maybe False (not . isObjectLinkable) linkable && optVerifyCoreFile) $ do
|
||||
let core_fp = ml_core_file $ ms_location ms
|
||||
traceIO $ "Verifying " ++ core_fp
|
||||
core <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp
|
||||
let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of
|
||||
Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists)"
|
||||
Just g -> g
|
||||
mod = ms_mod ms
|
||||
data_tycons = filter isDataTyCon tycons
|
||||
CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core
|
||||
case core_file of
|
||||
Just (core, _) | optVerifyCoreFile -> do
|
||||
let core_fp = ml_core_file $ ms_location ms
|
||||
traceIO $ "Verifying " ++ core_fp
|
||||
let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of
|
||||
Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists"
|
||||
Just g -> g
|
||||
mod = ms_mod ms
|
||||
data_tycons = filter isDataTyCon tycons
|
||||
CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core
|
||||
|
||||
-- Run corePrep first as we want to test the final version of the program that will
|
||||
-- get translated to STG/Bytecode
|
||||
(prepd_binds , _) <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
|
||||
(prepd_binds', _) <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
|
||||
let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds
|
||||
binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'
|
||||
-- Run corePrep first as we want to test the final version of the program that will
|
||||
-- get translated to STG/Bytecode
|
||||
(prepd_binds , _) <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
|
||||
(prepd_binds', _) <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
|
||||
let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds
|
||||
binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'
|
||||
|
||||
-- diffBinds is unreliable, sometimes it goes down the wrong track.
|
||||
-- This fixes the order of the bindings so that it is less likely to do so.
|
||||
diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'
|
||||
-- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')
|
||||
-- diffs3 = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')
|
||||
-- diffBinds is unreliable, sometimes it goes down the wrong track.
|
||||
-- This fixes the order of the bindings so that it is less likely to do so.
|
||||
diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'
|
||||
-- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')
|
||||
-- diffs3 = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')
|
||||
|
||||
diffs = diffs2
|
||||
go x y = S.state $ \s -> diffBinds True s x y
|
||||
diffs = diffs2
|
||||
go x y = S.state $ \s -> diffBinds True s x y
|
||||
|
||||
-- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these
|
||||
-- are used for generate core or bytecode, so we can safely ignore them
|
||||
-- SYB is slow but fine given that this is only used for testing
|
||||
noUnfoldings = everywhere $ mkT $ \v -> if isId v
|
||||
then
|
||||
let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v
|
||||
in setIdOccInfo v' noOccInfo
|
||||
else v
|
||||
isOtherUnfolding (OtherCon _) = True
|
||||
isOtherUnfolding _ = False
|
||||
-- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these
|
||||
-- are used for generate core or bytecode, so we can safely ignore them
|
||||
-- SYB is slow but fine given that this is only used for testing
|
||||
noUnfoldings = everywhere $ mkT $ \v -> if isId v
|
||||
then
|
||||
let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v
|
||||
in setIdOccInfo v' noOccInfo
|
||||
else v
|
||||
isOtherUnfolding (OtherCon _) = True
|
||||
isOtherUnfolding _ = False
|
||||
|
||||
|
||||
when (not $ null diffs) $
|
||||
panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds']))
|
||||
when (not $ null diffs) $
|
||||
panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds']))
|
||||
_ -> pure ()
|
||||
|
||||
pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm))
|
||||
pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file)
|
||||
|
||||
where
|
||||
dflags = hsc_dflags session'
|
||||
@ -544,10 +570,10 @@ generateObjectCode session summary guts = do
|
||||
|
||||
pure (map snd warnings, linkable)
|
||||
|
||||
data WriteCoreFile = WriteCoreFile | CoreFileExists !UTCTime
|
||||
newtype CoreFileTime = CoreFileTime UTCTime
|
||||
|
||||
generateByteCode :: ShakeExtras -> WriteCoreFile -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
|
||||
generateByteCode se write_core hscEnv summary guts = do
|
||||
generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
|
||||
generateByteCode (CoreFileTime time) hscEnv summary guts = do
|
||||
fmap (either (, Nothing) (second Just)) $
|
||||
catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do
|
||||
(warnings, (_, bytecode, sptEntries)) <-
|
||||
@ -562,16 +588,7 @@ generateByteCode se write_core hscEnv summary guts = do
|
||||
summary'
|
||||
#endif
|
||||
let unlinked = BCOs bytecode sptEntries
|
||||
time <- case write_core of
|
||||
CoreFileExists time -> pure time
|
||||
WriteCoreFile -> liftIO $ do
|
||||
let core_fp = ml_core_file $ ms_location summary
|
||||
core_file = codeGutsToCoreFile guts
|
||||
atomicFileWrite se core_fp $ \fp ->
|
||||
writeBinCoreFile fp core_file
|
||||
getModificationTime core_fp
|
||||
let linkable = LM time (ms_mod summary) [unlinked]
|
||||
|
||||
pure (map snd warnings, linkable)
|
||||
|
||||
demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
|
||||
@ -653,12 +670,12 @@ addRelativeImport fp modu dflags = dflags
|
||||
{importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
|
||||
|
||||
-- | Also resets the interface store
|
||||
atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO ()
|
||||
atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a
|
||||
atomicFileWrite se targetPath write = do
|
||||
let dir = takeDirectory targetPath
|
||||
createDirectoryIfMissing True dir
|
||||
(tempFilePath, cleanUp) <- newTempFileWithin dir
|
||||
(write tempFilePath >> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)))
|
||||
(write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)
|
||||
`onException` cleanUp
|
||||
|
||||
generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
|
||||
@ -681,12 +698,14 @@ generateHieAsts hscEnv tcm =
|
||||
#endif
|
||||
where
|
||||
dflags = hsc_dflags hscEnv
|
||||
#if MIN_VERSION_ghc(9,0,0)
|
||||
run ts =
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
fmap (join . snd) . liftIO . initDs hscEnv ts
|
||||
#else
|
||||
id
|
||||
#endif
|
||||
#endif
|
||||
|
||||
spliceExpresions :: Splices -> [LHsExpr GhcTc]
|
||||
spliceExpresions Splices{..} =
|
||||
@ -851,7 +870,7 @@ writeHiFile se hscEnv tc =
|
||||
atomicFileWrite se targetPath $ \fp ->
|
||||
writeIfaceFile hscEnv fp modIface
|
||||
where
|
||||
modIface = hm_iface $ hirHomeMod tc
|
||||
modIface = hirModIface tc
|
||||
targetPath = ml_hi_file $ ms_location $ hirModSummary tc
|
||||
dflags = hsc_dflags hscEnv
|
||||
|
||||
@ -1193,6 +1212,7 @@ data RecompilationInfo m
|
||||
{ source_version :: FileVersion
|
||||
, old_value :: Maybe (HiFileResult, FileVersion)
|
||||
, get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)
|
||||
, get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString]
|
||||
, regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface
|
||||
}
|
||||
|
||||
@ -1213,18 +1233,16 @@ ml_core_file ml = ml_hi_file ml <.> "core"
|
||||
-- See Note [Recompilation avoidance in the presence of TH]
|
||||
loadInterface
|
||||
:: (MonadIO m, MonadMask m)
|
||||
=> ShakeExtras
|
||||
-> HscEnv
|
||||
=> HscEnv
|
||||
-> ModSummary
|
||||
-> Maybe LinkableType
|
||||
-> RecompilationInfo m
|
||||
-> m ([FileDiagnostic], Maybe HiFileResult)
|
||||
loadInterface se session ms linkableNeeded RecompilationInfo{..} = do
|
||||
loadInterface session ms linkableNeeded RecompilationInfo{..} = do
|
||||
let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session
|
||||
mb_old_iface = hm_iface . hirHomeMod . fst <$> old_value
|
||||
mb_old_iface = hirModIface . fst <$> old_value
|
||||
mb_old_version = snd <$> old_value
|
||||
|
||||
obj_file = ml_obj_file (ms_location ms)
|
||||
core_file = ml_core_file (ms_location ms)
|
||||
iface_file = ml_hi_file (ms_location ms)
|
||||
|
||||
@ -1232,14 +1250,10 @@ loadInterface se session ms linkableNeeded RecompilationInfo{..} = do
|
||||
|
||||
mb_dest_version <- case mb_old_version of
|
||||
Just ver -> pure $ Just ver
|
||||
Nothing -> do
|
||||
let file = case linkableNeeded of
|
||||
Just ObjectLinkable -> obj_file
|
||||
Just BCOLinkable -> core_file
|
||||
Nothing -> iface_file
|
||||
get_file_version (toNormalizedFilePath' file)
|
||||
Nothing -> get_file_version (toNormalizedFilePath' iface_file)
|
||||
|
||||
-- The source is modified if it is newer than the destination
|
||||
-- The source is modified if it is newer than the destination (iface file)
|
||||
-- A more precise check for the core file is performed later
|
||||
let sourceMod = case mb_dest_version of
|
||||
Nothing -> SourceModified -- desitination file doesn't exist, assume modified source
|
||||
Just dest_version
|
||||
@ -1247,135 +1261,89 @@ loadInterface se session ms linkableNeeded RecompilationInfo{..} = do
|
||||
| otherwise -> SourceModified
|
||||
|
||||
-- If mb_old_iface is nothing then checkOldIface will load it for us
|
||||
-- given that the source is unmodified
|
||||
(recomp_iface_reqd, mb_checked_iface)
|
||||
<- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface
|
||||
|
||||
|
||||
(recomp_obj_reqd, mb_linkable) <- case linkableNeeded of
|
||||
Nothing -> pure (UpToDate, Nothing)
|
||||
Just linkableType -> case old_value of
|
||||
-- We don't have an old result
|
||||
Nothing -> recompMaybeBecause "missing"
|
||||
-- We have an old result
|
||||
Just (old_hir, old_file_version) ->
|
||||
case hm_linkable $ hirHomeMod old_hir of
|
||||
Nothing -> recompMaybeBecause "missing [not needed before]"
|
||||
Just old_lb
|
||||
| Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used
|
||||
, old_file_version /= source_version -> recompMaybeBecause "out of date"
|
||||
|
||||
-- Check if it is the correct type
|
||||
-- Ideally we could use object-code in case we already have
|
||||
-- it when we are generating bytecode, but this is difficult because something
|
||||
-- below us may be bytecode, and object code can't depend on bytecode
|
||||
| ObjectLinkable <- linkableType, isObjectLinkable old_lb
|
||||
-> pure (UpToDate, Just $ GhcLinkable old_lb)
|
||||
|
||||
| BCOLinkable <- linkableType , not (isObjectLinkable old_lb)
|
||||
-> pure (UpToDate, Just $ GhcLinkable old_lb)
|
||||
|
||||
| otherwise -> recompMaybeBecause "missing [wrong type]"
|
||||
where
|
||||
recompMaybeBecause msg =
|
||||
case mb_dest_version of -- The destination file should be the object code or the core file
|
||||
Nothing -> pure (RecompBecause msg', Nothing)
|
||||
Just disk_obj_version@(ModificationTime t) ->
|
||||
if (disk_obj_version >= source_version)
|
||||
then case linkableType of
|
||||
ObjectLinkable -> pure (UpToDate, Just $ GhcLinkable $ LM (posixSecondsToUTCTime t) mod [DotO obj_file])
|
||||
BCOLinkable -> liftIO $ do
|
||||
core <- readBinCoreFile (mkUpdater $ hsc_NC session) core_file
|
||||
pure (UpToDate, Just $ CoreLinkable (posixSecondsToUTCTime t) core)
|
||||
else pure (RecompBecause msg', Nothing)
|
||||
Just (VFSVersion _) -> pure (RecompBecause msg', Nothing)
|
||||
where
|
||||
msg' = case linkableType of
|
||||
BCOLinkable -> "bytecode " ++ msg
|
||||
ObjectLinkable -> "Object code " ++ msg
|
||||
|
||||
let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do
|
||||
setTag "Module" $ moduleNameString $ moduleName mod
|
||||
setTag "Reason" $ showReason _reason
|
||||
liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason)
|
||||
regenerate linkableNeeded
|
||||
|
||||
case (mb_checked_iface, recomp_iface_reqd <> recomp_obj_reqd) of
|
||||
case (mb_checked_iface, recomp_iface_reqd) of
|
||||
(Just iface, UpToDate) -> do
|
||||
-- Force it because we don't want to retain old modsummaries or linkables
|
||||
lb <- liftIO $ evaluate $ force mb_linkable
|
||||
|
||||
-- If we have an old value, just return it
|
||||
case old_value of
|
||||
Just (old_hir, _)
|
||||
| Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir)
|
||||
-> do_regenerate msg
|
||||
| otherwise -> return ([], Just old_hir)
|
||||
Nothing -> do
|
||||
(warns, hmi) <- liftIO $ mkDetailsFromIface se sessionWithMsDynFlags ms iface lb
|
||||
| if isJust linkableNeeded then isJust (hirCoreFp old_hir) else True
|
||||
-> do
|
||||
-- Peform the fine grained recompilation check for TH
|
||||
maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) (hirRuntimeModules old_hir)
|
||||
case maybe_recomp of
|
||||
Just msg -> do_regenerate msg
|
||||
Nothing -> return ([], Just old_hir)
|
||||
-- Otherwise use the value from disk, provided the core file is up to date if required
|
||||
_ -> do
|
||||
details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface
|
||||
-- parse the runtime dependencies from the annotations
|
||||
let runtime_deps
|
||||
| not (mi_used_th iface) = emptyModuleEnv
|
||||
| otherwise = parseRuntimeDeps (md_anns (hm_details hmi))
|
||||
return (warns, Just $ mkHiFileResult ms hmi runtime_deps)
|
||||
| otherwise = parseRuntimeDeps (md_anns details)
|
||||
-- Peform the fine grained recompilation check for TH
|
||||
maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
|
||||
case maybe_recomp of
|
||||
Just msg -> do_regenerate msg
|
||||
Nothing
|
||||
| isJust linkableNeeded -> do
|
||||
(core_file@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ readBinCoreFile (mkUpdater $ hsc_NC session) core_file
|
||||
if cf_iface_hash == getModuleHash iface
|
||||
then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash)))
|
||||
else do_regenerate (RecompBecause "Core file out of date (doesn't match iface hash)")
|
||||
| otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)
|
||||
(_, _reason) -> do_regenerate _reason
|
||||
|
||||
-- | ModDepTime is stored as an annotation in the iface to
|
||||
-- keep track of runtime dependencies
|
||||
newtype ModDepTime = ModDepTime UTCTime
|
||||
|
||||
deserializeModDepTime :: [Word8] -> ModDepTime
|
||||
deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of
|
||||
(a,b) -> UTCTime (toEnum a) (toEnum b)
|
||||
|
||||
serializeModDepTime :: ModDepTime -> [Word8]
|
||||
serializeModDepTime (ModDepTime l) = LBS.unpack $
|
||||
B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)
|
||||
|
||||
-- | Find the runtime dependencies by looking at the annotations
|
||||
-- serialized in the iface
|
||||
parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime
|
||||
parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString
|
||||
parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns
|
||||
where
|
||||
go (Annotation (ModuleTarget mod) payload)
|
||||
| Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload
|
||||
= Just (mod, t)
|
||||
| Just bs <- fromSerialized BS.pack payload
|
||||
= Just (mod, bs)
|
||||
go _ = Nothing
|
||||
|
||||
-- | checkLinkableDependencies compares the linkables in the home package to
|
||||
-- | checkLinkableDependencies compares the core files in the shake store to
|
||||
-- the runtime dependencies of the module, to check if any of them are out of date
|
||||
-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
|
||||
-- See Note [Recompilation avoidance in the presence of TH]
|
||||
checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired
|
||||
checkLinkableDependencies hpt runtime_deps
|
||||
| isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile
|
||||
| otherwise = Just $
|
||||
RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date))
|
||||
where
|
||||
out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of
|
||||
Nothing -> False
|
||||
Just hm -> case hm_linkable hm of
|
||||
Nothing -> False
|
||||
Just lm -> linkableTime lm /= time)
|
||||
runtime_deps
|
||||
checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
|
||||
checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
|
||||
let hs_files = mapM go (moduleEnvToList runtime_deps)
|
||||
go (mod, hash) = do
|
||||
ms <- mgLookupModule graph mod
|
||||
let hs = fromJust $ ml_hs_file $ ms_location ms
|
||||
pure (toNormalizedFilePath' hs, hash)
|
||||
case hs_files of
|
||||
Nothing -> error "invalid module graph"
|
||||
Just fs -> do
|
||||
store_hashes <- get_linkable_hashes (map fst fs)
|
||||
let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash]
|
||||
case out_of_date of
|
||||
[] -> pure Nothing
|
||||
_ -> pure $ Just $
|
||||
RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date)
|
||||
|
||||
showReason :: RecompileRequired -> String
|
||||
showReason UpToDate = "UpToDate"
|
||||
showReason MustCompile = "MustCompile"
|
||||
showReason (RecompBecause s) = s
|
||||
|
||||
mkDetailsFromIface :: ShakeExtras -> HscEnv -> ModSummary -> ModIface -> Maybe IdeLinkable -> IO ([FileDiagnostic], HomeModInfo)
|
||||
mkDetailsFromIface se session ms iface ide_linkable = do
|
||||
details <- liftIO $ fixIO $ \details -> do
|
||||
mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails
|
||||
mkDetailsFromIface session iface = do
|
||||
fixIO $ \details -> do
|
||||
let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details Nothing) }
|
||||
initIfaceLoad hsc' (typecheckIface iface)
|
||||
(warns, linkable) <- liftIO $ case ide_linkable of
|
||||
Nothing -> pure ([], Nothing)
|
||||
Just (GhcLinkable lb) -> pure ([], Just lb)
|
||||
Just (CoreLinkable t core_file) -> do
|
||||
cgi_guts <- coreFileToCgGuts session iface details core_file
|
||||
generateByteCode se (CoreFileExists t) session ms cgi_guts
|
||||
|
||||
return (warns, HomeModInfo iface details linkable)
|
||||
|
||||
coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
|
||||
coreFileToCgGuts session iface details core_file = do
|
||||
@ -1392,6 +1360,24 @@ coreFileToCgGuts session iface details core_file = do
|
||||
tyCons = typeEnvTyCons (md_types details)
|
||||
pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []
|
||||
|
||||
coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)
|
||||
coreFileToLinkable linkableType session ms iface details core_file t = do
|
||||
let act hpt = addToHpt hpt (moduleName this_mod)
|
||||
(HomeModInfo iface details Nothing)
|
||||
this_mod = mi_module iface
|
||||
types_var <- newIORef (md_types details)
|
||||
let kv = Just (this_mod, types_var)
|
||||
hsc_env' = session { hsc_HPT = act (hsc_HPT session)
|
||||
, hsc_type_env_var = kv }
|
||||
core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file
|
||||
let implicit_binds = concatMap getImplicitBinds tyCons
|
||||
tyCons = typeEnvTyCons (md_types details)
|
||||
let cgi_guts = CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []
|
||||
(warns, lb) <- case linkableType of
|
||||
BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts
|
||||
ObjectLinkable -> generateObjectCode session ms cgi_guts
|
||||
pure (warns, HomeModInfo iface details . Just <$> lb)
|
||||
|
||||
-- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
|
||||
-- The interactive paths create problems in ghc-lib builds
|
||||
--- and leads to fun errors like "Cannot continue after interface file error".
|
||||
|
@ -35,9 +35,7 @@ import GHC.Generics (Generic)
|
||||
|
||||
import qualified Data.Binary as B
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Text (Text)
|
||||
import Data.Time
|
||||
import Development.IDE.Import.FindImports (ArtifactsLocation)
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Spans.LocalBindings
|
||||
@ -45,6 +43,8 @@ import Development.IDE.Types.Diagnostics
|
||||
import GHC.Serialized (Serialized)
|
||||
import Language.LSP.Types (Int32,
|
||||
NormalizedFilePath)
|
||||
import Development.IDE.GHC.CoreFile
|
||||
import Control.Exception (assert)
|
||||
|
||||
data LinkableType = ObjectLinkable | BCOLinkable
|
||||
deriving (Eq,Ord,Show, Generic)
|
||||
@ -91,6 +91,26 @@ data GenerateCore = GenerateCore
|
||||
instance Hashable GenerateCore
|
||||
instance NFData GenerateCore
|
||||
|
||||
type instance RuleResult GetLinkable = LinkableResult
|
||||
|
||||
data LinkableResult
|
||||
= LinkableResult
|
||||
{ linkableHomeMod :: !HomeModInfo
|
||||
, linkableHash :: !ByteString
|
||||
-- ^ The hash of the core file
|
||||
}
|
||||
|
||||
instance Show LinkableResult where
|
||||
show = show . mi_module . hm_iface . linkableHomeMod
|
||||
|
||||
instance NFData LinkableResult where
|
||||
rnf = rwhnf
|
||||
|
||||
data GetLinkable = GetLinkable
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetLinkable
|
||||
instance NFData GetLinkable
|
||||
|
||||
data GetImportMap = GetImportMap
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetImportMap
|
||||
@ -138,9 +158,10 @@ data TcModuleResult = TcModuleResult
|
||||
-- ^ Typechecked splice information
|
||||
, tmrDeferedError :: !Bool
|
||||
-- ^ Did we defer any type errors for this module?
|
||||
, tmrRuntimeModules :: !(ModuleEnv UTCTime)
|
||||
, tmrRuntimeModules :: !(ModuleEnv ByteString)
|
||||
-- ^ Which modules did we need at runtime while compiling this file?
|
||||
-- Used for recompilation checking in the presence of TH
|
||||
-- Stores the hash of their core file
|
||||
}
|
||||
instance Show TcModuleResult where
|
||||
show = show . pm_mod_summary . tmrParsed
|
||||
@ -155,30 +176,29 @@ data HiFileResult = HiFileResult
|
||||
{ hirModSummary :: !ModSummary
|
||||
-- Bang patterns here are important to stop the result retaining
|
||||
-- a reference to a typechecked module
|
||||
, hirHomeMod :: !HomeModInfo
|
||||
-- ^ Includes the Linkable iff we need object files
|
||||
, hirIfaceFp :: ByteString
|
||||
, hirModIface :: !ModIface
|
||||
, hirModDetails :: ModDetails
|
||||
-- ^ Populated lazily
|
||||
, hirIfaceFp :: !ByteString
|
||||
-- ^ Fingerprint for the ModIface
|
||||
, hirLinkableFp :: ByteString
|
||||
-- ^ Fingerprint for the Linkable
|
||||
, hirRuntimeModules :: !(ModuleEnv UTCTime)
|
||||
, hirRuntimeModules :: !(ModuleEnv ByteString)
|
||||
-- ^ same as tmrRuntimeModules
|
||||
, hirCoreFp :: !(Maybe (CoreFile, ByteString))
|
||||
-- ^ If we wrote a core file for this module, then its contents (lazily deserialised)
|
||||
-- along with its hash
|
||||
}
|
||||
|
||||
hiFileFingerPrint :: HiFileResult -> ByteString
|
||||
hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp
|
||||
hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp
|
||||
|
||||
mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult
|
||||
mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..}
|
||||
mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult
|
||||
mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =
|
||||
assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _)
|
||||
-> getModuleHash hirModIface == cf_iface_hash
|
||||
_ -> True)
|
||||
HiFileResult{..}
|
||||
where
|
||||
hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes
|
||||
hirLinkableFp = case hm_linkable hirHomeMod of
|
||||
Nothing -> ""
|
||||
Just (linkableTime -> l) -> LBS.toStrict $
|
||||
B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)
|
||||
|
||||
hirModIface :: HiFileResult -> ModIface
|
||||
hirModIface = hm_iface . hirHomeMod
|
||||
hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes
|
||||
|
||||
instance NFData HiFileResult where
|
||||
rnf = rwhnf
|
||||
|
@ -99,7 +99,7 @@ import Data.Tuple.Extra
|
||||
import Development.IDE.Core.Compile
|
||||
import Development.IDE.Core.FileExists hiding (LogShake, Log)
|
||||
import Development.IDE.Core.FileStore (getFileContents,
|
||||
resetInterfaceStore)
|
||||
getModTime)
|
||||
import Development.IDE.Core.IdeConfiguration
|
||||
import Development.IDE.Core.OfInterest hiding (LogShake, Log)
|
||||
import Development.IDE.Core.PositionMapping
|
||||
@ -135,7 +135,7 @@ import Ide.Plugin.Config
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import Language.LSP.Types (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo))
|
||||
import Language.LSP.VFS
|
||||
import System.Directory (makeAbsolute)
|
||||
import System.Directory (makeAbsolute, doesFileExist)
|
||||
import Data.Default (def, Default)
|
||||
import Ide.Plugin.Properties (HasProperty,
|
||||
KeyNameProxy,
|
||||
@ -154,6 +154,9 @@ import qualified Development.IDE.Core.Shake as Shake
|
||||
import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake)
|
||||
import qualified Development.IDE.Types.Logger as Logger
|
||||
import qualified Development.IDE.Types.Shake as Shake
|
||||
import Development.IDE.GHC.CoreFile
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
||||
import Control.Monad.IO.Unlift
|
||||
|
||||
data Log
|
||||
= LogShake Shake.Log
|
||||
@ -673,9 +676,13 @@ typeCheckRuleDefinition hsc pm = do
|
||||
setPriority priorityTypeCheck
|
||||
IdeOptions { optDefer = defer } <- getIdeOptions
|
||||
|
||||
linkables_to_keep <- currentLinkables
|
||||
unlift <- askUnliftIO
|
||||
let dets = TypecheckHelpers
|
||||
{ getLinkablesToKeep = unliftIO unlift $ currentLinkables
|
||||
, getLinkables = unliftIO unlift . uses_ GetLinkable
|
||||
}
|
||||
addUsageDependencies $ liftIO $
|
||||
typecheckModule defer hsc linkables_to_keep pm
|
||||
typecheckModule defer hsc dets pm
|
||||
where
|
||||
addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
|
||||
addUsageDependencies a = do
|
||||
@ -752,7 +759,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
|
||||
depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
|
||||
ifaces <- uses_ GetModIface deps
|
||||
|
||||
let inLoadOrder = map hirHomeMod ifaces
|
||||
let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces
|
||||
session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions
|
||||
|
||||
Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])
|
||||
@ -768,7 +775,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
|
||||
Just session -> do
|
||||
linkableType <- getLinkableType f
|
||||
ver <- use_ GetModificationTime f
|
||||
se@ShakeExtras{ideNc} <- getShakeExtras
|
||||
ShakeExtras{ideNc} <- getShakeExtras
|
||||
let m_old = case old of
|
||||
Shake.Succeeded (Just old_version) v -> Just (v, old_version)
|
||||
Shake.Stale _ (Just old_version) v -> Just (v, old_version)
|
||||
@ -777,9 +784,10 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
|
||||
{ source_version = ver
|
||||
, old_value = m_old
|
||||
, get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
|
||||
, get_linkable_hashes = \fs -> map linkableHash <$> uses_ GetLinkable fs
|
||||
, regenerate = regenerateHiFile session f ms
|
||||
}
|
||||
r <- loadInterface se (hscEnv session) ms linkableType recompInfo
|
||||
r <- loadInterface (hscEnv session) ms linkableType recompInfo
|
||||
case r of
|
||||
(diags, Nothing) -> return (Nothing, (diags, Nothing))
|
||||
(diags, Just x) -> do
|
||||
@ -899,7 +907,7 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
|
||||
hsc <- hscEnv <$> use_ GhcSessionDeps f
|
||||
let compile = fmap ([],) $ use GenerateCore f
|
||||
se <- getShakeExtras
|
||||
(diags, !hiFile) <- compileToObjCodeIfNeeded se hsc linkableType compile tmr
|
||||
(diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr
|
||||
let fp = hiFileFingerPrint <$> hiFile
|
||||
hiDiags <- case hiFile of
|
||||
Just hiFile
|
||||
@ -912,10 +920,6 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
|
||||
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 $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
|
||||
pure res
|
||||
|
||||
-- | Count of total times we asked GHC to recompile
|
||||
@ -960,13 +964,12 @@ regenerateHiFile sess f ms compNeeded = do
|
||||
Nothing -> pure (diags', Nothing)
|
||||
Just tmr -> do
|
||||
|
||||
-- compile writes .o file
|
||||
let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
|
||||
|
||||
se <- getShakeExtras
|
||||
|
||||
-- Bang pattern is important to avoid leaking 'tmr'
|
||||
(diags'', !res) <- compileToObjCodeIfNeeded se hsc compNeeded compile tmr
|
||||
(diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr
|
||||
|
||||
-- Write hi file
|
||||
hiDiags <- case res of
|
||||
@ -994,18 +997,20 @@ regenerateHiFile sess f ms compNeeded = do
|
||||
|
||||
|
||||
-- | HscEnv should have deps included already
|
||||
compileToObjCodeIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
|
||||
compileToObjCodeIfNeeded _ hsc Nothing _ tmr = do
|
||||
-- This writes the core file if a linkable is required
|
||||
-- The actual linkable will be generated on demand when required by `GetLinkable`
|
||||
writeCoreFileIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
|
||||
writeCoreFileIfNeeded _ hsc Nothing _ tmr = do
|
||||
incrementRebuildCount
|
||||
res <- liftIO $ mkHiFileResultNoCompile hsc tmr
|
||||
pure ([], Just $! res)
|
||||
compileToObjCodeIfNeeded se hsc (Just linkableType) getGuts tmr = do
|
||||
writeCoreFileIfNeeded se hsc (Just _) getGuts tmr = do
|
||||
incrementRebuildCount
|
||||
(diags, mguts) <- getGuts
|
||||
case mguts of
|
||||
Nothing -> pure (diags, Nothing)
|
||||
Just guts -> do
|
||||
(diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts linkableType
|
||||
(diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts
|
||||
pure (diags++diags', res)
|
||||
|
||||
getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()
|
||||
@ -1037,6 +1042,48 @@ usePropertyAction kn plId p = do
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
getLinkableRule :: Recorder (WithPriority Log) -> Rules ()
|
||||
getLinkableRule recorder =
|
||||
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do
|
||||
ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f
|
||||
HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f
|
||||
let obj_file = ml_obj_file (ms_location ms)
|
||||
core_file = ml_core_file (ms_location ms)
|
||||
-- Can't use `GetModificationTime` rule because the core file was possibly written in this
|
||||
-- very session, so the results aren't reliable
|
||||
core_t <- liftIO $ getModTime core_file
|
||||
case hirCoreFp of
|
||||
Nothing -> error "called GetLinkable for a file without a linkable"
|
||||
Just (bin_core, hash) -> do
|
||||
session <- use_ GhcSessionDeps f
|
||||
ShakeExtras{ideNc} <- getShakeExtras
|
||||
let namecache_updater = mkUpdater ideNc
|
||||
linkableType <- getLinkableType f >>= \case
|
||||
Nothing -> error "called GetLinkable for a file which doesn't need compilation"
|
||||
Just t -> pure t
|
||||
(warns, hmi) <- case linkableType of
|
||||
-- Bytecode needs to be regenerated from the core file
|
||||
BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)
|
||||
-- Object code can be read from the disk
|
||||
ObjectLinkable -> do
|
||||
-- object file is up to date if it is newer than the core file
|
||||
-- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and
|
||||
-- thus bump its modification time, forcing this rule to be rerun every time.
|
||||
exists <- liftIO $ doesFileExist obj_file
|
||||
mobj_time <- liftIO $
|
||||
if exists
|
||||
then Just <$> getModTime obj_file
|
||||
else pure Nothing
|
||||
case mobj_time of
|
||||
Just obj_t
|
||||
| obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file]))
|
||||
_ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time")
|
||||
-- Record the linkable so we know not to unload it
|
||||
whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do
|
||||
compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
|
||||
liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
|
||||
return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash))
|
||||
|
||||
-- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH
|
||||
getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
|
||||
getLinkableType f = use_ NeedsCompilation f
|
||||
@ -1069,7 +1116,6 @@ needsCompilationRule file = do
|
||||
(,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps)
|
||||
(uses NeedsCompilation revdeps)
|
||||
pure $ computeLinkableType ms modsums (map join needsComps)
|
||||
|
||||
pure (Just $ encodeLinkableType res, Just res)
|
||||
where
|
||||
computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
|
||||
@ -1170,3 +1216,4 @@ mainRule recorder RulesConfig{..} = do
|
||||
persistentHieFileRule recorder
|
||||
persistentDocMapRule
|
||||
persistentImportMapRule
|
||||
getLinkableRule recorder
|
||||
|
@ -5,13 +5,14 @@
|
||||
-- | CoreFiles let us serialize Core to a file in order to later recover it
|
||||
-- without reparsing or retypechecking
|
||||
module Development.IDE.GHC.CoreFile
|
||||
( CoreFile
|
||||
( CoreFile(..)
|
||||
, codeGutsToCoreFile
|
||||
, typecheckCoreFile
|
||||
, readBinCoreFile
|
||||
, writeBinCoreFile
|
||||
, getImplicitBinds) where
|
||||
|
||||
import GHC.Fingerprint
|
||||
import Data.IORef
|
||||
import Data.Foldable
|
||||
import Data.List (isPrefixOf)
|
||||
@ -29,6 +30,7 @@ import GHC.IfaceToCore
|
||||
import GHC.Iface.Env
|
||||
import GHC.Iface.Binary
|
||||
import GHC.Types.Id.Make
|
||||
import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
|
||||
|
||||
#if MIN_VERSION_ghc(9,2,0)
|
||||
import GHC.Types.TypeEnv
|
||||
@ -48,13 +50,21 @@ import IdInfo
|
||||
import Var
|
||||
import Unique
|
||||
import MkId
|
||||
import BinFingerprint ( fingerprintBinMem )
|
||||
#endif
|
||||
|
||||
import qualified Development.IDE.GHC.Compat.Util as Util
|
||||
|
||||
-- | Initial ram buffer to allocate for writing interface files
|
||||
initBinMemSize :: Int
|
||||
initBinMemSize = 1024 * 1024
|
||||
|
||||
newtype CoreFile = CoreFile { cf_bindings :: [TopIfaceBinding IfaceId] }
|
||||
data CoreFile
|
||||
= CoreFile
|
||||
{ cf_bindings :: [TopIfaceBinding IfaceId]
|
||||
-- ^ The actual core file bindings, deserialized lazily
|
||||
, cf_iface_hash :: !Fingerprint
|
||||
}
|
||||
|
||||
-- | Like IfaceBinding, but lets us serialize internal names as well
|
||||
data TopIfaceBinding v
|
||||
@ -84,19 +94,21 @@ instance Binary (TopIfaceBinding IfaceId) where
|
||||
_ -> error "Binary TopIfaceBinding"
|
||||
|
||||
instance Binary CoreFile where
|
||||
put_ bh (CoreFile a) = put_ bh a
|
||||
get bh = CoreFile <$> get bh
|
||||
put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp
|
||||
get bh = CoreFile <$> lazyGet bh <*> get bh
|
||||
|
||||
readBinCoreFile
|
||||
:: NameCacheUpdater
|
||||
-> FilePath
|
||||
-> IO CoreFile
|
||||
-> IO (CoreFile, Fingerprint)
|
||||
readBinCoreFile name_cache fat_hi_path = do
|
||||
bh <- readBinMem fat_hi_path
|
||||
getWithUserData name_cache bh
|
||||
file <- getWithUserData name_cache bh
|
||||
!fp <- Util.getFileHash fat_hi_path
|
||||
return (file, fp)
|
||||
|
||||
-- | Write a core file
|
||||
writeBinCoreFile :: FilePath -> CoreFile -> IO ()
|
||||
writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint
|
||||
writeBinCoreFile core_path fat_iface = do
|
||||
bh <- openBinMem initBinMemSize
|
||||
|
||||
@ -112,11 +124,17 @@ writeBinCoreFile core_path fat_iface = do
|
||||
-- And send the result to the file
|
||||
writeBinMem bh core_path
|
||||
|
||||
!fp <- fingerprintBinMem bh
|
||||
pure fp
|
||||
|
||||
-- Implicit binds aren't tidied, so we can't serialise them.
|
||||
-- This isn't a problem however since we can regenerate them from the
|
||||
-- original ModIface
|
||||
codeGutsToCoreFile :: CgGuts -> CoreFile
|
||||
codeGutsToCoreFile CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds)
|
||||
codeGutsToCoreFile
|
||||
:: Fingerprint -- ^ Hash of the interface this was generated from
|
||||
-> CgGuts
|
||||
-> CoreFile
|
||||
codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds) hash
|
||||
|
||||
-- | Implicit binds can be generated from the interface and are not tidied,
|
||||
-- so we must filter them out
|
||||
@ -157,7 +175,7 @@ toIfaceTopBind mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr mod b) (toIface
|
||||
toIfaceTopBind mod (Rec prs) = TopIfaceRec [(toIfaceTopBndr mod b, toIfaceExpr r) | (b,r) <- prs]
|
||||
|
||||
typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
|
||||
typecheckCoreFile this_mod type_var (CoreFile prepd_binding) =
|
||||
typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) =
|
||||
initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do
|
||||
tcTopIfaceBindings type_var prepd_binding
|
||||
|
||||
|
@ -210,3 +210,8 @@ instance (NFData (HsModule a)) where
|
||||
|
||||
instance Show OccName where show = unpack . printOutputable
|
||||
instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n)
|
||||
|
||||
instance Show HomeModInfo where show = show . mi_module . hm_iface
|
||||
|
||||
instance NFData HomeModInfo where
|
||||
rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link
|
||||
|
@ -81,6 +81,7 @@ library
|
||||
, stm-containers
|
||||
, time
|
||||
, transformers
|
||||
, unliftio
|
||||
, unordered-containers
|
||||
|
||||
if flag(embed-files)
|
||||
|
@ -38,6 +38,7 @@ import qualified StmContainers.Map as SMap
|
||||
import System.Time.Extra (Seconds)
|
||||
import qualified Data.HashSet as Set
|
||||
import Data.List (intercalate)
|
||||
import UnliftIO (MonadUnliftIO)
|
||||
|
||||
|
||||
unwrapDynamic :: forall a . Typeable a => Dynamic -> a
|
||||
@ -64,7 +65,7 @@ data SRules = SRules {
|
||||
-- ACTIONS
|
||||
|
||||
newtype Action a = Action {fromAction :: ReaderT SAction IO a}
|
||||
deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
|
||||
deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
|
||||
|
||||
data SAction = SAction {
|
||||
actionDatabase :: !Database,
|
||||
|
@ -458,9 +458,9 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
|
||||
let fs = occNameFS n
|
||||
]
|
||||
fixFixities f pm = do
|
||||
HiFileResult {hirHomeMod} <-
|
||||
HiFileResult {hirModIface} <-
|
||||
useOrFail "GetModIface" NoTypeCheck GetModIface f
|
||||
let fixities = fixityEnvFromModIface $ hm_iface hirHomeMod
|
||||
let fixities = fixityEnvFromModIface hirModIface
|
||||
res <- transformA pm (fix fixities)
|
||||
return (fixities, res)
|
||||
fixAnns ParsedModule {..} =
|
||||
|
Loading…
Reference in New Issue
Block a user