Reimplement shake (continued) (#2060)

* Rewrite hls-graph to not use the Shake code

* redundant import

* Fix the bug

* add comments and format imports

* Fix another bug

* fix locking in incDatabase

* avoid calling withNumCapabilities on every build

* faster cleanup

* implement reverse deps

* --conservative-change-tracking

* Avoid grabbing the db lock when updating reverse deps

* update reverse deps asynchronously

* Profiling graph builds

* extend up profiling to record visiting steps

The main benefit of reverse dependency tracking is that we avoid unnecessary node lookups. However, these lookups were not shown in hls-graph profiles, hiding their real cost.

Concretely, if the number of lookups per build is proportional to the number of transitive dependencies of a node, which in turn is proportional to the number of transitive imports of a module, then we have an O(edges) complexity instead of an O(nodes) complexity, which is really bad for large projects.

This Diff extends the recorded data and the profiling UI to keep track
of visited nodes and to show them in a new column "Visited" of the "Rules" tab. The cost of doing this is storing an additional Int per node at runtime.

While I was editing the profiling UI, I took the chance to remove the command tabs, update the README and add some missing files

* include dirty set in profiles

* actionFork

* avoid spawning threads for simple lookups

* Fix a flaky test

* record changes to GetKnownTargets

* Readme for hls-graph

* Bump version numbers

* Drop dependency on Shake

* explain why we restart a Shake session

* clean up Internal.Database

* add a new benchmark example cabal-1module

* Fix masking and further reduce threading

* Trace aborted rule evaluations

* Fix code actions after cradle edit experiment

* Avoid spawning threads for build rules with 1 or fewer deps

* simplify a test

* hlint

* Add a test for off-editor changes

* Fix flaky tests

* fix incomplete pattern match in Tactics test suite

* Fix flaky tests

* attempt to fix tactics test suite in Windows

Co-authored-by: Neil Mitchell <[email protected]>

Author: pepeiborra

ghcide/bench/config.yaml

@@ -19,14 +19,35 @@ examples:
         - Distribution/Simple.hs
         - Distribution/Types/Module.hs
     extra-args: [] # extra ghcide command line args
+  - name: cabal-1module
+    package: Cabal
+    version: 3.0.0.0
+    modules:
+        - Distribution/Simple.hs
+  - name: cabal-conservative
+    package: Cabal
+    version: 3.0.0.0
+    modules:
+        - Distribution/Simple.hs
+        - Distribution/Types/Module.hs
+    extra-args:  # extra ghcide command line args
+      - --conservative-change-tracking
   # Small-sized project with TH
   - name: lsp-types
     package: lsp-types
     version: 1.0.0.1
     modules:
         - src/Language/LSP/VFS.hs
         - src/Language/LSP/Types/Lens.hs
-    extra-args: [] # extra ghcide command line args
+  - name: lsp-types-conservative
+    package: lsp-types
+    version: 1.0.0.1
+    modules:
+        - src/Language/LSP/VFS.hs
+        - src/Language/LSP/Types/Lens.hs
+    extra-args:
+      - --conservative-change-tracking
+  # Small-sized project with TH
   # Small but heavily multi-component example
   # Disabled as it is far to slow. hie-bios >0.7.2 should help
   # - name: HLS

ghcide/bench/lib/Experiments.hs

@@ -152,21 +152,22 @@ experiments =
       benchWithSetup
         "code actions after cradle edit"
         ( \docs -> do
-            unless (any (isJust . identifierP) docs) $
-                error "None of the example modules is suitable for this experiment"
-            forM_ docs $ \DocumentPositions{..} ->
-                forM_ identifierP $ \p -> changeDoc doc [charEdit p]
+            forM_ docs $ \DocumentPositions{..} -> do
+                forM identifierP $ \p -> do
+                    changeDoc doc [charEdit p]
+                    waitForProgressStart
+            void waitForBuildQueue
         )
         ( \docs -> do
             hieYamlUri <- getDocUri "hie.yaml"
             liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"
             sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
                 List [ FileEvent hieYamlUri FcChanged ]
-            forM_ docs $ \DocumentPositions{..} -> do
-              changeDoc doc [charEdit stringLiteralP]
-              waitForProgressStart
+            waitForProgressStart
+            waitForProgressStart
+            waitForProgressStart -- the Session logic restarts a second time
             waitForProgressDone
-            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
+            not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
               forM identifierP $ \p ->
                 getCodeActions doc (Range p p))
         ),
@@ -421,6 +422,17 @@ waitForProgressDone = loop
       done <- null <$> getIncompleteProgressSessions
       unless done loop
 
