Share ModuleGraphs for all files

bench/MultiLayerModules.sh

@@ -0,0 +1,34 @@
+#!/usr/bin/env bash
+# Generate $DEPTH layers of modules with $WIDTH modules on each layer
+# Every module on layer N imports all the modules on layer N-1
+# MultiLayerModules.hs imports all the modules from the last layer
+DEPTH=15
+WIDTH=40
+cat >hie.yaml << EOF
+cradle:
+  direct:
+    arguments:
+EOF
+for i in $(seq -w 1 $WIDTH); do
+  echo "module DummyLevel0M$i where" > DummyLevel0M$i.hs;
+  echo "          - DummyLevel0M$i.hs" >> hie.yaml;
+done
+for l in $(seq 1 $DEPTH); do
+  for i in $(seq -w 1 $WIDTH); do
+    echo "module DummyLevel${l}M$i where" > DummyLevel${l}M$i.hs;
+    echo "          - DummyLevel${l}M$i.hs" >> hie.yaml;
+    for j in $(seq -w 1 $WIDTH); do
+      echo "import DummyLevel$((l-1))M$j" >> DummyLevel${l}M$i.hs;
+    done
+  done
+done
+case "$1" in
+  '--th')
+    echo "{-# LANGUAGE TemplateHaskell #-}" > MultiLayerModules.hs
+    ;;
+esac
+echo "module MultiLayerModules where" >> MultiLayerModules.hs
+  echo "          - MultiLayerModules.hs" >> hie.yaml;
+for j in $(seq -w 1 $WIDTH); do
+  echo "import DummyLevel${DEPTH}M$j" >> MultiLayerModules.hs;
+done

bench/config.yaml

@@ -33,6 +33,50 @@ examples:
     modules:
         - src/Language/LSP/Types/WatchedFiles.hs
         - src/Language/LSP/Types/CallHierarchy.hs
+
+  - name: MultiLayerModules
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: ["--th"]
+    modules:
+        - MultiLayerModules.hs
+        - DummyLevel0M01.hs
+        - DummyLevel1M01.hs
+  - name: MultiLayerModulesNoTH
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: []
+    modules:
+        - MultiLayerModules.hs
+        - DummyLevel0M01.hs
+        - DummyLevel1M01.hs
+
+  - name: DummyLevel0M01
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: ["--th"]
+    modules:
+        - DummyLevel0M01.hs
+  - name: DummyLevel0M01NoTH
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: []
+    modules:
+        - DummyLevel0M01.hs
+
+  - name: DummyLevel1M01
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: ["--th"]
+    modules:
+        - DummyLevel1M01.hs
+  - name: DummyLevel1M01NoTH
+    path: bench/MultiLayerModules.sh
+    script: True
+    script-args: []
+    modules:
+        - DummyLevel1M01.hs
+
   # Small but heavily multi-component example
   # Disabled as it is far to slow. hie-bios >0.7.2 should help
   # - name: HLS
@@ -47,6 +91,7 @@ examples:
 
 # The set of experiments to execute
 experiments:
+    - "edit-header"
     - "edit"
     - "hover"
     - "hover after edit"

ghcide-bench/src/Experiments.hs

@@ -79,6 +79,12 @@ charEdit p =
                                         .+ #rangeLength .== Nothing
                                         .+ #text .== "a"
 
