Serialize Core

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)

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
         }

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

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

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -17,6 +17,7 @@ module Development.IDE.Core.RuleTypes(
     ) where
 
 import           Control.DeepSeq
+import           Control.Exception                            (assert)
 import           Control.Lens
 import           Data.Aeson.Types                             (Value)
 import           Data.Hashable
@@ -26,6 +27,7 @@ import           Data.Typeable
 import           Development.IDE.GHC.Compat                   hiding
                                                               (HieFileResult)
 import           Development.IDE.GHC.Compat.Util
+import           Development.IDE.GHC.CoreFile
 import           Development.IDE.GHC.Util
 import           Development.IDE.Graph
 import           Development.IDE.Import.DependencyInformation
@@ -35,9 +37,7 @@ import           GHC.Generics                                 (Generic)
 
 import qualified Data.Binary                                  as B
 import           Data.ByteString                              (ByteString)
-import qualified Data.ByteString.Lazy                         as LBS
 import           Data.Text                                    (Text)
-import           Data.Time
 import           Development.IDE.Import.FindImports           (ArtifactsLocation)
 import           Development.IDE.Spans.Common
 import           Development.IDE.Spans.LocalBindings
@@ -91,6 +91,26 @@ data GenerateCore = GenerateCore
 instance Hashable GenerateCore
 instance NFData   GenerateCore
 
+type instance RuleResult GetLinkable = LinkableResult
+
+data LinkableResult
+  = LinkableResult
+  { linkableHomeMod :: !HomeModInfo
+  , linkableHash    :: !ByteString
+  -- ^ The hash of the core file
+  }
+
+instance Show LinkableResult where
+    show = show . mi_module . hm_iface . linkableHomeMod
+
+instance NFData LinkableResult where
+    rnf = rwhnf
+
+data GetLinkable = GetLinkable
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetLinkable
+instance NFData   GetLinkable
+
 data GetImportMap = GetImportMap
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetImportMap
@@ -138,9 +158,10 @@ data TcModuleResult = TcModuleResult
     -- ^ Typechecked splice information
     , tmrDeferedError    :: !Bool
     -- ^ Did we defer any type errors for this module?
-    , tmrRuntimeModules  :: !(ModuleEnv UTCTime)
+    , tmrRuntimeModules  :: !(ModuleEnv ByteString)
         -- ^ Which modules did we need at runtime while compiling this file?
         -- Used for recompilation checking in the presence of TH
+        -- Stores the hash of their core file
     }
 instance Show TcModuleResult where
     show = show . pm_mod_summary . tmrParsed
@@ -155,30 +176,29 @@ data HiFileResult = HiFileResult
     { hirModSummary :: !ModSummary
     -- Bang patterns here are important to stop the result retaining
     -- a reference to a typechecked module
-    , hirHomeMod    :: !HomeModInfo
-    -- ^ Includes the Linkable iff we need object files
-    , hirIfaceFp    :: ByteString
+    , hirModIface   :: !ModIface
+    , hirModDetails :: ModDetails
+    -- ^ Populated lazily
+    , hirIfaceFp    :: !ByteString
     -- ^ Fingerprint for the ModIface
-    , hirLinkableFp :: ByteString
-    -- ^ Fingerprint for the Linkable
-    , hirRuntimeModules :: !(ModuleEnv UTCTime)
+    , hirRuntimeModules :: !(ModuleEnv ByteString)
     -- ^ same as tmrRuntimeModules
+    , hirCoreFp     :: !(Maybe (CoreFile, ByteString))
+    -- ^ If we wrote a core file for this module, then its contents (lazily deserialised)
+    -- along with its hash
     }
 
 hiFileFingerPrint :: HiFileResult -> ByteString
-hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp
-
-mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult
-mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..}
+hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp
+
+mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult
+mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =
+    assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _)
+                                -> getModuleHash hirModIface == cf_iface_hash
+                              _ -> True)
+    HiFileResult{..}
   where
-    hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes
-    hirLinkableFp = case hm_linkable hirHomeMod of
-      Nothing -> ""
-      Just (linkableTime -> l)  -> LBS.toStrict $
-        B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)
-
-hirModIface :: HiFileResult -> ModIface
-hirModIface = hm_iface . hirHomeMod
+    hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes
 
 instance NFData HiFileResult where
     rnf = rwhnf

ghcide/src/Development/IDE/Core/Rules.hs

@@ -99,7 +99,7 @@ import           Data.Tuple.Extra
 import           Development.IDE.Core.Compile
 import           Development.IDE.Core.FileExists hiding (LogShake, Log)
 import           Development.IDE.Core.FileStore               (getFileContents,
-                                                               resetInterfaceStore)
+                                                               getModTime)
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.OfInterest hiding (LogShake, Log)
 import           Development.IDE.Core.PositionMapping
