    {-# 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 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

    -- 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 key 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{Maybe Linkable
    ModDetails
    ModIface
    hm_iface :: ModIface
    hm_details :: ModDetails
    hm_linkable :: Maybe Linkable
    hm_iface :: HomeModInfo -> ModIface
    hm_details :: HomeModInfo -> ModDetails
    hm_linkable :: HomeModInfo -> Maybe Linkable
    ..} -> 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)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> Maybe a -> m (Maybe 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 a. a -> IO a
    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{Maybe (Weak Linkable)
    Weak ModDetails
    Weak ModIface
    Weak HomeModInfo
    leakMod :: Weak HomeModInfo
    leakIface :: Weak ModIface
    leakDetails :: Weak ModDetails
    leakLinkable :: Maybe (Weak Linkable)
    leakMod :: Weak HomeModInfo
    leakIface :: Weak ModIface
    leakDetails :: Weak ModDetails
    leakLinkable :: Maybe (Weak Linkable)
    ..}

    -- | 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 ModDetails
    Weak ModIface
    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) -> (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 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
        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 :: 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))