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

import Control.Monad
import Data.Bits
import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
import GHC
import GHC.Ptr (Ptr (..))
import Clash.GHCi.Util
import HscTypes
import Outputable
import GHC.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{[Target]
Maybe (Module, IORef TypeEnv)
MVar (Maybe IServ)
IORef ExternalPackageState
IORef NameCache
IORef FinderCache
InteractiveContext
ModuleGraph
DynLinker
HomePackageTable
DynFlags
hsc_dflags :: HscEnv -> DynFlags
hsc_targets :: HscEnv -> [Target]
hsc_mod_graph :: HscEnv -> ModuleGraph
hsc_IC :: HscEnv -> InteractiveContext
hsc_HPT :: HscEnv -> HomePackageTable
hsc_EPS :: HscEnv -> IORef ExternalPackageState
hsc_NC :: HscEnv -> IORef NameCache
hsc_FC :: HscEnv -> IORef FinderCache
hsc_type_env_var :: HscEnv -> Maybe (Module, IORef TypeEnv)
hsc_iserv :: HscEnv -> MVar (Maybe IServ)
hsc_dynLinker :: HscEnv -> DynLinker
hsc_dynLinker :: DynLinker
hsc_iserv :: MVar (Maybe IServ)
hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_FC :: IORef FinderCache
hsc_NC :: IORef NameCache
hsc_EPS :: IORef ExternalPackageState
hsc_HPT :: HomePackageTable
hsc_IC :: InteractiveContext
hsc_mod_graph :: ModuleGraph
hsc_targets :: [Target]
hsc_dflags :: DynFlags
..} =
  ([LeakModIndicators] -> LeakIndicators)
-> IO [LeakModIndicators] -> IO LeakIndicators
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 (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{Maybe Linkable
ModIface
ModDetails
hm_iface :: HomeModInfo -> ModIface
hm_details :: HomeModInfo -> ModDetails
hm_linkable :: HomeModInfo -> Maybe Linkable
hm_linkable :: Maybe Linkable
hm_details :: ModDetails
hm_iface :: ModIface
..} -> 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 :: Type -> Type) (m :: Type -> Type) 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 :: Type -> Type) 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{Maybe (Weak Linkable)
Weak HomeModInfo
Weak ModIface
Weak ModDetails
leakLinkable :: Maybe (Weak Linkable)
leakDetails :: Weak ModDetails
leakIface :: Weak ModIface
leakMod :: Weak HomeModInfo
leakLinkable :: Maybe (Weak Linkable)
leakDetails :: Weak ModDetails
leakIface :: Weak ModIface
leakMod :: Weak HomeModInfo
..}

-- | 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 HomeModInfo
Weak ModIface
Weak ModDetails
leakLinkable :: Maybe (Weak Linkable)
leakDetails :: Weak ModDetails
leakIface :: Weak ModIface
leakMod :: Weak HomeModInfo
leakLinkable :: LeakModIndicators -> Maybe (Weak Linkable)
leakDetails :: LeakModIndicators -> Weak ModDetails
leakIface :: LeakModIndicators -> Weak ModIface
leakMod :: LeakModIndicators -> Weak HomeModInfo
..} -> 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 :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe HomeModInfo
Nothing -> () -> IO ()
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 (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe ModIface -> IO ()
forall a. String -> Maybe a -> IO ()
report String
"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 :: 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) -> (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 ((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 (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 :: String -> Maybe a -> IO ()
report String
_ Maybe a
Nothing = () -> IO ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
  report String
msg (Just a
a) = do
    Ptr ()
addr <- a -> IO (Ptr ())
forall a. a -> IO (Ptr ())
anyToPtr a
a
    String -> IO ()
putStrLn (String
"-fghci-leak-check: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 (DynFlags -> Platform
targetPlatform DynFlags
dflags) = Int
2
    | Bool
otherwise = Int
3

  maskTagBits :: Ptr a -> Ptr a
  maskTagBits :: 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))