{-# LANGUAGE RecordWildCards, LambdaCase #-}
module Clash.GHCi.Leak
  ( LeakIndicators
  , getLeakIndicators
  , checkLeakIndicators
  ) where

import Clash.GHCi.Util
import Control.Monad
import Data.Bits
import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
import GHC
import GHC.Ptr (Ptr (..))
import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Utils.Outputable
import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Platform (target32Bit)
import GHC.Linker.Types
import Prelude
import System.Mem
import System.Mem.Weak
import GHC.Types.Unique.DFM
import Control.Exception

-- Checking for space leaks in GHCi. See #15111, and the
-- -fghci-leak-check flag.

data LeakIndicators = LeakIndicators [LeakModIndicators]

data LeakModIndicators = LeakModIndicators
  { LeakModIndicators -> Weak HomeModInfo
leakMod :: Weak HomeModInfo
  , LeakModIndicators -> Weak ModIface
leakIface :: Weak ModIface
  , LeakModIndicators -> Weak ModDetails
leakDetails :: Weak ModDetails
  , LeakModIndicators -> [Maybe (Weak Linkable)]
leakLinkable :: [Maybe (Weak Linkable)]
  }

-- | Grab weak references to some of the data structures representing
-- the currently loaded modules.
getLeakIndicators :: HscEnv -> IO LeakIndicators
getLeakIndicators :: HscEnv -> IO LeakIndicators
getLeakIndicators HscEnv
hsc_env =
  ([LeakModIndicators] -> LeakIndicators)
-> IO [LeakModIndicators] -> IO LeakIndicators
forall a b. (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [LeakModIndicators] -> LeakIndicators
LeakIndicators (IO [LeakModIndicators] -> IO LeakIndicators)
-> IO [LeakModIndicators] -> IO LeakIndicators
forall a b. (a -> b) -> a -> b
$
    [HomeModInfo]
-> (HomeModInfo -> IO LeakModIndicators) -> IO [LeakModIndicators]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (UniqDFM ModuleName HomeModInfo -> [HomeModInfo]
forall {k} (key :: k) elt. UniqDFM key elt -> [elt]
eltsUDFM (HscEnv -> UniqDFM ModuleName HomeModInfo
hsc_HPT HscEnv
hsc_env)) ((HomeModInfo -> IO LeakModIndicators) -> IO [LeakModIndicators])
-> (HomeModInfo -> IO LeakModIndicators) -> IO [LeakModIndicators]
forall a b. (a -> b) -> a -> b
$ \hmi :: HomeModInfo
hmi@HomeModInfo{ModIface
ModDetails
HomeModLinkable
hm_iface :: ModIface
hm_details :: ModDetails
hm_linkable :: HomeModLinkable
hm_linkable :: HomeModInfo -> HomeModLinkable
hm_details :: HomeModInfo -> ModDetails
hm_iface :: HomeModInfo -> ModIface
..} -> do
      leakMod <- HomeModInfo -> Maybe (IO ()) -> IO (Weak HomeModInfo)
forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr HomeModInfo
hmi Maybe (IO ())
forall a. Maybe a
Nothing
      leakIface <- mkWeakPtr hm_iface Nothing
      leakDetails <- mkWeakPtr hm_details Nothing
      leakLinkable <-  mkWeakLinkables hm_linkable
      return $ LeakModIndicators{..}
  where
    mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
    mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
mkWeakLinkables (HomeModLinkable Maybe Linkable
mbc Maybe Linkable
mo) =
      (Maybe Linkable -> IO (Maybe (Weak Linkable)))
-> [Maybe Linkable] -> IO [Maybe (Weak Linkable)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (\Maybe Linkable
ln -> (Linkable -> IO (Weak Linkable))
-> Maybe Linkable -> IO (Maybe (Weak Linkable))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((Linkable -> Maybe (IO ()) -> IO (Weak Linkable))
-> Maybe (IO ()) -> Linkable -> IO (Weak Linkable)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Linkable -> Maybe (IO ()) -> IO (Weak Linkable)
forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr Maybe (IO ())
forall a. Maybe a
Nothing (Linkable -> IO (Weak Linkable))
-> (Linkable -> IO Linkable) -> Linkable -> IO (Weak Linkable)
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Linkable -> IO Linkable
forall a. a -> IO a
evaluate) Maybe Linkable
ln) [Maybe Linkable
mbc, Maybe Linkable
mo]

-- | 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 :: DynFlags -> LeakIndicators -> IO ()
checkLeakIndicators DynFlags
dflags (LeakIndicators [LeakModIndicators]
leakmods)  = do
  IO ()
performGC
  [LeakModIndicators] -> (LeakModIndicators -> IO ()) -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LeakModIndicators]
leakmods ((LeakModIndicators -> IO ()) -> IO ())
-> (LeakModIndicators -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LeakModIndicators{[Maybe (Weak Linkable)]
Weak ModIface
Weak ModDetails
Weak HomeModInfo
leakMod :: LeakModIndicators -> Weak HomeModInfo
leakIface :: LeakModIndicators -> Weak ModIface
leakDetails :: LeakModIndicators -> Weak ModDetails
leakLinkable :: LeakModIndicators -> [Maybe (Weak Linkable)]
leakMod :: Weak HomeModInfo
leakIface :: Weak ModIface
leakDetails :: Weak ModDetails
leakLinkable :: [Maybe (Weak Linkable)]
..} -> do
    Weak HomeModInfo -> IO (Maybe HomeModInfo)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak HomeModInfo
leakMod IO (Maybe HomeModInfo) -> (Maybe HomeModInfo -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe HomeModInfo
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
      Just HomeModInfo
hmi ->
        String -> Maybe HomeModInfo -> IO ()
forall a. String -> Maybe a -> IO ()
report (String
"HomeModInfo for " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)))) (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
hmi)
    Weak ModIface -> IO (Maybe ModIface)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ModIface
leakIface IO (Maybe ModIface) -> (Maybe ModIface -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe ModIface
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
      Just ModIface
miface -> String -> Maybe ModIface -> IO ()
forall a. String -> Maybe a -> IO ()
report (String
"ModIface:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
miface))) (ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
miface)
    Weak ModDetails -> IO (Maybe ModDetails)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ModDetails
