Add -fghci-leak-check to check for space leaks

Summary:
Space leaks in GHCi emerge from time to time and tend to come back again
after they get fixed. This is an attempt to limit regressions by

* adding a reliable detection for some classes of space leaks in GHCi
* turning on leak checking for all GHCi tests in the test suite, so that
  we'll notice if the leak appears again.

The idea for detecting space leaks is quite simple:

* find some data that we expect to be GC'd later, make a weak pointer to it
* when we expect the data to be dead, do a `performGC` and then check
  the status of the weak pointer.

It would be nice to apply this trick to lots of things in GHC,
e.g. ensuring that HsSyn is not retained after the desugarer, or
ensuring that CoreSyn from the previous simplifier pass is not retained.

Test Plan: validate

Reviewers: bgamari, simonpj, erikd, niteria

Subscribers: thomie, carter

GHC Trac Issues: #15111

Differential Revision: https://phabricator.haskell.org/D4658

3 files changed, 74 insertions, 1 deletions

diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs
new file mode 100644
index 0000000000..3f64b5dcf0
--- /dev/null
+++ b/ghc/GHCi/Leak.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE RecordWildCards, LambdaCase #-}
+module GHCi.Leak
+  ( LeakIndicators
+  , getLeakIndicators
+  , checkLeakIndicators
+  ) where
+
+import Control.Monad
+import GHC
+import Outputable
+import HscTypes
+import UniqDFM
+import System.Mem
+import System.Mem.Weak
+
+-- Checking for space leaks in GHCi. See #15111, and the
+-- -fghci-leak-check flag.
+
+data LeakIndicators = LeakIndicators [LeakModIndicators]
+
+data LeakModIndicators = LeakModIndicators
+  { leakMod :: Weak HomeModInfo
+  , leakIface :: Weak ModIface
+  , leakDetails :: Weak ModDetails
+  , leakLinkable :: Maybe (Weak Linkable)
+  }
+
+-- | Grab weak references to some of the data structures representing
+-- the currently loaded modules.
+getLeakIndicators :: HscEnv -> IO LeakIndicators
+getLeakIndicators HscEnv{..} =
+  fmap LeakIndicators $
+    forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do
+      leakMod <- mkWeakPtr hmi Nothing
+      leakIface <- mkWeakPtr hm_iface Nothing
+      leakDetails <- mkWeakPtr hm_details Nothing
+      leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable
+      return $ LeakModIndicators{..}
+
+-- | Look at the LeakIndicators collected by an earlier call to
+-- `getLeakIndicators`, and print messasges if any of them are still
+-- alive.
+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()
+checkLeakIndicators dflags (LeakIndicators leakmods)  = do
+  performGC
+  forM_ leakmods $ \LeakModIndicators{..} -> do
+    deRefWeak leakMod >>= \case
+      Nothing -> return ()
+      Just hmi ->
+        report ("HomeModInfo for " ++
+          showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)
+    deRefWeak leakIface >>= report "ModIface"
+    deRefWeak leakDetails >>= report "ModDetails"
+    forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"
+ where
+  report :: String -> Maybe a -> IO ()
+  report _ Nothing = return ()
+  report msg (Just _) =
+    putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive!")
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 349368b6d7..c97fb01033 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -134,6 +134,8 @@ import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
 import GHC.IO.Handle ( hFlushAll )
 import GHC.TopHandler ( topHandler )
 
+import GHCi.Leak
+
 -----------------------------------------------------------------------------
 
 data GhciSettings = GhciSettings {
@@ -1646,6 +1648,14 @@ loadModule' files = do
   -- require some re-working of the GHC interface, so we'll leave it
   -- as a ToDo for now.
 
+  hsc_env <- GHC.getSession
+
+  -- Grab references to the currently loaded modules so that we can
+  -- see if they leak.
+  leak_indicators <- if gopt Opt_GhciLeakCheck (hsc_dflags hsc_env)
+    then liftIO $ getLeakIndicators hsc_env
+    else return (panic "no leak indicators")
+
   -- unload first
   _ <- GHC.abandonAll
   lift discardActiveBreakPoints
@@ -1653,7 +1663,10 @@ loadModule' files = do
   _ <- GHC.load LoadAllTargets
 
   GHC.setTargets targets
-  doLoadAndCollectInfo False LoadAllTargets
+  success <- doLoadAndCollectInfo False LoadAllTargets
+  when (gopt Opt_GhciLeakCheck (hsc_dflags hsc_env)) $
+    liftIO $ checkLeakIndicators (hsc_dflags hsc_env) leak_indicators
+  return success
 
 -- | @:add@ command
 addModule :: [FilePath] -> InputT GHCi ()
diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in
index 12812ef07c..6c12941630 100644
--- a/ghc/ghc-bin.cabal.in
+++ b/ghc/ghc-bin.cabal.in
@@ -61,6 +61,7 @@ Executable ghc
         CPP-Options: -DGHCI
         GHC-Options: -fno-warn-name-shadowing
         Other-Modules:
+            GHCi.Leak
             GHCi.UI
             GHCi.UI.Info
             GHCi.UI.Monad