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

import Control.Monad
import Data.Bits
import DynFlags ( sTargetPlatform )
import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
import GHC
import GHC.Ptr (Ptr (..))
import Clash.GHCi.Util
import HscTypes
import Outputable
import Platform (target32Bit)
import Prelude
import System.Mem
import System.Mem.Weak
import UniqDFM

-- 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{..} =
  ([LeakModIndicators] -> LeakIndicators)
-> IO [LeakModIndicators] -> IO LeakIndicators
forall (f :: * -> *) 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (HomePackageTable -> [HomeModInfo]
forall elt. UniqDFM elt -> [elt]
eltsUDFM HomePackageTable
hsc_HPT) ((HomeModInfo -> IO LeakModIndicators) -> IO [LeakModIndicators])
-> (HomeModInfo -> IO LeakModIndicators) -> IO [LeakModIndicators]
forall a b. (a -> b) -> a -> b
$ \hmi :: HomeModInfo
hmi@HomeModInfo{..} -> do
      Weak HomeModInfo
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
      Weak ModIface
leakIface <- ModIface -> Maybe (IO ()) -> IO (Weak ModIface)
forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr ModIface
hm_iface Maybe (IO ())
forall a. Maybe a
Nothing
      Weak ModDetails
leakDetails <- ModDetails -> Maybe (IO ()) -> IO (Weak ModDetails)
forall k. k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr ModDetails
hm_details Maybe (IO ())
forall a. Maybe a
Nothing
      Maybe (Weak Linkable)
leakLinkable <- (Linkable -> IO (Weak Linkable))
-> Maybe Linkable -> IO (Maybe (Weak Linkable))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Linkable -> Maybe (IO ()) -> IO (Weak Linkable)
forall k. k -> Maybe (IO ()) -> IO (Weak k)
`mkWeakPtr` Maybe (IO ())
forall a. Maybe a
Nothing) Maybe Linkable
hm_linkable
      LeakModIndicators -> IO LeakModIndicators
forall (m :: * -> *) a. Monad m => a -> m a
return (LeakModIndicators -> IO LeakModIndicators)
-> LeakModIndicators -> IO LeakModIndicators
forall a b. (a -> b) -> a -> b
$ LeakModIndicators :: Weak HomeModInfo
-> Weak ModIface
-> Weak ModDetails
-> Maybe (Weak Linkable)
-> LeakModIndicators
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 :: DynFlags -> LeakIndicators -> IO ()
checkLeakIndicators dflags :: DynFlags
dflags (LeakIndicators leakmods :: [LeakModIndicators]
leakmods)  = do
  IO ()
performGC
  [LeakModIndicators] -> (LeakModIndicators -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) 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{..} -> 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just hmi :: HomeModInfo
hmi ->
        String -> Maybe HomeModInfo -> IO ()
forall a. String -> Maybe a -> IO ()
report ("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
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe ModIface -> IO ()
forall a. String -> Maybe a -> IO ()
report "ModIface"
    Weak ModDetails -> IO (Maybe ModDetails)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ModDetails
leakDetails IO (Maybe ModDetails) -> (Maybe ModDetails -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe ModDetails -> IO ()
forall a. String -> Maybe a -> IO ()
report "ModDetails"
    Maybe (Weak Linkable) -> (Weak Linkable -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Weak Linkable)
leakLinkable ((Weak Linkable -> IO ()) -> IO ())
-> (Weak Linkable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \l :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Linkable -> IO ()
forall a. String -> Maybe a -> IO ()
report "Linkable"
 where
  report :: String -> Maybe a -> IO ()
  report :: String -> Maybe a -> IO ()
report _ Nothing = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  report msg :: String
msg (Just a :: a
a) = do
    Ptr ()
addr <- a -> IO (Ptr ())
forall a. a -> IO (Ptr ())
anyToPtr a
a
    String -> IO ()
putStrLn ("-fghci-leak-check: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is still alive at " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              Ptr () -> String
forall a. Show a => a -> String
show (Ptr () -> Ptr ()
forall a. Ptr a -> Ptr a
maskTagBits Ptr ()
addr))

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

  maskTagBits :: Ptr a -> Ptr a
  maskTagBits :: Ptr a -> Ptr a
maskTagBits p :: 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 1 Int
tagBits IntPtr -> IntPtr -> IntPtr
forall a. Num a => a -> a -> a
- 1))