diff options
Diffstat (limited to 'ghc/GHCi')
-rw-r--r-- | ghc/GHCi/Leak.hs | 59 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 15 |
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 () |