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.

Author: wz1000

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

@@ -35,16 +35,16 @@ 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
 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

ghcide/src/Development/IDE/Core/RuleTypes.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