+headerEdit :: TextDocumentContentChangeEvent
+headerEdit =
+    TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 0)
+                                        .+ #rangeLength .== Nothing
+                                        .+ #text .== "-- header comment \n"
+
 data DocumentPositions = DocumentPositions {
     -- | A position that can be used to generate non null goto-def and completion responses
     identifierP    :: Maybe Position,
@@ -112,6 +118,16 @@ experiments =
         waitForProgressDone
         return True,
       ---------------------------------------------------------------------------------------
+      bench "edit-header" $ \docs -> do
+        forM_ docs $ \DocumentPositions{..} -> do
+          changeDoc doc [headerEdit]
+          -- wait for a fresh build start
+          waitForProgressStart
+        -- wait for the build to be finished
+        output "edit: waitForProgressDone"
+        waitForProgressDone
+        return True,
+      ---------------------------------------------------------------------------------------
       bench "hover after edit" $ \docs -> do
         forM_ docs $ \DocumentPositions{..} ->
           changeDoc doc [charEdit stringLiteralP]
@@ -276,23 +292,26 @@ configP =
     <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
     <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")
     <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")
-    <*> ( Example "name"
-               <$> (Right <$> packageP)
+    <*> ( Example
+               <$> exampleName
+               <*> (ExampleHackage <$> packageP)
                <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])
                <*> pure []
-         <|>
-          Example "name"
-                <$> (Left <$> pathP)
-                <*> some moduleOption
-                <*> pure [])
+      <|> Example
+               <$> exampleName
+               <*> pathOrScriptP
+               <*> some moduleOption
+               <*> pure [])
     <*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")
   where
       moduleOption = strOption (long "example-module" <> metavar "PATH")
+      exampleName = strOption (long "example-name" <> metavar "NAME")
 
       packageP = ExamplePackage
             <$> strOption (long "example-package-name" <> value "Cabal")
             <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))
-      pathP = strOption (long "example-path")
+      pathOrScriptP = ExamplePath   <$> strOption (long "example-path")
+                  <|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))
 
 versionP :: ReadM Version
 versionP = maybeReader $ extract . readP_to_S parseVersion
@@ -581,13 +600,25 @@ setup :: HasConfig => IO SetupResult
 setup = do
 --   when alreadyExists $ removeDirectoryRecursive examplesPath
   benchDir <- case exampleDetails(example ?config) of
-      Left examplePath -> do
+      ExamplePath examplePath -> do
           let hieYamlPath = examplePath </> "hie.yaml"
           alreadyExists <- doesFileExist hieYamlPath
           unless alreadyExists $
                 cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)
           return examplePath
-      Right ExamplePackage{..} -> do
+      ExampleScript examplePath' scriptArgs -> do
+          let exampleDir = examplesPath </> exampleName (example ?config)
+          alreadySetup <- doesDirectoryExist exampleDir
+          unless alreadySetup $ do
+            createDirectoryIfMissing True exampleDir
+            examplePath <- makeAbsolute examplePath'
+            cmd_ (Cwd exampleDir) examplePath scriptArgs
+            let hieYamlPath = exampleDir </> "hie.yaml"
+            alreadyExists <- doesFileExist hieYamlPath
+            unless alreadyExists $
+                  cmd_ (Cwd exampleDir) (FileStdout hieYamlPath) ("gen-hie"::String)
+          return exampleDir
+      ExampleHackage ExamplePackage{..} -> do
         let path = examplesPath </> package
             package = packageName <> "-" <> showVersion packageVersion
             hieYamlPath = path </> "hie.yaml"
@@ -633,8 +664,9 @@ setup = do
   whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
 
   let cleanUp = case exampleDetails(example ?config) of
-        Right _ -> removeDirectoryRecursive examplesPath
-        Left _  -> return ()
+        ExampleHackage _  -> removeDirectoryRecursive examplesPath
+        ExampleScript _ _ -> removeDirectoryRecursive examplesPath
+        ExamplePath _     -> return ()
 
       runBenchmarks = runBenchmarksFun benchDir
 

ghcide-bench/src/Experiments/Types.hs

@@ -40,12 +40,20 @@ data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion ::
 
 data Example = Example
     { exampleName      :: !String
-    , exampleDetails   :: Either FilePath ExamplePackage
+    , exampleDetails   :: ExampleDetails
     , exampleModules   :: [FilePath]
     , exampleExtraArgs :: [String]}
   deriving (Eq, Generic, Show)
   deriving anyclass (Binary, Hashable, NFData)
 
