summaryrefslogtreecommitdiff
path: root/ghc/GHCi
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/GHCi')
-rw-r--r--ghc/GHCi/Leak.hs59
-rw-r--r--ghc/GHCi/UI.hs15
2 files changed, 73 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 3ed1c7f6a3..d449b3ca83 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 {
@@ -1642,6 +1644,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
@@ -1649,7 +1659,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 ()