|
| 1 | +{-# LANGUAGE RecordWildCards, LambdaCase #-} |
| 2 | +module Clash.GHCi.Leak |
| 3 | + ( LeakIndicators |
| 4 | + , getLeakIndicators |
| 5 | + , checkLeakIndicators |
| 6 | + ) where |
| 7 | + |
| 8 | +import Control.Monad |
| 9 | +import Data.Bits |
| 10 | +import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) |
| 11 | +import GHC |
| 12 | +import GHC.Ptr (Ptr (..)) |
| 13 | +import Clash.GHCi.Util |
| 14 | +import GHC.Driver.Env |
| 15 | +import GHC.Driver.Ppr |
| 16 | +import GHC.Utils.Outputable |
| 17 | +import GHC.Unit.Module.ModDetails |
| 18 | +import GHC.Unit.Home.ModInfo |
| 19 | +import GHC.Platform (target32Bit) |
| 20 | +import GHC.Linker.Types |
| 21 | +import Prelude |
| 22 | +import System.Mem |
| 23 | +import System.Mem.Weak |
| 24 | +import GHC.Types.Unique.DFM |
| 25 | +import Control.Exception |
| 26 | + |
| 27 | +-- Checking for space leaks in GHCi. See #15111, and the |
| 28 | +-- -fghci-leak-check flag. |
| 29 | + |
| 30 | +data LeakIndicators = LeakIndicators [LeakModIndicators] |
| 31 | + |
| 32 | +data LeakModIndicators = LeakModIndicators |
| 33 | + { leakMod :: Weak HomeModInfo |
| 34 | + , leakIface :: Weak ModIface |
| 35 | + , leakDetails :: Weak ModDetails |
| 36 | + , leakLinkable :: [Maybe (Weak Linkable)] |
| 37 | + } |
| 38 | + |
| 39 | +-- | Grab weak references to some of the data structures representing |
| 40 | +-- the currently loaded modules. |
| 41 | +getLeakIndicators :: HscEnv -> IO LeakIndicators |
| 42 | +getLeakIndicators hsc_env = |
| 43 | + fmap LeakIndicators $ |
| 44 | + forM (eltsUDFM (hsc_HPT hsc_env)) $ \hmi@HomeModInfo{..} -> do |
| 45 | + leakMod <- mkWeakPtr hmi Nothing |
| 46 | + leakIface <- mkWeakPtr hm_iface Nothing |
| 47 | + leakDetails <- mkWeakPtr hm_details Nothing |
| 48 | + leakLinkable <- mkWeakLinkables hm_linkable |
| 49 | + return $ LeakModIndicators{..} |
| 50 | + where |
| 51 | + mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)] |
| 52 | + mkWeakLinkables (HomeModLinkable mbc mo) = |
| 53 | + mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo] |
| 54 | + |
| 55 | +-- | Look at the LeakIndicators collected by an earlier call to |
| 56 | +-- `getLeakIndicators`, and print messasges if any of them are still |
| 57 | +-- alive. |
| 58 | +checkLeakIndicators :: DynFlags -> LeakIndicators -> IO () |
| 59 | +checkLeakIndicators dflags (LeakIndicators leakmods) = do |
| 60 | + performGC |
| 61 | + forM_ leakmods $ \LeakModIndicators{..} -> do |
| 62 | + deRefWeak leakMod >>= \case |
| 63 | + Nothing -> return () |
| 64 | + Just hmi -> |
| 65 | + report ("HomeModInfo for " ++ |
| 66 | + showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi) |
| 67 | + deRefWeak leakIface >>= \case |
| 68 | + Nothing -> return () |
| 69 | + Just miface -> report ("ModIface:" ++ moduleNameString (moduleName (mi_module miface))) (Just miface) |
| 70 | + deRefWeak leakDetails >>= report "ModDetails" |
| 71 | + forM_ leakLinkable $ \l -> forM_ l $ \l' -> deRefWeak l' >>= report "Linkable" |
| 72 | + where |
| 73 | + report :: String -> Maybe a -> IO () |
| 74 | + report _ Nothing = return () |
| 75 | + report msg (Just a) = do |
| 76 | + addr <- anyToPtr a |
| 77 | + putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++ |
| 78 | + show (maskTagBits addr)) |
| 79 | + |
| 80 | + tagBits |
| 81 | + | target32Bit (targetPlatform dflags) = 2 |
| 82 | + | otherwise = 3 |
| 83 | + |
| 84 | + maskTagBits :: Ptr a -> Ptr a |
| 85 | + maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1)) |
0 commit comments