+data ExampleDetails
+  = ExamplePath FilePath -- ^ directory where the package is located
+  | ExampleHackage ExamplePackage -- ^ package from hackage
+  | ExampleScript FilePath -- ^ location of the script we are running
+                  [String] -- ^ extra arguments for the script
+  deriving (Eq, Generic, Show)
+  deriving anyclass (Binary, Hashable, NFData)
+
 instance FromJSON Example where
     parseJSON = withObject "example" $ \x -> do
         exampleName <- x .: "name"
@@ -55,24 +63,39 @@ instance FromJSON Example where
         path <- x .:? "path"
         case path of
             Just examplePath -> do
-                let exampleDetails = Left examplePath
+                script <- fromMaybe False <$> x.:? "script"
+                args <- fromMaybe [] <$> x .:? "script-args"
+                let exampleDetails
+                      | script = ExampleScript examplePath args
+                      | otherwise = ExamplePath examplePath
                 return Example{..}
             Nothing -> do
                 packageName <- x .: "package"
                 packageVersion <- x .: "version"
-                let exampleDetails = Right ExamplePackage{..}
+                let exampleDetails = ExampleHackage ExamplePackage{..}
                 return Example{..}
 
 exampleToOptions :: Example -> [String] -> [String]
-exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =
+exampleToOptions Example{exampleDetails = ExampleHackage ExamplePackage{..}, ..} extraArgs =
     ["--example-package-name", packageName
     ,"--example-package-version", showVersion packageVersion
+    ,"--example-name", exampleName
     ] ++
     ["--example-module=" <> m | m <- exampleModules
     ] ++
     ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
-exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =
+exampleToOptions Example{exampleDetails = ExamplePath examplePath, ..} extraArgs =
     ["--example-path", examplePath
+    ,"--example-name", exampleName
+    ] ++
+    ["--example-module=" <> m | m <- exampleModules
+    ] ++
+    ["--ghcide-options=" <> o | o <- exampleExtraArgs ++ extraArgs]
+exampleToOptions Example{exampleDetails = ExampleScript examplePath exampleArgs, ..} extraArgs =
+    ["--example-script", examplePath
+    ,"--example-name", exampleName
+    ] ++
+    ["--example-script-args=" <> o | o <- exampleArgs
     ] ++
     ["--example-module=" <> m | m <- exampleModules
     ] ++

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

@@ -137,6 +137,7 @@
 import qualified GHC                               as G
 import           GHC.Hs                            (LEpaComment)
 import qualified GHC.Types.Error                   as Error
+import Development.IDE.Import.DependencyInformation
 #endif
 
 #if MIN_VERSION_ghc(9,5,0)
@@ -177,7 +178,7 @@
 
 newtype TypecheckHelpers
   = TypecheckHelpers
   { getLinkables       :: ([NormalizedFilePath] -> IO [LinkableResult]) -- ^ hls-graph action to get linkables for files
   }
 
 typecheckModule :: IdeDefer
@@ -295,7 +296,7 @@
             -- by default, so we can safely ignore them here.
 
             -- Find the linkables for the modules we need
            ; let needed_mods = mkUniqSet [
 #if MIN_VERSION_ghc(9,3,0)
                                            mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids
 #else
@@ -593,8 +594,8 @@
       (prepd_binds', _)
 #endif
         <- corePrep unprep_binds' data_tycons
       let binds  = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds
           binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'
 
           -- diffBinds is unreliable, sometimes it goes down the wrong track.
           -- This fixes the order of the bindings so that it is less likely to do so.
@@ -610,7 +611,7 @@
           -- SYB is slow but fine given that this is only used for testing
           noUnfoldings = everywhere $ mkT $ \v -> if isId v
             then
               let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v
                 in setIdOccInfo v' noOccInfo
             else v
           isOtherUnfolding (OtherCon _) = True
@@ -1052,25 +1053,19 @@
 -- Add the current ModSummary to the graph, along with the
 -- HomeModInfo's of all direct dependencies (by induction hypothesis all
 -- transitive dependencies will be contained in envs)
+mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
+mergeEnvs env mg ms extraMods envs = do
 #if MIN_VERSION_ghc(9,3,0)
-mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
-mergeEnvs env (ms, deps) extraMods envs = do
     let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
         ifr = InstalledFound (ms_location ms) im
         curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr
-        -- Very important to force this as otherwise the hsc_mod_graph field is not
-        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
-        -- this new one, which in turn leads to the EPS referencing the HPT.
-        module_graph_nodes =
-          nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs)
-
     newFinderCache <- concatFC curFinderCache (map hsc_FC envs)