@@ -135,7 +135,7 @@ import           Ide.Plugin.Config
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.Types                           (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo))
 import           Language.LSP.VFS
-import           System.Directory                             (makeAbsolute)
+import           System.Directory                             (makeAbsolute, doesFileExist)
 import           Data.Default                                 (def, Default)
 import           Ide.Plugin.Properties                        (HasProperty,
                                                                KeyNameProxy,
@@ -154,6 +154,9 @@ import qualified Development.IDE.Core.Shake as Shake
 import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake)
 import qualified Development.IDE.Types.Logger as Logger
 import qualified Development.IDE.Types.Shake as Shake
+import           Development.IDE.GHC.CoreFile
+import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Control.Monad.IO.Unlift
 
 data Log
   = LogShake Shake.Log
@@ -673,9 +676,13 @@ typeCheckRuleDefinition hsc pm = do
   setPriority priorityTypeCheck
   IdeOptions { optDefer = defer } <- getIdeOptions
 
-  linkables_to_keep <- currentLinkables
+  unlift <- askUnliftIO
+  let dets = TypecheckHelpers
+           { getLinkablesToKeep = unliftIO unlift $ currentLinkables
+           , getLinkables = unliftIO unlift . uses_ GetLinkable
+           }
   addUsageDependencies $ liftIO $
-    typecheckModule defer hsc linkables_to_keep pm
+    typecheckModule defer hsc dets pm
   where
     addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
     addUsageDependencies a = do
@@ -752,7 +759,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps
             ifaces <- uses_ GetModIface deps
 
-            let inLoadOrder = map hirHomeMod ifaces
+            let            inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces
             session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions
 
             Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])
@@ -768,6 +775,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
     Just session -> do
       linkableType <- getLinkableType f
       ver <- use_ GetModificationTime f
+      ShakeExtras{ideNc} <- getShakeExtras
       let m_old = case old of
             Shake.Succeeded (Just old_version) v -> Just (v, old_version)
             Shake.Stale _   (Just old_version) v -> Just (v, old_version)
@@ -776,6 +784,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
+            , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
             , regenerate = regenerateHiFile session f ms
             }
       r <- loadInterface (hscEnv session) ms linkableType recompInfo
@@ -897,23 +906,20 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
       linkableType <- getLinkableType f
       hsc <- hscEnv <$> use_ GhcSessionDeps f
       let compile = fmap ([],) $ use GenerateCore f
