Fix space leak on cradle reloads

ghcide/bench/config.yaml

@@ -29,11 +29,14 @@ experiments:
     - "edit"
     - "hover"
     - "hover after edit"
+    # - "hover after cradle edit"
     - "getDefinition"
     - "getDefinition after edit"
+    - "completions"
     - "completions after edit"
     - "code actions"
     - "code actions after edit"
+    - "code actions after cradle edit"
     - "documentSymbols after edit"
 
 # An ordered list of versions to analyze

ghcide/bench/lib/Experiments.hs

@@ -62,52 +62,51 @@ allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs)
 experiments :: [Bench]
 experiments =
     [ ---------------------------------------------------------------------------------------
-      bench "hover" 10 $ allWithIdentifierPos $ \DocumentPositions{..} ->
+      bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->
         isJust <$> getHover doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
-      bench "edit" 10 $ \docs -> do
+      bench "edit" $ \docs -> do
         forM_ docs $ \DocumentPositions{..} ->
           changeDoc doc [charEdit stringLiteralP]
         waitForProgressDone -- TODO check that this waits for all of them
         return True,
       ---------------------------------------------------------------------------------------
-      bench "hover after edit" 10 $ \docs -> do
+      bench "hover after edit" $ \docs -> do
         forM_ docs $ \DocumentPositions{..} ->
           changeDoc doc [charEdit stringLiteralP]
         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
           isJust <$> getHover doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
-      bench "getDefinition" 10 $ allWithIdentifierPos $ \DocumentPositions{..} ->
+      bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->
         not . null <$> getDefinitions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
-      bench "getDefinition after edit" 10 $ \docs -> do
+      bench "getDefinition after edit" $ \docs -> do
           forM_ docs $ \DocumentPositions{..} ->
             changeDoc doc [charEdit stringLiteralP]
           flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
             not . null <$> getDefinitions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
-      bench "documentSymbols" 100 $ allM $ \DocumentPositions{..} -> do
+      bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do
         fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,
       ---------------------------------------------------------------------------------------
-      bench "documentSymbols after edit" 100 $ \docs -> do
+      bench "documentSymbols after edit" $ \docs -> do
         forM_ docs $ \DocumentPositions{..} ->
           changeDoc doc [charEdit stringLiteralP]
         flip allM docs $ \DocumentPositions{..} ->
           either (not . null) (not . null) <$> getDocumentSymbols doc,
       ---------------------------------------------------------------------------------------
-      bench "completions" 10 $ \docs -> do
+      bench "completions" $ \docs -> do
         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
           not . null <$> getCompletions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
-      bench "completions after edit" 10 $ \docs -> do
+      bench "completions after edit" $ \docs -> do
         forM_ docs $ \DocumentPositions{..} ->
           changeDoc doc [charEdit stringLiteralP]
         flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
           not . null <$> getCompletions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
       benchWithSetup
         "code actions"
-        10
         ( \docs -> do
             unless (any (isJust . identifierP) docs) $
                 error "None of the example modules is suitable for this experiment"
@@ -122,7 +121,6 @@ experiments =
       ---------------------------------------------------------------------------------------
       benchWithSetup
         "code actions after edit"
-        10
         ( \docs -> do
             unless (any (isJust . identifierP) docs) $
                 error "None of the example modules is suitable for this experiment"
@@ -136,6 +134,37 @@ experiments =
             not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
               forM identifierP $ \p ->
                 getCodeActions doc (Range p p))
+        ),
+      ---------------------------------------------------------------------------------------
+      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]
+        )
+        ( \docs -> do
+            Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml"
+            liftIO $ appendFile hieYaml "##\n"
+            sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
+                List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]
+            forM_ docs $ \DocumentPositions{..} ->
+              changeDoc doc [charEdit stringLiteralP]
+            waitForProgressDone
+            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
+              forM identifierP $ \p ->
+                getCodeActions doc (Range p p))
+        ),
+      ---------------------------------------------------------------------------------------
+      bench
+        "hover after cradle edit"
+        (\docs -> do
+            Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml"
+            liftIO $ appendFile hieYaml "##\n"
+            sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
+                List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]
+            flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)
         )
     ]
 