-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
+    return $! loadModulesHome extraMods $
       let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in
       (hscUpdateHUG (const newHug) env){
           hsc_FC = newFinderCache,
-          hsc_mod_graph = mkModuleGraph module_graph_nodes
-      })
+          hsc_mod_graph = mg
+      }
 
     where
         mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b
@@ -1096,30 +1091,16 @@
           pure $ FinderCache fcModules' fcFiles'
 
 #else
-mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
-mergeEnvs env ms extraMods envs = do
     prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
     let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))
         ifr = InstalledFound (ms_location ms) im
-        -- Very important to force this as otherwise the hsc_mod_graph field is not
-        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get
-        -- this new one, which in turn leads to the EPS referencing the HPT.
-        module_graph_nodes =
-#if MIN_VERSION_ghc(9,2,0)
-        -- We don't do any instantiation for backpack at this point of time, so it is OK to use
-        -- 'extendModSummaryNoDeps'.
-        -- This may have to change in the future.
-          map extendModSummaryNoDeps $
-#endif
-          nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs)
-
     newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr
-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $
+    return $! loadModulesHome extraMods $
       env{
           hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,
           hsc_FC = newFinderCache,
-          hsc_mod_graph = mkModuleGraph module_graph_nodes
-      })
+          hsc_mod_graph = mg
+      }
 
     where
         mergeUDFM = plusUDFM_C combineModules
@@ -1534,8 +1515,8 @@
              let runtime_deps
                    | not (mi_used_th iface) = emptyModuleEnv
                    | otherwise = parseRuntimeDeps (md_anns details)
-             -- Perform the fine grained recompilation check for TH
-             maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps
+             -- Peform the fine grained recompilation check for TH
+             maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps
              case maybe_recomp of
                Just msg -> do_regenerate msg
                Nothing
@@ -1572,13 +1553,21 @@
 -- the runtime dependencies of the module, to check if any of them are out of date
 -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH
 -- See Note [Recompilation avoidance in the presence of TH]
-checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
-checkLinkableDependencies get_linkable_hashes graph runtime_deps = do
-  let hs_files = mapM go (moduleEnvToList runtime_deps)
-      go (mod, hash) = do
-        ms <- mgLookupModule graph mod
-        let hs = fromJust $ ml_hs_file $ ms_location ms
-        pure (toNormalizedFilePath' hs, hash)
+checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)
+checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do
+#if MIN_VERSION_ghc(9,3,0)
+  moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)
+#else
+  moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)
+#endif
+  let go (mod, hash) = do
+        ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)
+        case ifr of
+          InstalledFound loc _ -> do
+            hs <- ml_hs_file loc
+            pure (toNormalizedFilePath' hs,hash)
+          _ -> Nothing
+      hs_files = mapM go (moduleEnvToList runtime_deps)
   case hs_files of
     Nothing -> error "invalid module graph"
     Just fs -> do
@@ -1701,7 +1690,7 @@
                                   Map.findWithDefault mempty name amap))
 #endif
     return $ map (first $ T.unpack . printOutputable)
            $ res
   where
     compiled n =
       -- TODO: Find a more direct indicator.