+-- | Wait for the build queue to be empty
+waitForBuildQueue :: Session Seconds
+waitForBuildQueue = do
+    let m = SCustomMethod "test"
+    waitId <- sendRequest m (toJSON WaitForShakeQueue)
+    (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId
+    case resp of
+        ResponseMessage{_result=Right Null} -> return td
+        -- assume a ghcide binary lacking the WaitForShakeQueue method
+        _                                   -> return 0
+
 runBench ::
   (?config :: Config) =>
   (Session BenchRun -> IO BenchRun) ->
@@ -451,15 +463,8 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
             else do
                 output (showDuration t)
                 -- Wait for the delayed actions to finish
-                let m = SCustomMethod "test"
-                waitId <- sendRequest m (toJSON WaitForShakeQueue)
-                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId
-                case resp of
-                    ResponseMessage{_result=Right Null} -> do
-                      loop (userWaits+t) (delayedWork+td) (n -1)
-                    _ ->
-                    -- Assume a ghcide build lacking the WaitForShakeQueue command
-                      loop (userWaits+t) delayedWork (n -1)
+                td <- waitForBuildQueue
+                loop (userWaits+t) (delayedWork+td) (n -1)
 
       (runExperiment, result) <- duration $ loop 0 0 samples
       let success = isJust result

ghcide/exe/Arguments.hs

@@ -9,15 +9,16 @@ import           Ide.Types            (IdePlugins)
 import           Options.Applicative
 
 data Arguments = Arguments
-    {argsCwd               :: Maybe FilePath
-    ,argsVersion           :: Bool
-    ,argsShakeProfiling    :: Maybe FilePath
-    ,argsOTMemoryProfiling :: Bool
-    ,argsTesting           :: Bool
-    ,argsDisableKick       :: Bool
-    ,argsThreads           :: Int
-    ,argsVerbose           :: Bool
-    ,argsCommand           :: Command
+    {argsCwd                        :: Maybe FilePath
+    ,argsVersion                    :: Bool
+    ,argsShakeProfiling             :: Maybe FilePath
+    ,argsOTMemoryProfiling          :: Bool
+    ,argsTesting                    :: Bool
+    ,argsDisableKick                :: Bool
+    ,argsThreads                    :: Int
+    ,argsVerbose                    :: Bool
+    ,argsCommand                    :: Command
+    ,argsConservativeChangeTracking :: Bool
     }
 
 getArguments :: IdePlugins IdeState -> IO Arguments
@@ -38,6 +39,7 @@ arguments plugins = Arguments
       <*> 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)
+      <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)")
       where
           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
           lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")

ghcide/exe/Main.hs

@@ -71,6 +71,8 @@ main = do
             then Test.plugin
             else mempty
 
+        ,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
+
         ,Main.argsIdeOptions = \config  sessionLoader ->
             let defOptions = defaultIdeOptions sessionLoader
             in defOptions
@@ -80,5 +82,6 @@ main = do
                 , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
                 , optCheckParents = pure $ checkParents config
                 , optCheckProject = pure $ checkProject config
+                , optRunSubset = not argsConservativeChangeTracking
                 }
         }

ghcide/ghcide.cabal

@@ -48,6 +48,7 @@ library
         dependent-map,
         dependent-sum,
         dlist,
+        exceptions,
         -- we can't use >= 1.7.10 while we have to use hlint == 3.2.*
         extra >= 1.7.4 && < 1.7.10,
         fuzzy,
@@ -76,7 +77,7 @@ library
         rope-utf16-splay,
         safe,
         safe-exceptions,
-        hls-graph ^>= 1.4,
+        hls-graph ^>= 1.5,
         sorted-list,
         sqlite-simple,
         stm,
@@ -269,6 +270,7 @@ benchmark benchHist
         directory,
         extra,
         filepath,
+        lens,
         optparse-applicative,
         shake,
         text,

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

@@ -250,7 +250,6 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 
     IdeOptions{ optTesting = IdeTesting optTesting
               , optCheckProject = getCheckProject
-              , optModifyDynFlags
               , optExtensions
               } <- getIdeOptions
 
@@ -264,6 +263,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
               TargetModule _ -> do
                 found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
                 return (targetTarget, found)
+          recordDirtyKeys extras GetKnownTargets  [emptyFilePath]
           modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do
             let known' = HM.unionWith (<>) known $ HM.fromList $ map (second Set.fromList) knownTargets
             when (known /= known') $
@@ -390,7 +390,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 
           -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
           invalidateShakeCache
-          restartShakeSession []
+          restartShakeSession "new component" []
 
           -- Typecheck all files in the project on startup
           checkProject <- getCheckProject

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

@@ -48,7 +48,6 @@ import           Development.IDE.Import.DependencyInformation
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
-import           Development.IDE.Types.Shake                  (SomeShakeValue)
 import           HieDb.Create                                 (deleteMissingRealFiles)
 import           Ide.Plugin.Config                            (CheckParents (..),
                                                                Config)
@@ -271,7 +270,7 @@ setFileModified state saved nfp = do
     when (isJust setVirtualFileContents) $
         fail "setFileModified can't be called on this type of VFSHandle"
     recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
-    restartShakeSession (shakeExtras state) []
+    restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") []
     when checkParents $
       typecheckParents state nfp
 
@@ -294,16 +293,16 @@ typecheckParentsAction 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 :: IdeState -> [SomeShakeValue] -> IO ()
-setSomethingModified state keys = do
+setSomethingModified :: IdeState -> [Key] -> String -> IO ()
+setSomethingModified state keys reason = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setSomethingModified can't be called on this type of VFSHandle"
     -- Update database to remove any files that might have been renamed/deleted
     atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles
     atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x ->
         foldl' (flip HSet.insert) x keys
-    void $ restartShakeSession (shakeExtras state) []
+    void $ restartShakeSession (shakeExtras state) reason []
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool
 registerFileWatches globs = do