Add -fghci-leak-check to check for space leaks
[ghc.git] / ghc / GHCi / Leak.hs
1 {-# LANGUAGE RecordWildCards, LambdaCase #-}
2 module GHCi.Leak
3 ( LeakIndicators
4 , getLeakIndicators
5 , checkLeakIndicators
6 ) where
7
8 import Control.Monad
9 import GHC
10 import Outputable
11 import HscTypes
12 import UniqDFM
13 import System.Mem
14 import System.Mem.Weak
15
16 -- Checking for space leaks in GHCi. See #15111, and the
17 -- -fghci-leak-check flag.
18
19 data LeakIndicators = LeakIndicators [LeakModIndicators]
20
21 data LeakModIndicators = LeakModIndicators
22 { leakMod :: Weak HomeModInfo
23 , leakIface :: Weak ModIface
24 , leakDetails :: Weak ModDetails
25 , leakLinkable :: Maybe (Weak Linkable)
26 }
27
28 -- | Grab weak references to some of the data structures representing
29 -- the currently loaded modules.
30 getLeakIndicators :: HscEnv -> IO LeakIndicators
31 getLeakIndicators HscEnv{..} =
32 fmap LeakIndicators $
33 forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do
34 leakMod <- mkWeakPtr hmi Nothing
35 leakIface <- mkWeakPtr hm_iface Nothing
36 leakDetails <- mkWeakPtr hm_details Nothing
37 leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable
38 return $ LeakModIndicators{..}
39
40 -- | Look at the LeakIndicators collected by an earlier call to
41 -- `getLeakIndicators`, and print messasges if any of them are still
42 -- alive.
43 checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()
44 checkLeakIndicators dflags (LeakIndicators leakmods) = do
45 performGC
46 forM_ leakmods $ \LeakModIndicators{..} -> do
47 deRefWeak leakMod >>= \case
48 Nothing -> return ()
49 Just hmi ->
50 report ("HomeModInfo for " ++
51 showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)
52 deRefWeak leakIface >>= report "ModIface"
53 deRefWeak leakDetails >>= report "ModDetails"
54 forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"
55 where
56 report :: String -> Maybe a -> IO ()
57 report _ Nothing = return ()
58 report msg (Just _) =
59 putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive!")