Move to creating a single HscEnv that we reuse in all GHC sessions rather than a fresh one each time (#1179)

src/Development/IDE/Functions/AtPoint.hs

@@ -41,7 +41,7 @@ import qualified Data.Text as T
 -- | Locate the definition of the name at a given position.
 gotoDefinition
   :: IdeOptions
-  -> PackageDynFlags
+  -> HscEnv
   -> [SpanInfo]
   -> Position
   -> Action (Maybe Location)
@@ -86,7 +86,7 @@ atPoint tcs srcSpans pos = do
         Just name -> any (`isInfixOf` show name) ["==", "showsPrec"]
         Nothing -> False
 
-locationsAtPoint :: IdeOptions -> PackageDynFlags -> Position -> [SpanInfo] -> Action [Location]
+locationsAtPoint :: IdeOptions -> HscEnv -> Position -> [SpanInfo] -> Action [Location]
 locationsAtPoint IdeOptions{..} pkgState pos =
     fmap (map srcSpanToLocation) .
     mapMaybeM (getSpan . spaninfoSource) .

src/Development/IDE/Functions/Compile.hs

@@ -95,12 +95,12 @@ data LoadPackageResult = LoadPackageResult
 getSrcSpanInfos
     :: IdeOptions
     -> ParsedModule
-    -> PackageDynFlags
+    -> HscEnv
     -> [(Located ModuleName, Maybe FilePath)]
     -> TcModuleResult
     -> IO [SpanInfo]
-getSrcSpanInfos opt mod packageState imports tc =
-    runGhcSession opt (Just mod) packageState
+getSrcSpanInfos opt mod env imports tc =
+    runGhcSession opt (Just mod) env
         . getSpanInfo imports
         $ tmrModule tc
 
@@ -108,7 +108,7 @@ getSrcSpanInfos opt mod packageState imports tc =
 -- | Given a string buffer, return a pre-processed @ParsedModule@.
 parseModule
     :: IdeOptions
-    -> PackageDynFlags
+    -> HscEnv
     -> FilePath
     -> (UTCTime, SB.StringBuffer)
     -> IO ([FileDiagnostic], Maybe ParsedModule)
@@ -118,7 +118,7 @@ parseModule opt@IdeOptions{..} packageState file =
     runGhcSessionExcept opt Nothing packageState . parseFileContents optPreprocessor file
 
 computePackageDeps ::
-     IdeOptions -> PackageDynFlags -> InstalledUnitId -> IO (Either [FileDiagnostic] [InstalledUnitId])
+     IdeOptions -> HscEnv -> InstalledUnitId -> IO (Either [FileDiagnostic] [InstalledUnitId])
 computePackageDeps opts packageState iuid =
   Ex.runExceptT $
   runGhcSessionExcept opts Nothing packageState $
@@ -138,7 +138,7 @@ getPackage dflags p =
 typecheckModule
     :: IdeOptions
     -> ParsedModule
-    -> PackageDynFlags
+    -> HscEnv
     -> UniqSupply
     -> [TcModuleResult]
     -> [LoadPackageResult]
@@ -157,7 +157,7 @@ typecheckModule opt mod packageState uniqSupply deps pkgs pm =
 -- | Load a pkg and populate the name cache and external package state.
 loadPackage ::
      IdeOptions
-  -> PackageDynFlags
+  -> HscEnv
   -> UniqSupply
   -> [LoadPackageResult]
   -> InstalledUnitId
@@ -185,7 +185,7 @@ loadPackage opt packageState us lps p =
 compileModule
     :: IdeOptions
     -> ParsedModule
-    -> PackageDynFlags
+    -> HscEnv
     -> UniqSupply
     -> [TcModuleResult]
     -> [LoadPackageResult]
@@ -222,14 +222,14 @@ compileModule opt mod packageState uniqSupply deps pkgs tmr =
 runGhcSessionExcept
     :: IdeOptions
     -> Maybe ParsedModule
-    -> PackageDynFlags
+    -> HscEnv
     -> Ex.ExceptT e Ghc a
     -> Ex.ExceptT e IO a
 runGhcSessionExcept opts mbMod pkg m =
     Ex.ExceptT $ runGhcSession opts mbMod pkg $ Ex.runExceptT m
 
 
-getGhcDynFlags :: IdeOptions -> ParsedModule -> PackageDynFlags -> IO DynFlags
+getGhcDynFlags :: IdeOptions -> ParsedModule -> HscEnv -> IO DynFlags
 getGhcDynFlags opts mod pkg = runGhcSession opts (Just mod) pkg getSessionDynFlags
 
 -- | Evaluate a GHC session using a new environment constructed with
@@ -237,10 +237,27 @@ getGhcDynFlags opts mod pkg = runGhcSession opts (Just mod) pkg getSessionDynFla
 runGhcSession
     :: IdeOptions
     -> Maybe ParsedModule
-    -> PackageDynFlags
+    -> HscEnv
     -> Ghc a
     -> IO a
-runGhcSession IdeOptions{..} = optRunGhcSession
+runGhcSession IdeOptions{..} modu env act = runGhcEnv env $ do
+    modifyDynFlags $ \x -> x{importPaths = maybe [] moduleImportPaths modu ++ importPaths x}
+    act
+
+
+moduleImportPaths :: GHC.ParsedModule -> [FilePath]
+moduleImportPaths pm =
+    maybe [] (\modRoot -> [modRoot]) mbModuleRoot
+  where
+    ms   = GHC.pm_mod_summary pm
+    file = GHC.ms_hspp_file ms
+    mod'  = GHC.ms_mod ms
+    rootPathDir  = takeDirectory file
+    rootModDir   = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'
+    mbModuleRoot
+        | rootModDir == "." = Just rootPathDir
+        | otherwise = dropTrailingPathSeparator <$> stripSuffix rootModDir rootPathDir
+
 
 -- When we make a fresh GHC environment, the OrigNameCache comes already partially
 -- populated. So to be safe, we simply extend this one.

src/Development/IDE/State/RuleTypes.hs

@@ -15,7 +15,6 @@ module Development.IDE.State.RuleTypes(
 import           Control.DeepSeq
 import           Development.IDE.Functions.Compile             (TcModuleResult, GhcModule, LoadPackageResult(..))
 import qualified Development.IDE.Functions.Compile             as Compile
-import qualified Development.IDE.UtilGHC as Compile
 import           Development.IDE.Functions.FindImports         (Import(..))
 import           Development.IDE.Functions.DependencyInformation
 import           Data.Hashable
@@ -61,9 +60,8 @@ type instance RuleResult GetSpanInfo = [SpanInfo]
 -- | Convert to Core, requires TypeCheck*
 type instance RuleResult GenerateCore = GhcModule
 
--- | We capture the subset of `DynFlags` that is computed by package initialization in a rule to
--- make session initialization cheaper by reusing it.
-type instance RuleResult LoadPackageState = Compile.PackageDynFlags
+-- | A GHC session that we reuse.
+type instance RuleResult GhcSession = HscEnv
 
 -- | Resolve the imports in a module to the list of either external packages or absolute file paths
 -- for modules in the same package.
@@ -128,10 +126,10 @@ data GenerateCore = GenerateCore
 instance Hashable GenerateCore
 instance NFData   GenerateCore
 
-data LoadPackageState = LoadPackageState
+data GhcSession = GhcSession
     deriving (Eq, Show, Typeable, Generic)
-instance Hashable LoadPackageState
-instance NFData   LoadPackageState
+instance Hashable GhcSession
+instance NFData   GhcSession
 
 -- Note that we embed the filepath here instead of using the filepath associated with Shake keys.
 -- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.
@@ -161,6 +159,12 @@ instance Show ParsedModule where
 instance NFData ModSummary where
     rnf = rwhnf
 
+instance Show HscEnv where
+    show _ = "HscEnv"
+
+instance NFData HscEnv where
+    rnf = rwhnf
+
 instance NFData ParsedModule where
     rnf = rwhnf
 

src/Development/IDE/State/Rules.hs

@@ -35,6 +35,7 @@ import           Development.IDE.State.FileStore
 import           Development.IDE.Types.Diagnostics as Base
 import Data.Bifunctor
 import Data.Either.Extra
+import Development.IDE.UtilGHC
 import Data.Maybe
 import           Data.Foldable
 import qualified Data.Map.Strict                          as Map
@@ -46,6 +47,7 @@ import           Development.IDE.Types.LSP as Compiler
 import Development.IDE.State.RuleTypes
 
 import           GHC
+import HscTypes
 import Development.IDE.Compat
 import           UniqSupply
 import           Module                         as M
@@ -153,7 +155,7 @@ getAtPointForFile file pos = do
 getDefinitionForFile :: FilePath -> Position -> ExceptT [FileDiagnostic] Action (Maybe Location)
 getDefinitionForFile file pos = do
     spans <- useE GetSpanInfo file
-    pkgState <- useE LoadPackageState ""
+    pkgState <- useE GhcSession ""
     opts <- lift getOpts
     lift $ AtPoint.gotoDefinition opts pkgState spans pos
 
@@ -177,7 +179,7 @@ getParsedModuleRule :: Rules ()
 getParsedModuleRule =
     define $ \GetParsedModule file -> do
         contents <- getFileContents file
-        packageState <- use_ LoadPackageState ""
+        packageState <- use_ GhcSession ""
         opt <- getOpts
         liftIO $ Compile.parseModule opt packageState file contents
 
@@ -187,7 +189,7 @@ getLocatedImportsRule =
         pm <- use_ GetParsedModule file
         let ms = pm_mod_summary pm
         let imports = ms_textual_imps ms
-        packageState <- use_ LoadPackageState ""
+        packageState <- use_ GhcSession ""
         opt <- getOpts
         dflags <- liftIO $ Compile.getGhcDynFlags opt pm packageState
         xs <- forM imports $ \(mbPkgName, modName) ->
@@ -209,7 +211,7 @@ rawDependencyInformation f = go (Set.singleton f) Map.empty Map.empty
                   let modGraph' = Map.insert f (Left ModuleParseError) modGraph
                   in go fs modGraph' pkgs
                 Just imports -> do
-                  packageState <- lift $ use_ LoadPackageState ""
+                  packageState <- lift $ use_ GhcSession ""
                   opt <- lift getOpts
                   modOrPkgImports <- forM imports $ \imp -> do
                     case imp of
@@ -277,7 +279,7 @@ getSpanInfoRule =
         pm <- use_ GetParsedModule file
         tc <- use_ TypeCheck file
         imports <- use_ GetLocatedImports file
-        packageState <- use_ LoadPackageState ""
+        packageState <- use_ GhcSession ""
         opt <- getOpts
         x <- liftIO $ Compile.getSrcSpanInfos opt pm packageState (fileImports imports) tc
         return ([], Just x)
@@ -292,7 +294,7 @@ typeCheckRule =
         tms <- uses_ TypeCheck (transitiveModuleDeps deps)
         setPriority PriorityTypeCheck
         us <- getUniqSupply
-        packageState <- use_ LoadPackageState ""
+        packageState <- use_ GhcSession ""
         opt <- getOpts
         liftIO $ Compile.typecheckModule opt pm packageState us tms lps pm
 
@@ -300,7 +302,7 @@ typeCheckRule =
 loadPackageRule :: Rules ()
 loadPackageRule =
   defineNoFile $ \(LoadPackage pkg) -> do
-      packageState <- use_ LoadPackageState ""
+      packageState <- use_ GhcSession ""
       opt <- getOpts
       pkgs <- liftIO $ Compile.computePackageDeps opt packageState pkg
       case pkgs of
@@ -324,16 +326,19 @@ generateCoreRule =
         let pm = tm_parsed_module . Compile.tmrModule $ tm
         setPriority PriorityGenerateDalf
         us <- getUniqSupply
-        packageState <- use_ LoadPackageState ""
+        packageState <- use_ GhcSession ""
         opt <- getOpts
         liftIO $ Compile.compileModule opt pm packageState us tms lps tm
 
-loadPackageStateRule :: Rules ()
-loadPackageStateRule =
-    defineNoFile $ \LoadPackageState -> do
+loadGhcSession :: Rules ()
+loadGhcSession =
+    defineNoFile $ \GhcSession -> do
         opts <- envOptions <$> getServiceEnv
-        liftIO $ Compile.generatePackageState
+        env <- Compile.optGhcSession opts
+        pkg <- liftIO $ Compile.generatePackageState
             (Compile.optPackageDbs opts) (Compile.optHideAllPkgs opts) (Compile.optPackageImports opts)
+        return env{hsc_dflags = setPackageDynFlags pkg $ hsc_dflags env}
+
 
 getHieFileRule :: Rules ()
 getHieFileRule =
@@ -353,7 +358,7 @@ mainRule = do
     typeCheckRule
     getSpanInfoRule
     generateCoreRule
-    loadPackageStateRule
+    loadGhcSession
     loadPackageRule
     getHieFileRule
 

src/Development/IDE/Types/Options.hs

@@ -9,14 +9,14 @@ module Development.IDE.Types.Options
   , IdePkgLocationOptions(..)
   ) where
 
-import Development.IDE.UtilGHC
+import Development.Shake
 import           GHC hiding (parseModule, typecheckModule)
 import           GhcPlugins                     as GHC hiding (fst3, (<>))
 
 
 data IdeOptions = IdeOptions
   { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)
-  , optRunGhcSession :: forall a. Maybe ParsedModule -> PackageDynFlags -> Ghc a -> IO a
+  , optGhcSession :: Action HscEnv
   -- ^ Setup a GHC session using a given package state. If a `ParsedModule` is supplied,
   -- the import path should be setup for that module.
   , optPkgLocationOpts :: IdePkgLocationOptions

src/Development/IDE/UtilGHC.hs

@@ -17,7 +17,8 @@ module Development.IDE.UtilGHC(
     setPackageDbs,
     fakeDynFlags,
     prettyPrint,
-    runGhcFast
+    runGhcFast,
+    runGhcEnv
     ) where
 
 import           Config
@@ -89,20 +90,26 @@ getPackageDynFlags DynFlags{..} = PackageDynFlags
     , pdfThisUnitIdInsts = thisUnitIdInsts_
     }
 
-lookupPackageConfig :: UnitId -> PackageDynFlags -> Maybe PackageConfig
-lookupPackageConfig unitId PackageDynFlags {..} =
+lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
+lookupPackageConfig unitId env =
     lookupPackage' False pkgConfigMap unitId
     where
         pkgConfigMap =
             -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap
             -- from PackageState so we have to wrap it in DynFlags first.
-            getPackageConfigMap fakeDynFlags { pkgState = pdfPkgState }
+            getPackageConfigMap $ hsc_dflags env
 
 
 
 prettyPrint :: Outputable a => a -> String
 prettyPrint = showSDoc fakeDynFlags . ppr
 
+runGhcEnv :: HscEnv -> Ghc a -> IO a
+runGhcEnv env act = do
+    ref <- newIORef env
+    unGhc act $ Session ref
+
+
 -- | Like 'runGhc' but much faster (400x), with less IO and no file dependency
 runGhcFast :: Ghc a -> IO a
 -- copied from GHC with the nasty bits dropped