leakDetails IO (Maybe ModDetails) -> (Maybe ModDetails -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe ModDetails -> IO ()
forall a. String -> Maybe a -> IO ()
report String
"ModDetails"
    [Maybe (Weak Linkable)]
-> (Maybe (Weak Linkable) -> IO ()) -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Maybe (Weak Linkable)]
leakLinkable ((Maybe (Weak Linkable) -> IO ()) -> IO ())
-> (Maybe (Weak Linkable) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Weak Linkable)
l -> Maybe (Weak Linkable) -> (Weak Linkable -> IO ()) -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Weak Linkable)
l ((Weak Linkable -> IO ()) -> IO ())
-> (Weak Linkable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Weak Linkable
l' -> Weak Linkable -> IO (Maybe Linkable)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak Linkable
l' IO (Maybe Linkable) -> (Maybe Linkable -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Linkable -> IO ()
forall a. String -> Maybe a -> IO ()
report String
"Linkable"
 where
  report :: String -> Maybe a -> IO ()
  report :: forall a. String -> Maybe a -> IO ()
report String
_ Maybe a
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  report String
msg (Just a
a) = do
    addr <- a -> IO (Ptr ())
forall a. a -> IO (Ptr ())
anyToPtr a
a
    putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++
              show (maskTagBits addr))

  tagBits :: Int
tagBits
    | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) = Int
2
    | Bool
otherwise = Int
3

  maskTagBits :: Ptr a -> Ptr a
  maskTagBits :: forall a. Ptr a -> Ptr a
maskTagBits Ptr a
p = IntPtr -> Ptr a
forall a. IntPtr -> Ptr a
intPtrToPtr (Ptr a -> IntPtr
forall a. Ptr a -> IntPtr
ptrToIntPtr Ptr a
p IntPtr -> IntPtr -> IntPtr
forall a. Bits a => a -> a -> a
.&. IntPtr -> IntPtr
forall a. Bits a => a -> a
complement (IntPtr -> Int -> IntPtr
forall a. Bits a => a -> Int -> a
shiftL IntPtr
1 Int
tagBits IntPtr -> IntPtr -> IntPtr
forall a. Num a => a -> a -> a
- IntPtr
1))