From 1ed44ef2ea705c25b8370cbf177b94390b6958bb Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 11 Feb 2022 12:58:16 +0530 Subject: [PATCH 01/11] Serialize core to core files Add a `.hi.core` file format to which we serialize out compiled core after generating it. This core is then read back in on subsequent runs and compiled to bytecode. This greatly speeds up startup times when we need compilation, as we can simply read bytecode off the disk instead of having to recompile a lot of modules This is based off Fat Interface files in GHC: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7502 - Also add --verify-core-file to do roundtrip testing of core-files - Use closed world assumption for core and .hie files --- ghcide/exe/Arguments.hs | 2 + ghcide/exe/Main.hs | 1 + ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Core/Compile.hs | 250 +++++++++++++----- ghcide/src/Development/IDE/Core/FileStore.hs | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 34 ++- ghcide/src/Development/IDE/GHC/Compat.hs | 20 +- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 1 + .../Development/IDE/GHC/Compat/Outputable.hs | 2 +- ghcide/src/Development/IDE/GHC/CoreFile.hs | 212 +++++++++++++++ ghcide/src/Development/IDE/Types/Options.hs | 3 + ghcide/test/data/THCoreFile/THA.hs | 23 ++ ghcide/test/data/THCoreFile/THB.hs | 13 + ghcide/test/data/THCoreFile/THC.hs | 5 + ghcide/test/data/THCoreFile/hie.yaml | 1 + ghcide/test/data/THUnboxed/THA.hs | 15 +- ghcide/test/exe/Main.hs | 9 +- 17 files changed, 497 insertions(+), 97 deletions(-) create mode 100644 ghcide/src/Development/IDE/GHC/CoreFile.hs create mode 100644 ghcide/test/data/THCoreFile/THA.hs create mode 100644 ghcide/test/data/THCoreFile/THB.hs create mode 100644 ghcide/test/data/THCoreFile/THC.hs create mode 100644 ghcide/test/data/THCoreFile/hie.yaml 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..606553b522 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -35,10 +35,10 @@ module Development.IDE.Core.Compile 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 @@ -62,10 +62,11 @@ import Data.Maybe import qualified Data.Text as T import Data.Time (UTCTime (..), getCurrentTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) 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 @@ -84,6 +85,7 @@ 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, @@ -105,13 +107,23 @@ 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) +#if MIN_VERSION_ghc(9,2,0) import GHC (Anchor (anchor), EpaComment (EpaComment), EpaCommentTok (EpaBlockComment, EpaLineComment), @@ -121,6 +133,9 @@ import qualified GHC as G import GHC.Hs (LEpaComment) import qualified GHC.Types.Error as Error #endif +import qualified Control.Monad.Trans.State.Strict as S +import Data.Generics.Schemes +import Data.Generics.Aliases -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule @@ -369,31 +384,32 @@ mkHiFileResultNoCompile session tcm = do pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm) 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 ltype = 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 + BCOLinkable -> generateByteCode se WriteCoreFile - (linkable, details, diags) <- + (linkable, details, mguts, diags) <- if mg_hsc_src simplified_guts == HsBootFile then do -- give variables unique OccNames details <- mkBootModDetailsTc session tcGblEnv - pure (Nothing, details, []) + pure (Nothing, details, Nothing, []) else do -- give variables unique OccNames (guts, details) <- tidyProgram session simplified_guts (diags, linkable) <- genLinkable session ms guts - pure (linkable, details, diags) + pure (linkable, details, Just guts, diags) #if MIN_VERSION_ghc(9,0,1) let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface <- mkFullIface session partial_iface Nothing @@ -404,6 +420,51 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do (final_iface,_) <- mkIface session Nothing details simplified_guts #endif let mod_info = HomeModInfo final_iface details linkable + + -- 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 + + -- 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 (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)) where @@ -483,8 +544,10 @@ generateObjectCode session summary guts = do pure (map snd warnings, linkable) -generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateByteCode hscEnv summary guts = do +data WriteCoreFile = WriteCoreFile | CoreFileExists !UTCTime + +generateByteCode :: ShakeExtras -> WriteCoreFile -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateByteCode se write_core hscEnv summary guts = do fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do (warnings, (_, bytecode, sptEntries)) <- @@ -499,7 +562,14 @@ generateByteCode hscEnv summary guts = do summary' #endif let unlinked = BCOs bytecode sptEntries - time <- liftIO getCurrentTime + 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) @@ -582,12 +652,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 () +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 >> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath))) + `onException` cleanUp generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) generateHieAsts hscEnv tcm = @@ -765,7 +837,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,10 +845,10 @@ 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 @@ -1124,31 +1196,48 @@ data RecompilationInfo m , 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 -- See Note [Recompilation avoidance in the presence of TH] loadInterface :: (MonadIO m, MonadMask m) - => HscEnv + => ShakeExtras + -> HscEnv -> ModSummary -> Maybe LinkableType -> RecompilationInfo m -> m ([FileDiagnostic], Maybe HiFileResult) -loadInterface session ms linkableNeeded RecompilationInfo{..} = do +loadInterface se session ms linkableNeeded RecompilationInfo{..} = do let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session mb_old_iface = hm_iface . hirHomeMod . 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 -> do + let file = case linkableNeeded of + Just ObjectLinkable -> obj_file + Just BCOLinkable -> core_file + Nothing -> iface_file + get_file_version (toNormalizedFilePath' file) -- The source is modified if it is newer than the destination let sourceMod = case mb_dest_version of @@ -1162,42 +1251,47 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do <- 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" + (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 @@ -1217,12 +1311,12 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do -> do_regenerate msg | otherwise -> return ([], Just old_hir) Nothing -> do - hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb + (warns, hmi) <- liftIO $ mkDetailsFromIface se sessionWithMsDynFlags ms iface lb -- 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) + return (warns, Just $ mkHiFileResult ms hmi runtime_deps) (_, _reason) -> do_regenerate _reason -- | ModDepTime is stored as an annotation in the iface to @@ -1269,12 +1363,34 @@ showReason UpToDate = "UpToDate" showReason MustCompile = "MustCompile" showReason (RecompBecause s) = s -mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo -mkDetailsFromIface session iface linkable = do +mkDetailsFromIface :: ShakeExtras -> HscEnv -> ModSummary -> ModIface -> Maybe IdeLinkable -> IO ([FileDiagnostic], HomeModInfo) +mkDetailsFromIface se session ms iface ide_linkable = do details <- liftIO $ fixIO $ \details -> do - let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) } + 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) + (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 + 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 [] -- | 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/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index d91766d458..bab7dfc88b 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -768,6 +768,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco Just session -> do linkableType <- getLinkableType f ver <- use_ GetModificationTime f + se@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) @@ -778,7 +779,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} , regenerate = regenerateHiFile session f ms } - r <- loadInterface (hscEnv session) ms linkableType recompInfo + r <- loadInterface se (hscEnv session) ms linkableType recompInfo case r of (diags, Nothing) -> return (Nothing, (diags, Nothing)) (diags, Just x) -> do @@ -897,12 +898,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) <- compileToObjCodeIfNeeded 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 @@ -961,8 +963,10 @@ regenerateHiFile sess f ms compNeeded = 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) <- compileToObjCodeIfNeeded se hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of @@ -980,7 +984,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 +994,18 @@ 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 +compileToObjCodeIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult) +compileToObjCodeIfNeeded _ hsc Nothing _ tmr = do incrementRebuildCount res <- liftIO $ mkHiFileResultNoCompile hsc tmr pure ([], Just $! res) -compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do +compileToObjCodeIfNeeded se hsc (Just linkableType) 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 linkableType pure (diags++diags', res) getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () @@ -1039,6 +1043,9 @@ 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 @@ -1097,15 +1104,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 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..fdb6c87fb1 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/CoreFile.hs @@ -0,0 +1,212 @@ +{-# 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 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 + +#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 +#endif + +-- | Initial ram buffer to allocate for writing interface files +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 + +newtype CoreFile = CoreFile { cf_bindings :: [TopIfaceBinding IfaceId] } + +-- | 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 a) = put_ bh a + get bh = CoreFile <$> get bh + +readBinCoreFile + :: NameCacheUpdater + -> FilePath + -> IO CoreFile +readBinCoreFile name_cache fat_hi_path = do + bh <- readBinMem fat_hi_path + getWithUserData name_cache bh + +-- | Write a core file +writeBinCoreFile :: FilePath -> CoreFile -> IO () +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 + +-- 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) + +-- | 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/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. From 5c3f94130558d295c0fd045312624f06d9e36a69 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Thu, 17 Mar 2022 17:42:01 +0530 Subject: [PATCH 02/11] 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. --- ghcide/src/Development/IDE/Core/Compile.hs | 476 +++++++++--------- ghcide/src/Development/IDE/Core/RuleTypes.hs | 62 ++- ghcide/src/Development/IDE/Core/Rules.hs | 85 +++- ghcide/src/Development/IDE/GHC/CoreFile.hs | 38 +- ghcide/src/Development/IDE/GHC/Orphans.hs | 5 + hls-graph/hls-graph.cabal | 1 + .../Development/IDE/Graph/Internal/Types.hs | 3 +- .../src/Ide/Plugin/Retrie.hs | 4 +- 8 files changed, 376 insertions(+), 298 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 606553b522..3cab68bbbf 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -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 - - -- 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 (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)) + 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' @@ -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) - - -- The source is modified if it is newer than the destination + Nothing -> get_file_version (toNormalizedFilePath' iface_file) + + -- 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". diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e4c9bcafcd..73d93e4778 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -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 - -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 bab7dfc88b..12780b431d 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,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 diff --git a/ghcide/src/Development/IDE/GHC/CoreFile.hs b/ghcide/src/Development/IDE/GHC/CoreFile.hs index fdb6c87fb1..5f0cbd981c 100644 --- a/ghcide/src/Development/IDE/GHC/CoreFile.hs +++ b/ghcide/src/Development/IDE/GHC/CoreFile.hs @@ -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 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/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-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 {..} = From 5c3b3d6e2aa671fff59e90502071f14a832fb694 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 18 Jun 2022 13:08:51 +0530 Subject: [PATCH 03/11] Fix eval plugin --- .../src/Ide/Plugin/Eval/CodeLens.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) 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..5f50cef44b 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 linkables_needed + 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) From 8fdc76900f9836e098ed85d1b3d81f2d566cb1ea Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 19 Jun 2022 10:32:17 +0200 Subject: [PATCH 04/11] Shake store -> Values store --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 3cab68bbbf..5b319643f5 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -1313,7 +1313,7 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns = Just (mod, bs) go _ = Nothing --- | checkLinkableDependencies compares the core files in the shake store to +-- | checkLinkableDependencies compares the core files in the Values 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] From e9d879deced93c95c2e86dc1a0fa34fde47d23d5 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 19 Jun 2022 10:45:03 +0200 Subject: [PATCH 05/11] fix a few imports --- ghcide/src/Development/IDE/Core/Compile.hs | 8 ++++---- ghcide/src/Development/IDE/Core/RuleTypes.hs | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 5b319643f5..8f2d383695 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -45,6 +45,7 @@ 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 @@ -52,6 +53,8 @@ import qualified Data.ByteString as BS 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) @@ -124,14 +127,11 @@ import GHC (Anchor (anchor), 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 #endif -import GHC (ModuleGraph, mgLookupModule, mgModSummaries) -import qualified Control.Monad.Trans.State.Strict as S -import Data.Generics.Schemes -import Data.Generics.Aliases -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 73d93e4778..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 @@ -43,8 +45,6 @@ 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) From f2c5a9a3aea43f61efe07b0501eb6184483af01c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 19 Jun 2022 10:52:49 +0200 Subject: [PATCH 06/11] Values store -> build graph --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 8f2d383695..946a3a4e86 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -1313,7 +1313,7 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns = Just (mod, bs) go _ = Nothing --- | checkLinkableDependencies compares the core files in the Values store 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] From c166153226957cfd6e9b599770401b91f7510e01 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sun, 19 Jun 2022 14:33:07 +0530 Subject: [PATCH 07/11] Don't force codegen from the corefile if we just need the hash --- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 12780b431d..4b5fac7502 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -784,7 +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 linkableHash <$> uses_ GetLinkable fs + , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs , regenerate = regenerateHiFile session f ms } r <- loadInterface (hscEnv session) ms linkableType recompInfo From 7588c19734681fe6ff3bfed2552ab7e7ad1008b2 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sun, 19 Jun 2022 17:32:40 +0530 Subject: [PATCH 08/11] Address some review comments --- ghcide/src/Development/IDE/Core/Compile.hs | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 946a3a4e86..eef7bcc686 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -1181,9 +1181,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? @@ -1203,8 +1204,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 @@ -1276,7 +1282,7 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do -- If we have an old value, just return it case old_value of Just (old_hir, _) - | if isJust linkableNeeded then isJust (hirCoreFp old_hir) else True + | 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) @@ -1305,6 +1311,9 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do -- | Find the runtime dependencies by looking at the annotations -- serialized in the iface +-- 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 From 37f573b360b77bb167635330d79890a3e0640e2b Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sun, 19 Jun 2022 17:28:25 +0530 Subject: [PATCH 09/11] Fix eval plugin --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 5f50cef44b..4f265bbce2 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -304,7 +304,7 @@ runEvalCmd plId st EvalParams{..} = -- the statement we are parsing lbs <- liftIO $ runAction "eval: GetLinkables" st $ do linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp - uses_ GetLinkable linkables_needed + 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 <- From e0edcc74b91a75a5d55dbdde11adedfd78eab389 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sun, 19 Jun 2022 17:34:00 +0530 Subject: [PATCH 10/11] GHC 9.2 supports unboxed things in bytecode --- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 4b5fac7502..b02a58dd9f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -1136,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 From 0db8920130d5d9ce948ec98dba0c01aa8dfdca40 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sun, 19 Jun 2022 20:17:41 +0530 Subject: [PATCH 11/11] Handle exceptions when reading core files --- ghcide/src/Development/IDE/Core/Compile.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index eef7bcc686..7496b3d5fa 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -89,7 +89,9 @@ import Development.IDE.Types.Options import Development.IDE.GHC.CoreFile import GHC (ForeignHValue, GetDocsFailure (..), - parsedSource) + parsedSource, + GhcException(..) + ) import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized import HieDb @@ -1301,12 +1303,20 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do 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 + | 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 -- | Find the runtime dependencies by looking at the annotations