@@ -208,21 +237,20 @@ select Bench {name, enabled} =
 
 benchWithSetup ::
   String ->
-  Natural ->
   ([DocumentPositions] -> Session ()) ->
   Experiment ->
   Bench
-benchWithSetup name samples benchSetup experiment = Bench {..}
+benchWithSetup name benchSetup experiment = Bench {..}
   where
     enabled = True
+    samples = 100
 
-bench :: String -> Natural -> Experiment -> Bench
-bench name defSamples =
-  benchWithSetup name defSamples (const $ pure ())
+bench :: String -> Experiment -> Bench
+bench name = benchWithSetup name (const $ pure ())
 
 runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()
 runBenchmarksFun dir allBenchmarks = do
-  let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) }
+  let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) }
                    | b <- allBenchmarks
                    , select b ]
 

ghcide/ghcide.cabal

@@ -166,6 +166,7 @@ library
         Development.IDE.Spans.LocalBindings
         Development.IDE.Types.Diagnostics
         Development.IDE.Types.Exports
+        Development.IDE.Types.HscEnvEq
         Development.IDE.Types.KnownTargets
         Development.IDE.Types.Location
         Development.IDE.Types.Logger
@@ -202,8 +203,6 @@ library
         Development.IDE.Import.FindImports
         Development.IDE.LSP.Notifications
         Development.IDE.Plugin.CodeAction.PositionIndexed
-        Development.IDE.Plugin.CodeAction.Rules
-        Development.IDE.Plugin.CodeAction.RuleTypes
         Development.IDE.Plugin.Completions.Logic
         Development.IDE.Plugin.HLS.Formatter
         Development.IDE.Types.Action

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

@@ -49,6 +49,7 @@ import Development.IDE.GHC.Util
 import Development.IDE.Session.VersionCheck
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Exports
+import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEqPreserveImportPaths, newHscEnvEq)
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Types.Options

ghcide/src/Development/IDE.hs

@@ -40,6 +40,7 @@ import Development.IDE.GHC.Error as X
 import Development.IDE.GHC.Util as X
 import Development.IDE.Plugin as X
 import Development.IDE.Types.Diagnostics as X
+import Development.IDE.Types.HscEnvEq as X (HscEnvEq(..), hscEnv, hscEnvWithImportPaths)
 import Development.IDE.Types.Location as X
 import Development.IDE.Types.Logger as X
 import Development.Shake as X (Action, action, Rules, RuleResult)

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

@@ -22,6 +22,7 @@ import Data.Binary
 import           Development.IDE.Import.DependencyInformation
 import Development.IDE.GHC.Compat hiding (HieFileResult)
 import Development.IDE.GHC.Util
+import Development.IDE.Types.HscEnvEq (HscEnvEq)
 import Development.IDE.Types.KnownTargets
 import           Data.Hashable
 import           Data.Typeable
@@ -191,10 +192,10 @@ data HieKind a where
 instance NFData (HieKind a) where
     rnf (HieFromDisk hf) = rnf hf
     rnf HieFresh = ()
- 
+
 instance NFData HieAstResult where
     rnf (HAR m hf _rm _tr kind) = rnf m `seq` rwhnf hf `seq` rnf kind
- 
+
 instance Show HieAstResult where
     show = show . hieModule
 

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

@@ -112,6 +112,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint
 import Development.IDE.Core.IdeConfiguration
 import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
+import Development.IDE.Types.HscEnvEq
 import Development.Shake.Classes hiding (get, put)
 import Control.Monad.Trans.Except (runExceptT,ExceptT,except)
 import Control.Concurrent.Async (concurrently)

ghcide/src/Development/IDE/GHC/Util.hs

@@ -4,14 +4,8 @@
 
 -- | General utility functions, mostly focused around GHC operations.
 module Development.IDE.GHC.Util(
-    -- * HcsEnv and environment
-    HscEnvEq,
-    hscEnv, newHscEnvEq,
-    hscEnvWithImportPaths,
-    envImportPaths,
     modifyDynFlags,
     evalGhcEnv,
-    deps,
     -- * GHC wrappers
     prettyPrint,
     unsafePrintSDoc,
@@ -32,8 +26,7 @@ module Development.IDE.GHC.Util(
     setHieDir,
     dontWriteHieFiles,
     disableWarningsAsErrors,
-    newHscEnvEqPreserveImportPaths,
-    newHscEnvEqWithImportPaths) where
+    ) where
 
 import Control.Concurrent
 import Data.List.Extra
