Process shake restarts asynchronously

ghcide-test/exe/Main.hs

@@ -63,6 +63,7 @@ import           ReferenceTests
 import           ResolveTests
 import           RootUriTests
 import           SafeTests
+import           ShakeRestartTests
 import           SymlinkTests
 import           THTests
 import           UnitTests
@@ -105,4 +106,5 @@ main = do
     , GarbageCollectionTests.tests
     , HieDbRetry.tests
     , ExceptionTests.tests
+    , ShakeRestartTests.tests
     ]

ghcide-test/exe/ShakeRestartTests.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module ShakeRestartTests (tests) where
+
+import qualified Data.Map.Lazy               as Map
+import           Development.IDE.Core.Shake
+import           Language.LSP.Protocol.Types (Uri (..), toNormalizedUri)
+import           Language.LSP.VFS
+import           Test.Tasty
+import           Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "shake restart merging"
+    [ testCase "succeedVFS" $ do
+        let vfs1 = VFSModified (VFS mempty)
+        succeedVFS VFSUnmodified VFSUnmodified @?= VFSUnmodified
+        succeedVFS VFSUnmodified vfs1 @?= vfs1
+        succeedVFS vfs1 VFSUnmodified @?= vfs1
+
+    , testCase "<> appends reasons in reverse chronological order" $ do
+        let p1 = PendingRestart VFSUnmodified mempty ["r1"] [] []
+            p2 = PendingRestart VFSUnmodified mempty ["r2"] [] []
+        reverse (pendingRestartReasons (succeedPendingRestart p1 p2)) @?= ["r1", "r2"]
+
+    , testCase "<> takes VFS from the right operand" $ do
+        let olderUri  = toNormalizedUri (Uri "older")
+            newerUri  = toNormalizedUri (Uri "newer")
+            unforced  = error "VFS payload should not be forced by Map.keys"
+            olderVfs  = VFSModified (VFS (Map.singleton olderUri unforced))
+            newerVfs  = VFSModified (VFS (Map.singleton newerUri unforced))
+            older     = PendingRestart olderVfs mempty ["older"] [] []
+            newer     = PendingRestart newerVfs mempty ["newer"] [] []
+        case pendingRestartVFS (succeedPendingRestart older newer) of
+            VFSModified (VFS m) -> Map.keys m @?= [newerUri]
+            VFSUnmodified       -> assertFailure "expected VFSModified"
+    ]
+
+instance Eq VFSModified where
+    VFSUnmodified == VFSUnmodified             = True
+    VFSModified (VFS _) == VFSModified (VFS _) = True
+    _ == _                                     = False
+
+instance Eq PendingRestart where
+    p1 == p2 = pendingRestartVFS p1 == pendingRestartVFS p2 &&
+               pendingRestartReasons p1 == pendingRestartReasons p2

ghcide/session-loader/Development/IDE/Session.hs

@@ -90,6 +90,7 @@ import           Data.HashMap.Strict                 (HashMap)
 import           Data.HashSet                        (HashSet)
 import qualified Data.HashSet                        as Set
 import           Database.SQLite.Simple
+import qualified Development.IDE.Core.Shake          as Shake
 import           Development.IDE.Core.Tracing        (withTrace)
 import           Development.IDE.Core.WorkerThread
 import           Development.IDE.Session.Dependency
@@ -136,6 +137,7 @@ data Log
   | LogLookupSessionCache !FilePath
   | LogTime !String
   | LogSessionGhc Ghc.Log
+  | LogShake Shake.Log
 deriving instance Show Log
 
 instance Pretty Log where
@@ -209,6 +211,7 @@ instance Pretty Log where
     LogSessionGhc msg -> pretty msg
     LogSessionLoadingChanged ->
       "Session Loading config changed, reloading the full session."
+    LogShake msg -> pretty msg
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -633,11 +636,12 @@ newSessionState = do
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 
-loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession)
+loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> WorkerTasks STM (IO ()) -> IO (Action IdeGhcSession)
 loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
   let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]
 
   sessionState <- newSessionState
+  sharedInterp <- newVar Nothing
   let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState))
 
   -- This caches the mapping from Mod.hs -> hie.yaml
