diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 4d14b920bd..f1be07dbcb 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -15,6 +15,7 @@ data Arguments = Arguments ,argsOTMemoryProfiling :: Bool ,argsTesting :: Bool ,argsDisableKick :: Bool + ,argsVerifyCoreFile :: Bool ,argsThreads :: Int ,argsVerbose :: Bool ,argsCommand :: Command @@ -37,6 +38,7 @@ arguments plugins = Arguments <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite") <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") + <*> switch (long "verify-core-file" <> help "Verify core trips by roundtripping after serialization. Slow, only useful for testing purposes") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output") <*> (commandP plugins <|> lspCommand <|> checkCommand) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index e97f393d2a..538367c3bd 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -142,6 +142,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do , optCheckParents = pure $ checkParents config , optCheckProject = pure $ checkProject config , optRunSubset = not argsConservativeChangeTracking + , optVerifyCoreFile = argsVerifyCoreFile } , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort } diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index d7260fe832..b8b7b006da 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -180,6 +180,7 @@ library Development.IDE.GHC.Compat.Units Development.IDE.GHC.Compat.Util Development.IDE.Core.Compile + Development.IDE.GHC.CoreFile Development.IDE.GHC.Dump Development.IDE.GHC.Error Development.IDE.GHC.ExactPrint diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 7cfbbc893f..7496b3d5fa 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -31,26 +31,30 @@ module Development.IDE.Core.Compile , getDocsBatch , lookupName , mergeEnvs + , ml_core_file + , coreFileToLinkable + , TypecheckHelpers(..) ) where import Control.Concurrent.Extra import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (force, liftRnf, rnf, rwhnf) +import Control.DeepSeq (force, liftRnf, rnf, rwhnf, NFData(..)) import Control.Exception (evaluate) import Control.Exception.Safe -import Control.Lens hiding (List) +import Control.Lens hiding (List, (<.>)) import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Trans.Except +import qualified Control.Monad.Trans.State.Strict as S 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 +import Data.Generics.Schemes +import Data.Generics.Aliases import qualified Data.HashMap.Strict as HashMap import Data.IORef import Data.IntMap (IntMap) @@ -60,12 +64,11 @@ 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) +import Data.Time (UTCTime (..)) import Data.Tuple.Extra (dupe) import Data.Unique as Unique import Debug.Trace +import Development.IDE.Core.FileStore (resetInterfaceStore) import Development.IDE.Core.Preprocessor import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake @@ -80,14 +83,15 @@ 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) + parsedSource, + GhcException(..) + ) import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized import HieDb @@ -105,18 +109,27 @@ import ErrUtils #if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice + +#if MIN_VERSION_ghc(9,2,1) +import GHC.Types.HpcInfo +import GHC.Types.ForeignStubs +import GHC.Types.TypeEnv +#else +import GHC.Driver.Types +#endif + #else import TcSplice +import HscTypes #endif #if MIN_VERSION_ghc(9,2,0) -import Development.IDE.GHC.Compat.Util (emptyUDFM, fsLit, - plusUDFM_C) import GHC (Anchor (anchor), EpaComment (EpaComment), EpaCommentTok (EpaBlockComment, EpaLineComment), epAnnComments, priorComments) +import GHC (ModuleGraph, mgLookupModule, mgModSummaries) import qualified GHC as G import GHC.Hs (LEpaComment) import qualified GHC.Types.Error as Error @@ -147,12 +160,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)" @@ -167,7 +186,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 @@ -178,16 +197,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 @@ -200,12 +219,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 @@ -242,41 +256,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 @@ -310,18 +359,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, @@ -330,25 +376,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) @@ -365,35 +394,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 - :: HscEnv + :: ShakeExtras + -> HscEnv -> TcModuleResult -> ModGuts - -> LinkableType -- ^ use object code or byte code? -> IO (IdeResult HiFileResult) -mkHiFileResultCompile 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 - - (linkable, details, diags) <- + (details, mguts) <- if mg_hsc_src simplified_guts == HsBootFile then do - -- give variables unique OccNames details <- mkBootModDetailsTc session tcGblEnv - pure (Nothing, details, []) + 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, 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 @@ -403,8 +427,73 @@ mkHiFileResultCompile 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 - pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)) + + -- 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 + 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' + + -- 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 + + -- 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'])) + _ -> pure () + + pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file) where dflags = hsc_dflags session' @@ -483,8 +572,10 @@ generateObjectCode session summary guts = do pure (map snd warnings, linkable) -generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateByteCode hscEnv summary guts = do +newtype CoreFileTime = CoreFileTime UTCTime + +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)) <- @@ -499,9 +590,7 @@ generateByteCode hscEnv summary guts = do summary' #endif let unlinked = BCOs bytecode sptEntries - time <- liftIO getCurrentTime let linkable = LM time (ms_mod summary) [unlinked] - pure (map snd warnings, linkable) demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule @@ -582,12 +671,14 @@ addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags addRelativeImport fp modu dflags = dflags {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} -atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO () -atomicFileWrite targetPath write = do +-- | Also resets the interface store +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) `onException` cleanUp + (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) + `onException` cleanUp generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) generateHieAsts hscEnv tcm = @@ -609,12 +700,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{..} = @@ -765,7 +858,7 @@ writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = handleGenerationErrors dflags "extended interface write/compression" $ do hf <- runHsc hscEnv $ GHC.mkHieFile' mod_summary exports ast source - atomicFileWrite targetPath $ flip GHC.writeHieFile hf + atomicFileWrite se targetPath $ flip GHC.writeHieFile hf hash <- Util.getFileHash targetPath indexHieFile se mod_summary srcPath hash hf where @@ -773,13 +866,13 @@ writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = mod_location = ms_location mod_summary targetPath = Compat.ml_hie_file mod_location -writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic] -writeHiFile hscEnv tc = +writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic] +writeHiFile se hscEnv tc = handleGenerationErrors dflags "interface write" $ do - atomicFileWrite targetPath $ \fp -> + 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 @@ -1090,9 +1183,10 @@ recompilation avoidance scheme for subsequent compiles: `HiFileResult` for some reason 4. If the file in question used Template Haskell on the previous compile, then - we need to recompile if any `Linkable` in its transitive closure changed. This - sounds bad, but it is possible to make some improvements. - In particular, we only need to recompile if any of the `Linkable`s actually used during the previous compile change. +we need to recompile if any `Linkable` in its transitive closure changed. This +sounds bad, but it is possible to make some improvements. In particular, we only +need to recompile if any of the `Linkable`s actually used during the previous +compile change. How can we tell if a `Linkable` was actually used while running some TH? @@ -1112,8 +1206,13 @@ were generated) using `Annotation`s, which provide a somewhat general purpose way to serialise arbitrary information along with interface files. Then when deciding whether to recompile, we need to check that the versions -of the linkables used during a previous compile match whatever is currently -in the HPT. +(i.e. hashes) of the linkables used during a previous compile match whatever is +currently in the HPT. + +As we always generate Linkables from core files, we use the core file hash +as a (hopefully) deterministic measure of whether the Linkable has changed. +This is better than using the object file hash (if we have one) because object +file generation is not deterministic. -} data RecompilationInfo m @@ -1121,9 +1220,21 @@ 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 } +-- | Either a regular GHC linkable or a core file that +-- can be later turned into a proper linkable +data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile + +instance NFData IdeLinkable where + rnf (GhcLinkable lb) = rnf lb + rnf (CoreLinkable time _) = rnf time + +ml_core_file :: ModLocation -> FilePath +ml_core_file ml = ml_hi_file ml <.> "core" + -- | Retuns an up-to-date module interface, regenerating if needed. -- Assumes file exists. -- Requires the 'HscEnv' to be set up with dependencies @@ -1137,20 +1248,20 @@ loadInterface -> m ([FileDiagnostic], Maybe HiFileResult) 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) !mod = ms_mod ms mb_dest_version <- case mb_old_version of Just ver -> pure $ Just ver - Nothing -> get_file_version $ toNormalizedFilePath' $ case linkableNeeded of - Just ObjectLinkable -> ml_obj_file (ms_location ms) - _ -> ml_hi_file (ms_location ms) + 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 @@ -1158,123 +1269,133 @@ loadInterface 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 - - let - (recomp_obj_reqd, mb_linkable) = case linkableNeeded of - Nothing -> (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 - -> (UpToDate, Just old_lb) - - | BCOLinkable <- linkableType , not (isObjectLinkable old_lb) - -> (UpToDate, Just old_lb) - - | otherwise -> recompMaybeBecause "missing [wrong type]" - where - recompMaybeBecause msg = case linkableType of - BCOLinkable -> (RecompBecause ("bytecode "++ msg), Nothing) - ObjectLinkable -> case mb_dest_version of -- The destination file should be the object code - Nothing -> (RecompBecause ("object code "++ msg), Nothing) - Just disk_obj_version@(ModificationTime t) -> - -- If we make it this far, assume that the object code on disk is up to date - -- This assertion works because of the sourceMod check - assert (disk_obj_version >= source_version) - (UpToDate, Just $ LM (posixSecondsToUTCTime t) mod [DotO obj_file]) - Just (VFSVersion _) -> error "object code in vfs" - 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 - hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb + | isNothing linkableNeeded || isJust (hirCoreFp old_hir) + -> 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 ([], 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 -> handleErrs $ 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) + where handleErrs = flip catches + [Handler $ \(e :: IOException) -> do_regenerate (RecompBecause $ "Reading core file failed (" ++ show e ++ ")") + ,Handler $ \(e :: GhcException) -> case e of + Signal _ -> throw e + Panic _ -> throw e + _ -> do_regenerate (RecompBecause $ "Reading core file failed (" ++ show e ++ ")") + ] (_, _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 +-- The bytestrings are the hashes of the core files for modules we +-- required to run the TH splices in the given module. +-- See Note [Recompilation avoidance in the presence of TH] +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 build graph 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 :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo -mkDetailsFromIface session iface linkable = do - details <- liftIO $ fixIO $ \details -> do - let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) } +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) - return (HomeModInfo iface details linkable) + +coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts +coreFileToCgGuts session iface details core_file = 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 + -- Implicit binds aren't saved, so we need to regenerate them ourselves. + let implicit_binds = concatMap getImplicitBinds tyCons + 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 diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 35e18819e6..849167988d 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -150,7 +150,7 @@ getModificationTimeImpl missingFileDiags file = do -- But interface files are private, in that only HLS writes them. -- So we implement watching ourselves, and bypass the need for alwaysRerun. isInterface :: NormalizedFilePath -> Bool -isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"] +isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"] -- | Reset the GetModificationTime state of interface files resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM () diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e4c9bcafcd..41ccfc4819 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -17,6 +17,7 @@ module Development.IDE.Core.RuleTypes( ) where import Control.DeepSeq +import Control.Exception (assert) import Control.Lens import Data.Aeson.Types (Value) import Data.Hashable @@ -26,6 +27,7 @@ import Data.Typeable import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.CoreFile import Development.IDE.GHC.Util import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -35,9 +37,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 @@ -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 - -mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult -mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..} +hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp + +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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index d91766d458..b02a58dd9f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -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,6 +775,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco Just session -> do linkableType <- getLinkableType f ver <- use_ GetModificationTime f + 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) @@ -776,6 +784,7 @@ 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 (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs , regenerate = regenerateHiFile session f ms } r <- loadInterface (hscEnv session) ms linkableType recompInfo @@ -897,12 +906,13 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ linkableType <- getLinkableType f hsc <- hscEnv <$> use_ GhcSessionDeps f let compile = fmap ([],) $ use GenerateCore f - (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr + se <- getShakeExtras + (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr let fp = hiFileFingerPrint <$> hiFile hiDiags <- case hiFile of Just hiFile | OnDisk <- status - , not (tmrDeferedError tmr) -> writeHiFileAction hsc hiFile + , not (tmrDeferedError tmr) -> liftIO $ writeHiFile se hsc hiFile _ -> pure [] return (fp, (diags++hiDiags, hiFile)) NotFOI -> do @@ -910,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 @@ -958,11 +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 hsc compNeeded compile tmr + (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of @@ -980,7 +987,7 @@ regenerateHiFile sess f ms compNeeded = do -- We don't write the `.hi` file if there are defered errors, since we won't get -- accurate diagnostics next time if we do hiDiags <- if not $ tmrDeferedError tmr - then writeHiFileAction hsc hiFile + then liftIO $ writeHiFile se hsc hiFile else pure [] pure (hiDiags <> gDiags <> concat wDiags) @@ -990,18 +997,20 @@ regenerateHiFile sess f ms compNeeded = do -- | HscEnv should have deps included already -compileToObjCodeIfNeeded :: 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 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 hsc tmr guts linkableType + (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts pure (diags++diags', res) getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () @@ -1033,12 +1042,57 @@ 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 -- needsCompilationRule :: Rules () needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) +needsCompilationRule file + | "boot" `isSuffixOf` (fromNormalizedFilePath file) = + pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do graph <- useNoFile GetModuleGraph res <- case graph of @@ -1062,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 @@ -1083,7 +1136,7 @@ uses_th_qq (ms_hspp_opts -> dflags) = -- Depends on whether it uses unboxed tuples or sums computeLinkableTypeForDynFlags :: DynFlags -> LinkableType computeLinkableTypeForDynFlags d -#if defined(GHC_PATCHED_UNBOXED_BYTECODE) +#if defined(GHC_PATCHED_UNBOXED_BYTECODE) || MIN_VERSION_ghc(9,2,0) = BCOLinkable #else | unboxed_tuples_or_sums = ObjectLinkable @@ -1097,15 +1150,6 @@ computeLinkableTypeForDynFlags d newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables - -writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] -writeHiFileAction hsc hiFile = do - extras <- getShakeExtras - let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile - liftIO $ do - atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath - writeHiFile hsc hiFile - data RulesConfig = RulesConfig { -- | Disable import cycle checking for improved performance in large codebases checkForImportCycles :: Bool @@ -1172,3 +1216,4 @@ mainRule recorder RulesConfig{..} = do persistentHieFileRule recorder persistentDocMapRule persistentImportMapRule + getLinkableRule recorder diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 61a679d287..1c2876f736 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -79,6 +79,7 @@ module Development.IDE.GHC.Compat( tidyExpr, emptyTidyEnv, corePrepExpr, + corePrepPgm, lintInteractiveExpr, icInteractiveModule, HomePackageTable, @@ -93,6 +94,12 @@ module Development.IDE.GHC.Compat( module UniqSet, module UniqDFM, getDependentMods, + diffBinds, + flattenBinds, + mkRnEnv2, + emptyInScopeSet, + Unfolding(..), + noUnfolding, #if MIN_VERSION_ghc(9,2,0) loadExpr, byteCodeGen, @@ -122,11 +129,12 @@ import GHC hiding (HasSrcSpan, lookupName, exprType) #if MIN_VERSION_ghc(9,0,0) import GHC.Driver.Hooks (hscCompileCoreExprHook) -import GHC.Core (CoreExpr, CoreProgram) +import GHC.Core (CoreExpr, CoreProgram, Unfolding(..), noUnfolding, flattenBinds) import qualified GHC.Core.Opt.Pipeline as GHC import GHC.Core.Tidy (tidyExpr) -import GHC.Types.Var.Env (emptyTidyEnv) +import GHC.Types.Var.Env (emptyTidyEnv, mkRnEnv2, emptyInScopeSet) import qualified GHC.CoreToStg.Prep as GHC +import GHC.CoreToStg.Prep (corePrepPgm) import GHC.Core.Lint (lintInteractiveExpr) #if MIN_VERSION_ghc(9,2,0) import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable) @@ -146,11 +154,11 @@ import GHC.Types.Unique.Set as UniqSet import GHC.Types.Unique.DFM as UniqDFM #else import Hooks (hscCompileCoreExprHook) -import CoreSyn (CoreExpr) +import CoreSyn (CoreExpr, flattenBinds, Unfolding(..), noUnfolding) import qualified SimplCore as GHC import CoreTidy (tidyExpr) -import VarEnv (emptyTidyEnv) -import CorePrep (corePrepExpr) +import VarEnv (emptyTidyEnv, mkRnEnv2, emptyInScopeSet) +import CorePrep (corePrepExpr, corePrepPgm) import CoreLint (lintInteractiveExpr) import ByteCodeGen (coreExprToBCOs) import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods)) @@ -234,6 +242,8 @@ import GHC.ByteCode.Types import GHC.Linker.Loader (loadDecls) import GHC.Data.Maybe import GHC.CoreToStg +import GHC.Core.Utils +import GHC.Types.Var.Env #endif type ModIfaceAnnotation = Annotation diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 9d4cf17e6f..625010fd7c 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -305,6 +305,7 @@ module Development.IDE.GHC.Compat.Core ( -- * Panic PlainGhcException, panic, + panicDoc, -- * Other GHC.CoreModule(..), GHC.SafeHaskellMode(..), diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index 65189a90db..8abff2c6ea 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -6,7 +6,7 @@ module Development.IDE.GHC.Compat.Outputable ( showSDoc, showSDocUnsafe, showSDocForUser, - ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, + ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate, printSDocQualifiedUnsafe, printWithoutUniques, mkPrintUnqualified, diff --git a/ghcide/src/Development/IDE/GHC/CoreFile.hs b/ghcide/src/Development/IDE/GHC/CoreFile.hs new file mode 100644 index 0000000000..5f0cbd981c --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/CoreFile.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | CoreFiles let us serialize Core to a file in order to later recover it +-- without reparsing or retypechecking +module Development.IDE.GHC.CoreFile + ( CoreFile(..) + , codeGutsToCoreFile + , typecheckCoreFile + , readBinCoreFile + , writeBinCoreFile + , getImplicitBinds) where + +import GHC.Fingerprint +import Data.IORef +import Data.Foldable +import Data.List (isPrefixOf) +import Control.Monad.IO.Class +import Control.Monad +import Data.Maybe + +import Development.IDE.GHC.Compat + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Utils.Binary +import GHC.Core +import GHC.CoreToIface +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 +#else +import GHC.Driver.Types +#endif + +#elif MIN_VERSION_ghc(8,6,0) +import Binary +import CoreSyn +import ToIface +import TcIface +import IfaceEnv +import BinIface +import HscTypes +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 + +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 + = TopIfaceNonRec v IfaceExpr + | TopIfaceRec [(v, IfaceExpr)] + deriving (Functor, Foldable, Traversable) + +-- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType', +-- but it does export 'tcIfaceDecl' +-- so we use `IfaceDecl` as a container for all of these +-- invariant: 'IfaceId' is always a 'IfaceId' constructor +type IfaceId = IfaceDecl + +instance Binary (TopIfaceBinding IfaceId) where + put_ bh (TopIfaceNonRec d e) = do + putByte bh 0 + put_ bh d + put_ bh e + put_ bh (TopIfaceRec vs) = do + putByte bh 1 + put_ bh vs + get bh = do + t <- getByte bh + case t of + 0 -> TopIfaceNonRec <$> get bh <*> get bh + 1 -> TopIfaceRec <$> get bh + _ -> error "Binary TopIfaceBinding" + +instance Binary CoreFile where + put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp + get bh = CoreFile <$> lazyGet bh <*> get bh + +readBinCoreFile + :: NameCacheUpdater + -> FilePath + -> IO (CoreFile, Fingerprint) +readBinCoreFile name_cache fat_hi_path = do + bh <- readBinMem fat_hi_path + file <- getWithUserData name_cache bh + !fp <- Util.getFileHash fat_hi_path + return (file, fp) + +-- | Write a core file +writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint +writeBinCoreFile core_path fat_iface = do + bh <- openBinMem initBinMemSize + + let quietTrace = +#if MIN_VERSION_ghc(9,2,0) + QuietBinIFace +#else + (const $ pure ()) +#endif + + putWithUserData quietTrace bh fat_iface + + -- 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 + :: 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 +isNotImplictBind :: CoreBind -> Bool +isNotImplictBind bind = any (not . isImplicitId) $ bindBindings bind + +bindBindings :: CoreBind -> [Var] +bindBindings (NonRec b _) = [b] +bindBindings (Rec bnds) = map fst bnds + +getImplicitBinds :: TyCon -> [CoreBind] +getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc + where + cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) + +getTyConImplicitBinds :: TyCon -> [CoreBind] +getTyConImplicitBinds tc + | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId + | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + +getClassImplicitBinds :: Class -> [CoreBind] +getClassImplicitBinds cls + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] + +get_defn :: Id -> CoreBind +get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) + +toIfaceTopBndr :: Module -> Id -> IfaceId +toIfaceTopBndr mod id + = IfaceId (mangleDeclName mod $ getName id) + (toIfaceType (idType id)) + (toIfaceIdDetails (idDetails id)) + (toIfaceIdInfo (idInfo id)) + +toIfaceTopBind :: Module -> Bind Id -> TopIfaceBinding IfaceId +toIfaceTopBind mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr mod b) (toIfaceExpr r) +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 _) = + initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do + tcTopIfaceBindings type_var prepd_binding + +-- | Internal names can't be serialized, so we mange them +-- to an external name and restore at deserialization time +-- This is necessary because we rely on stuffing TopIfaceBindings into +-- a IfaceId because we don't have access to 'tcIfaceType' etc.. +mangleDeclName :: Module -> Name -> Name +mangleDeclName mod name + | isExternalName name = name + | otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name) + +-- | Mangle the module name too to avoid conflicts +mangleModule :: Module -> Module +mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod)) + +isGhcideModule :: Module -> Bool +isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod) + +-- Is this a fake external name that we need to make into an internal name? +isGhcideName :: Name -> Bool +isGhcideName = isGhcideModule . nameModule + +tcTopIfaceBindings :: IORef TypeEnv -> [TopIfaceBinding IfaceId] + -> IfL [CoreBind] +tcTopIfaceBindings ty_var ver_decls + = do + int <- mapM (traverse $ tcIfaceId) ver_decls + let all_ids = concatMap toList int + liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids) + extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int + +tcIfaceId :: IfaceId -> IfL Id +tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name + where + unmangle_decl_name ifid@IfaceId{ ifName = name } + -- Check if the name is mangled + | isGhcideName name = do + name' <- newIfaceName (mkVarOcc $ getOccString name) + pure $ ifid{ ifName = name' } + | otherwise = pure ifid + -- invariant: 'IfaceId' is always a 'IfaceId' constructor + getIfaceId (AnId id) = id + getIfaceId _ = error "tcIfaceId: got non Id" + +tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind +tc_iface_bindings (TopIfaceNonRec v e) = do + e' <- tcIfaceExpr e + pure $ NonRec v e' +tc_iface_bindings (TopIfaceRec vs) = do + vs' <- traverse (\(v, e) -> (,) <$> pure v <*> tcIfaceExpr e) vs + pure $ Rec vs' diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 11905b22d1..3dfaaedf80 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 2c536026cd..d01d9f3260 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -83,6 +83,8 @@ data IdeOptions = IdeOptions , optProgressStyle :: ProgressReportingStyle , optRunSubset :: Bool -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed + , optVerifyCoreFile :: Bool + -- ^ Verify core files after serialization } data OptHaddockParse = HaddockParse | NoHaddockParse @@ -135,6 +137,7 @@ defaultIdeOptions session = IdeOptions ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit ,optRunSubset = True + ,optVerifyCoreFile = False ,optMaxDirtyAge = 100 } diff --git a/ghcide/test/data/THCoreFile/THA.hs b/ghcide/test/data/THCoreFile/THA.hs new file mode 100644 index 0000000000..93a86c8dee --- /dev/null +++ b/ghcide/test/data/THCoreFile/THA.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +module THA where +import Language.Haskell.TH +import Control.Monad (when) + +th_a :: DecsQ +th_a = do + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + [d| a = () |] + +data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show +data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show +data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show + +class SingleMethodClass a where + classMethod :: a -> Bool + +instance SingleMethodClass Char where + classMethod = (== 'z') diff --git a/ghcide/test/data/THCoreFile/THB.hs b/ghcide/test/data/THCoreFile/THB.hs new file mode 100644 index 0000000000..672248d351 --- /dev/null +++ b/ghcide/test/data/THCoreFile/THB.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA +import Control.Monad (when) + +$(do + -- Need to verify in both defining module and usage module" + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + th_a) diff --git a/ghcide/test/data/THCoreFile/THC.hs b/ghcide/test/data/THCoreFile/THC.hs new file mode 100644 index 0000000000..79a02ef601 --- /dev/null +++ b/ghcide/test/data/THCoreFile/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/ghcide/test/data/THCoreFile/hie.yaml b/ghcide/test/data/THCoreFile/hie.yaml new file mode 100644 index 0000000000..36872d3531 --- /dev/null +++ b/ghcide/test/data/THCoreFile/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}} diff --git a/ghcide/test/data/THUnboxed/THA.hs b/ghcide/test/data/THUnboxed/THA.hs index a2bd3a70d9..be07eb4b86 100644 --- a/ghcide/test/data/THUnboxed/THA.hs +++ b/ghcide/test/data/THUnboxed/THA.hs @@ -1,9 +1,16 @@ -{-# LANGUAGE TemplateHaskell, UnboxedTuples #-} +{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-} module THA where import Language.Haskell.TH -f :: Int -> (# Int, Int #) -f x = (# x , x+1 #) +data Foo = Foo !Int !Char !String + deriving Show + +newtype Bar = Bar Int + deriving Show + + +f :: Int -> (# Int, Int, Foo, Bar#) +f x = (# x , x+1 , Foo x 'a' "test", Bar 1 #) th_a :: DecsQ -th_a = case f 1 of (# a , b #) -> [d| a = () |] +th_a = case f 1 of (# a , b, Foo _ _ _, Bar !_ #) -> [d| a = () |] diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index b91af99c74..f19b732cdc 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4622,6 +4622,7 @@ thTests = return () , thReloadingTest False , thLoadingTest + , thCoreTest , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 , thLinkingTest False @@ -4678,6 +4679,12 @@ thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \ _ <- openDoc thb "haskell" expectNoMoreDiagnostics 1 +thCoreTest :: TestTree +thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do + let thc = dir "THC.hs" + _ <- openDoc thc "haskell" + expectNoMoreDiagnostics 1 + -- | test that TH is reevaluated on typecheck thReloadingTest :: Bool -> TestTree thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do @@ -6604,7 +6611,7 @@ runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do shakeProfiling <- getEnv "SHAKE_PROFILING" let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir + [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] ] ++ extraOptions -- HIE calls getXgdDirectory which assumes that HOME is set. diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index c9865099f3..bef6f58d32 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -81,6 +81,7 @@ library , stm-containers , time , transformers + , unliftio , unordered-containers if flag(embed-files) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 02a1129390..449aba1112 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -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, diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 2979efd9cc..4f265bbce2 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -45,18 +45,22 @@ import qualified Data.Text as T import Data.Time (getCurrentTime) import Data.Typeable (Typeable) import Development.IDE (GetModSummary (..), + GetDependencyInformation (..), + GetLinkable (..), GhcSessionIO (..), IdeState, ModSummaryResult (..), NeedsCompilation (NeedsCompilation), VFSModified (..), evalGhcEnv, hscEnvWithImportPaths, printOutputable, runAction, + linkableHomeMod, textToStringBuffer, toNormalizedFilePath', uriToFilePath', useNoFile_, - useWithStale_, use_) + useWithStale_, use_, uses_) import Development.IDE.Core.Rules (GhcSessionDepsConfig (..), ghcSessionDepsDefinition) +import Development.IDE.Import.DependencyInformation ( reachableModules ) import Development.IDE.GHC.Compat hiding (typeKind, unitState) import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as SrcLoc @@ -294,10 +298,19 @@ runEvalCmd plId st EvalParams{..} = setContext [Compat.IIModule modName] Right <$> getSession evalCfg <- lift $ getEvalConfig plId + + -- Get linkables for all modules below us + -- This can be optimised to only get the linkables for the symbols depended on by + -- the statement we are parsing + lbs <- liftIO $ runAction "eval: GetLinkables" st $ do + linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp + uses_ GetLinkable (filter (/= nfp) linkables_needed) -- We don't need the linkable for the current module + let hscEnv'' = hscEnv' { hsc_HPT = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] } + edits <- perf "edits" $ liftIO $ - evalGhcEnv hscEnv' $ + evalGhcEnv hscEnv'' $ runTests evalCfg (st, fp) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 8c1ddecf55..91ac93d59f 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -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 {..} =