@@ -56,8 +49,6 @@ import GHC.IO.Encoding
 import GHC.IO.Exception
 import GHC.IO.Handle.Types
 import GHC.IO.Handle.Internals
-import Data.Unique
-import Development.Shake.Classes
 import qualified Data.Text                as T
 import qualified Data.Text.Encoding       as T
 import qualified Data.Text.Encoding.Error as T
@@ -71,13 +62,12 @@ import Outputable (SDoc, showSDocUnsafe, ppr, Outputable, mkUserStyle, renderWit
 import Packages (getPackageConfigMap, lookupPackage')
 import SrcLoc (mkRealSrcLoc)
 import FastString (mkFastString)
-import Module (moduleNameSlashes, InstalledUnitId)
+import Module (moduleNameSlashes)
 import OccName (parenSymOcc)
 import RdrName (nameRdrName, rdrNameOcc)
 
 import Development.IDE.GHC.Compat as GHC
 import Development.IDE.Types.Location
-import System.Directory (canonicalizePath)
 
 
 ----------------------------------------------------------------------
@@ -178,77 +168,6 @@ moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
         fromNormalizedFilePath $ toNormalizedFilePath' $
         moduleNameSlashes mn
 
--- | An 'HscEnv' with equality. Two values are considered equal
---   if they are created with the same call to 'newHscEnvEq'.
-data HscEnvEq = HscEnvEq
-    { envUnique :: !Unique
-    , hscEnv :: !HscEnv
-    , deps   :: [(InstalledUnitId, DynFlags)]
-               -- ^ In memory components for this HscEnv
-               -- This is only used at the moment for the import dirs in
-               -- the DynFlags
-    , envImportPaths :: Maybe [String]
-        -- ^ If Just, import dirs originally configured in this env
-        --   If Nothing, the env import dirs are unaltered
-    }
-
--- | Wrap an 'HscEnv' into an 'HscEnvEq'.
-newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
-newHscEnvEq cradlePath hscEnv0 deps = do
-    envUnique <- newUnique
-    let relativeToCradle = (takeDirectory cradlePath </>)
-        hscEnv = removeImportPaths hscEnv0
-
-    -- Canonicalize import paths since we also canonicalize targets
-    importPathsCanon <-
-      mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
-    let envImportPaths = Just importPathsCanon
-
-    return HscEnvEq{..}
-
-newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
-newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
-    envUnique <- newUnique
-    return HscEnvEq{..}
-
--- | Wrap an 'HscEnv' into an 'HscEnvEq'.
-newHscEnvEqPreserveImportPaths
-    :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
-newHscEnvEqPreserveImportPaths hscEnv deps = do
-    let envImportPaths = Nothing
-    envUnique <- newUnique
-    return HscEnvEq{..}
-
--- | Unwrap the 'HscEnv' with the original import paths.
---   Used only for locating imports
-hscEnvWithImportPaths :: HscEnvEq -> HscEnv
-hscEnvWithImportPaths HscEnvEq{..}
-    | Just imps <- envImportPaths
-    = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = imps}}
-    | otherwise
-    = hscEnv
-
-removeImportPaths :: HscEnv -> HscEnv
-removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}}
-
-instance Show HscEnvEq where
-  show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique)
-
-instance Eq HscEnvEq where
-  a == b = envUnique a == envUnique b
-
-instance NFData HscEnvEq where
-  rnf (HscEnvEq a b c d) = rnf (hashUnique a) `seq` b `seq` c `seq` rnf d
-
-instance Hashable HscEnvEq where
-  hashWithSalt s = hashWithSalt s . envUnique
-
--- Fake instance needed to persuade Shake to accept this type as a key.
--- No harm done as ghcide never persists these keys currently
-instance Binary HscEnvEq where
-  put _ = error "not really"
-  get = error "not really"
-
 -- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
 readFileUtf8 :: FilePath -> IO T.Text
 readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f