@@ -663,7 +667,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
     -- see Note [Serializing runs in separate thread]
     -- Start the 'getOptionsLoop' if the queue is empty
     liftIO $ atomically $
-      Extra.whenM (isEmptyTaskQueue que) $ do
+      Extra.whenM (nullWorkerTasks que) $ do
         let newSessionLoadingOptions = SessionLoadingOptions
               { findCradle = cradleLoc
               , ..
@@ -681,9 +685,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
               , sessionClientConfig = clientConfig
               , sessionSharedNameCache = ideNc
               , sessionLoadingOptions = newSessionLoadingOptions
+              , sessionSharedInterp = sharedInterp
               }
 
-        writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv)
+        addWorkerTask que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv)
 
     -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action
     -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes.
@@ -729,7 +734,7 @@ checkInCache sessionState ncfp = runMaybeT $ do
 
 -- | Modify the shake state.
 data SessionShake = SessionShake
-  { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO ()
+  { restartSession :: VFSModified -> T.Text -> [DelayedAction ()] -> IO [Key] -> IO ()
   , invalidateCache :: IO Key
   , enqueueActions :: DelayedAction () -> IO (IO ())
   }
@@ -743,6 +748,8 @@ data SessionEnv = SessionEnv
   , sessionClientConfig    :: Config
   , sessionSharedNameCache :: NameCache
   , sessionLoadingOptions  :: SessionLoadingOptions
+  , sessionSharedInterp    :: Var (Maybe Interp)
+    -- ^ Shared interpreter for all sessions. See Note [TH interpreter loader reuse].
   }
 
 type SessionM = ReaderT SessionEnv IO
@@ -1071,7 +1078,12 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do
 emptyHscEnvM :: FilePath -> SessionM HscEnv
 emptyHscEnvM libDir = do
   nc <- asks sessionSharedNameCache
-  liftIO $ Ghc.emptyHscEnv nc libDir
+  sharedInterpVar <- asks sessionSharedInterp
+  env <- liftIO $ Ghc.emptyHscEnv nc libDir
+  liftIO $ modifyVar sharedInterpVar $ \cached ->
+    case (cached, hscInterpMaybe env) of
+      (Nothing, mFresh) -> pure (mFresh, env)
+      (mCached, _)      -> pure (mCached, withHscInterp mCached env)
 
 toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
 toFlagsMap TargetDetails{..} =

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

@@ -75,7 +75,7 @@ import           Development.IDE.Core.Preprocessor
 import           Development.IDE.Core.ProgressReporting       (progressUpdate)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
-import           Development.IDE.Core.WorkerThread            (writeTaskQueue)
+import           Development.IDE.Core.WorkerThread            (WorkerTasks (..))
 import           Development.IDE.Core.Tracing                 (withTrace)
 import qualified Development.IDE.GHC.Compat                   as Compat
 import qualified Development.IDE.GHC.Compat                   as GHC
@@ -342,7 +342,6 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do
 #else
            ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env
 #endif
-
              {- load it -}
 #if MIN_VERSION_ghc(9,11,0)
            ; bco_time <- getCurrentTime
@@ -942,7 +941,7 @@ indexHieFile se mod_summary srcPath !hash hf = do
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
       modifyTVar' indexPending $ HashMap.insert srcPath hash
-      writeTaskQueue indexQueue $ \withHieDb -> do
+      addWorkerTask indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
         -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do
@@ -1489,6 +1488,21 @@ This is better than using the object file hash (if we have one) because object
 file generation is not deterministic.
 -}
 