-      (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr
+      se <- getShakeExtras
+      (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr
       let fp = hiFileFingerPrint <$> hiFile
       hiDiags <- case hiFile of
         Just hiFile
           | OnDisk <- status
-          , not (tmrDeferedError tmr) -> writeHiFileAction hsc hiFile
+          , not (tmrDeferedError tmr) -> liftIO $ writeHiFile se hsc hiFile
         _ -> pure []
       return (fp, (diags++hiDiags, hiFile))
     NotFOI -> do
       hiFile <- use GetModIfaceFromDiskAndIndex f
       let fp = hiFileFingerPrint <$> hiFile
       return (fp, ([], hiFile))
 
-  -- Record the linkable so we know not to unload it
-  whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do
-      compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
-      liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
   pure res
 
 -- | Count of total times we asked GHC to recompile
@@ -958,11 +964,12 @@ regenerateHiFile sess f ms compNeeded = do
               Nothing -> pure (diags', Nothing)
               Just tmr -> do
 
-                -- compile writes .o file
                 let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
 
+                se <- getShakeExtras
+
                 -- Bang pattern is important to avoid leaking 'tmr'
-                (diags'', !res) <- compileToObjCodeIfNeeded hsc compNeeded compile tmr
+                (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr
 
                 -- Write hi file
                 hiDiags <- case res of
@@ -980,7 +987,7 @@ regenerateHiFile sess f ms compNeeded = do
                     -- We don't write the `.hi` file if there are defered errors, since we won't get
                     -- accurate diagnostics next time if we do
                     hiDiags <- if not $ tmrDeferedError tmr
-                               then writeHiFileAction hsc hiFile
+                               then liftIO $ writeHiFile se hsc hiFile
                                else pure []
 
                     pure (hiDiags <> gDiags <> concat wDiags)
@@ -990,18 +997,20 @@ regenerateHiFile sess f ms compNeeded = do
 
 
 -- | HscEnv should have deps included already
-compileToObjCodeIfNeeded :: HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
-compileToObjCodeIfNeeded hsc Nothing _ tmr = do
+-- This writes the core file if a linkable is required
+-- The actual linkable will be generated on demand when required by `GetLinkable`
+writeCoreFileIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)
+writeCoreFileIfNeeded _ hsc Nothing _ tmr = do
   incrementRebuildCount
   res <- liftIO $ mkHiFileResultNoCompile hsc tmr
   pure ([], Just $! res)
-compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do
+writeCoreFileIfNeeded se hsc (Just _) getGuts tmr = do
   incrementRebuildCount
   (diags, mguts) <- getGuts
   case mguts of
     Nothing -> pure (diags, Nothing)
     Just guts -> do
-      (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType
+      (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts
       pure (diags++diags', res)
 
 getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()
@@ -1033,12 +1042,57 @@ usePropertyAction kn plId p = do
 
 -- ---------------------------------------------------------------------
 
+getLinkableRule :: Recorder (WithPriority Log) -> Rules ()
+getLinkableRule recorder =
+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do
+    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f
+    HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f
+    let obj_file  = ml_obj_file (ms_location ms)
+        core_file = ml_core_file (ms_location ms)
+    -- Can't use `GetModificationTime` rule because the core file was possibly written in this
+    -- very session, so the results aren't reliable
+    core_t <- liftIO $ getModTime core_file
+    case hirCoreFp of
+      Nothing -> error "called GetLinkable for a file without a linkable"
+      Just (bin_core, hash) -> do
+        session <- use_ GhcSessionDeps f
+        ShakeExtras{ideNc} <- getShakeExtras
+        let namecache_updater = mkUpdater ideNc
+        linkableType <- getLinkableType f >>= \case
+          Nothing -> error "called GetLinkable for a file which doesn't need compilation"
+          Just t -> pure t
+        (warns, hmi) <- case linkableType of
+          -- Bytecode needs to be regenerated from the core file
+          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)
+          -- Object code can be read from the disk
+          ObjectLinkable -> do
+            -- object file is up to date if it is newer than the core file
+            -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and
+            -- thus bump its modification time, forcing this rule to be rerun every time.
+            exists <- liftIO $ doesFileExist obj_file
+            mobj_time <- liftIO $
+              if exists
+              then Just <$> getModTime obj_file
+              else pure Nothing
+            case mobj_time of
+              Just obj_t
+                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file]))
+              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time")
+        -- Record the linkable so we know not to unload it
+        whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do
+            compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction
+            liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time
+        return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash))
+
 -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH
 getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)
 getLinkableType f = use_ NeedsCompilation f
 
 -- needsCompilationRule :: Rules ()
 needsCompilationRule :: NormalizedFilePath  -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))
+needsCompilationRule file 
+  | "boot" `isSuffixOf` (fromNormalizedFilePath file) = 
+    pure (Just $ encodeLinkableType Nothing, Just Nothing)
 needsCompilationRule file = do
   graph <- useNoFile GetModuleGraph
   res <- case graph of
@@ -1062,7 +1116,6 @@ needsCompilationRule file = do
             (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps)
                 (uses NeedsCompilation revdeps)
         pure $ computeLinkableType ms modsums (map join needsComps)
-
   pure (Just $ encodeLinkableType res, Just res)
   where
     computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType
@@ -1083,7 +1136,7 @@ uses_th_qq (ms_hspp_opts -> dflags) =
 -- Depends on whether it uses unboxed tuples or sums
 computeLinkableTypeForDynFlags :: DynFlags -> LinkableType
 computeLinkableTypeForDynFlags d
-#if defined(GHC_PATCHED_UNBOXED_BYTECODE)
+#if defined(GHC_PATCHED_UNBOXED_BYTECODE) || MIN_VERSION_ghc(9,2,0)
           = BCOLinkable
 #else
           | unboxed_tuples_or_sums = ObjectLinkable
@@ -1097,15 +1150,6 @@ computeLinkableTypeForDynFlags d
 newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
 instance IsIdeGlobal CompiledLinkables
 
-
-writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic]
-writeHiFileAction hsc hiFile = do
-    extras <- getShakeExtras
-    let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile
-    liftIO $ do
-        atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath
-        writeHiFile hsc hiFile
-
 data RulesConfig = RulesConfig
     { -- | Disable import cycle checking for improved performance in large codebases
       checkForImportCycles :: Bool
@@ -1172,3 +1216,4 @@ mainRule recorder RulesConfig{..} = do
     persistentHieFileRule recorder
     persistentDocMapRule
     persistentImportMapRule
+    getLinkableRule recorder