Use closed world assumption for core and .hie files

Author: wz1000

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

@@ -66,6 +66,7 @@ import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime, utcTi
 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
@@ -396,7 +397,7 @@ mkHiFileResultCompile se session' tcm simplified_guts ltype = catchErrs $ do
 
   let genLinkable = case ltype of
         ObjectLinkable -> generateObjectCode
-        BCOLinkable    -> generateByteCode WriteCoreFile
+        BCOLinkable    -> generateByteCode se WriteCoreFile
 
   (linkable, details, mguts, diags) <-
     if mg_hsc_src simplified_guts == HsBootFile
@@ -545,8 +546,8 @@ generateObjectCode session summary guts = do
 
 data WriteCoreFile = WriteCoreFile | CoreFileExists !UTCTime
 
-generateByteCode :: WriteCoreFile -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
-generateByteCode write_core hscEnv summary guts = do
+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)) <-
@@ -566,7 +567,7 @@ generateByteCode write_core hscEnv summary guts = do
                 WriteCoreFile -> liftIO $ do
                   let core_fp = ml_core_file $ ms_location summary
                       core_file = codeGutsToCoreFile guts
-                  atomicFileWrite core_fp $ \fp ->
+                  atomicFileWrite se core_fp $ \fp ->
                     writeBinCoreFile fp core_file
                   getModificationTime core_fp
               let linkable = LM time (ms_mod summary) [unlinked]
@@ -651,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 =
@@ -834,18 +837,18 @@ 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
     dflags       = hsc_dflags hscEnv
     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
@@ -1210,12 +1213,13 @@ ml_core_file ml = ml_hi_file ml <.> "core"
 -- 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
@@ -1309,7 +1313,7 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do
              -> do_regenerate msg
              | otherwise -> return ([], Just old_hir)
            Nothing -> do
-             (warns, hmi) <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags ms 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
@@ -1361,8 +1365,8 @@ showReason UpToDate          = "UpToDate"
 showReason MustCompile       = "MustCompile"
 showReason (RecompBecause s) = s
 
-mkDetailsFromIface :: HscEnv -> ModSummary -> ModIface -> Maybe IdeLinkable -> IO ([FileDiagnostic], HomeModInfo)
-mkDetailsFromIface session ms iface ide_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 Nothing) }
     initIfaceLoad hsc' (typecheckIface iface)
@@ -1371,7 +1375,7 @@ mkDetailsFromIface session ms iface ide_linkable = do
     Just (GhcLinkable lb) -> pure ([], Just lb)
     Just (CoreLinkable t core_file) -> do
       cgi_guts <- coreFileToCgGuts session iface details core_file
-      generateByteCode (CoreFileExists t) session ms cgi_guts
+      generateByteCode se (CoreFileExists t) session ms cgi_guts
 
   return (warns, HomeModInfo iface details linkable)
 

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

@@ -151,7 +151,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/Rules.hs

@@ -767,7 +767,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
     Just session -> do
       linkableType <- getLinkableType f
       ver <- use_ GetModificationTime f
-      ShakeExtras{ideNc} <- getShakeExtras
+      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 +778,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
@@ -901,7 +901,7 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
       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
@@ -947,6 +947,7 @@ regenerateHiFile sess f ms compNeeded = do
                 let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
 
                 se <- getShakeExtras
+
                 -- Bang pattern is important to avoid leaking 'tmr'
                 (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded se hsc compNeeded compile tmr
 
@@ -966,7 +967,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)
@@ -1087,14 +1088,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