+{- Note [TH interpreter loader reuse]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'loadDecls' (called per TH splice) consults the interpreter's
+'bcos_loaded :: ModuleEnv Linkable': a module with a matching timestamp is
+reused, otherwise it is loaded fresh from the HUG. 'loadModulesHome' only
+updates the HUG, so stale 'bcos_loaded' entries must be evicted via 'unload'.
+
+'getLinkableRule' calls 'unload' on every new linkable. For this to reach
+'loadDecls', all sessions must share the same 'Interp' IORef. 'emptyHscEnvM'
+ensures this by caching the first 'Interp' and overwrites 'hsc_interp' on every
+subsequent call.
+
+See also: Note [Recompilation avoidance in the presence of TH]
+-}
+
 data RecompilationInfo m
   = RecompilationInfo
   { source_version :: FileVersion

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

@@ -279,7 +279,7 @@ setFileModified recorder vfs state saved nfp actionBefore = do
           AlwaysCheck -> True
           CheckOnSave -> saved
           _           -> False
-    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do
+    restartShakeSession (shakeExtras state) vfs (T.pack (fromNormalizedFilePath nfp ++ " (modified)")) [] $ do
         keys<-actionBefore
         return (toKey GetModificationTime nfp:keys)
     when checkParents $
@@ -301,10 +301,11 @@ typecheckParentsAction recorder nfp = do
 -- | Note that some keys have been modified and restart the session
 --   Only valid if the virtual file system was initialised by LSP, as that
 --   independently tracks which files are modified.
-setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
+setSomethingModified :: VFSModified -> IdeState -> T.Text -> IO [Key] -> IO ()
 setSomethingModified vfs state reason actionBetweenSession = do
     -- Update database to remove any files that might have been renamed/deleted
-    atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
+    let indexQueue' = indexQueue $ hiedbWriter $ shakeExtras state
+    atomically $ addWorkerTask indexQueue' (\withHieDb -> withHieDb deleteMissingRealFiles)
     void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool

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

@@ -140,6 +140,13 @@ import qualified Development.IDE.Types.Shake                  as Shake
 import           GHC.Iface.Ext.Types                          (HieASTs (..))
 import           GHC.Iface.Ext.Utils                          (generateReferencesMap)
 import qualified GHC.LanguageExtensions                       as LangExt
+#if MIN_VERSION_ghc(9,11,0)
+import           GHC.ByteCode.Types                           (CompiledByteCode (..))
+import           GHC.Data.FlatBag                             (emptyFlatBag)
+#endif
+#if MIN_VERSION_ghc(9,11,0) && !MIN_VERSION_ghc(9,13,0)
+import           GHC.Types.Name.Env                           (emptyNameEnv)
+#endif
 #if MIN_VERSION_ghc(9,13,0)
 import           GHC.Types.PkgQual                            (PkgQual (NoPkgQual))
 import           GHC.Types.Basic                              (ImportLevel (..))
@@ -1115,6 +1122,33 @@ usePropertyByPathAction path plId p = do
 
 -- ---------------------------------------------------------------------
 
+-- | Argument order matches 'moduleEnvToList'. See Note [TH interpreter loader reuse].
+fakeKeepLinkable :: Module -> UTCTime -> Linkable
+#if MIN_VERSION_ghc(9,13,0)
+fakeKeepLinkable m t = Linkable t m (pure (BCOs emptyCompiledByteCode))
+  where
+    emptyCompiledByteCode = CompiledByteCode
+      { bc_bcos = emptyFlatBag
+      , bc_itbls = []
+      , bc_strs = []
+      , bc_breaks = Nothing
+      , bc_spt_entries = []
+      }
+#elif MIN_VERSION_ghc(9,11,0)
+fakeKeepLinkable m t = Linkable t m (pure (BCOs emptyCompiledByteCode))
+  where
+    emptyCompiledByteCode = CompiledByteCode
+      { bc_bcos = emptyFlatBag
+      , bc_itbls = emptyNameEnv
+      , bc_ffis = []
+      , bc_strs = emptyNameEnv
+      , bc_breaks = Nothing
+      , bc_spt_entries = []
+      }
+#else
+fakeKeepLinkable m t = LM t m [LoadedBCOs []]
+#endif
+
 getLinkableRule :: Recorder (WithPriority Log) -> Rules ()
 getLinkableRule recorder =
   defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do
@@ -1175,9 +1209,8 @@ getLinkableRule recorder =
               --just before returning it to be loaded. This has a substantial effect on recompile
               --times as the number of loaded modules and splices increases.
               --
-              --We use a dummy DotA linkable part to fake a NativeCode linkable.
-              --The unload function doesn't care about the exact linkable parts.
-              unload (hscEnv session) (map (\(mod', time') -> mkLinkable time' mod' (DotA "dummy")) $ moduleEnvToList to_keep)
+              -- See Note [TH interpreter loader reuse]
+              unload (hscEnv session) (map (uncurry fakeKeepLinkable) $ moduleEnvToList to_keep)
               return (to_keep, ())
         return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash))