{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}

module Debug.RecoverRTTI.FlatClosure (
    FlatClosure(..)
  , getBoxedClosureData
    -- * Re-exports
  , Box(..)
  , asBox
  ) where

import Control.Exception (evaluate)
import Control.Monad
import GHC.Exts.Heap (Box(..), asBox)
import qualified GHC.Exts.Heap as H

-- | Flattened form of 'Closure' (with indirection nodes removed)
--
-- We only include the fields of 'Closure' that we are interested in.
--
-- TODO: For functions ('FunClosure', 'PAPClosure') we don't currently include
-- any information at all. We could potentially do better here.
data FlatClosure =
    -- | Constructor application
    ConstrClosure {
        FlatClosure -> [Box]
ptrArgs :: [Box]
      , FlatClosure -> String
pkg     :: String
      , FlatClosure -> String
modl    :: String
      , FlatClosure -> String
name    :: String
      }

    -- | Functions
    --
    -- We map 'H.FunClosure', 'H.PAPClosure' and H.BCOClosure' all to this.
  | FunClosure

    -- | Unrecognized closure type
  | OtherClosure H.Closure
  deriving (Int -> FlatClosure -> ShowS
[FlatClosure] -> ShowS
FlatClosure -> String
(Int -> FlatClosure -> ShowS)
-> (FlatClosure -> String)
-> ([FlatClosure] -> ShowS)
-> Show FlatClosure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlatClosure] -> ShowS
$cshowList :: [FlatClosure] -> ShowS
show :: FlatClosure -> String
$cshow :: FlatClosure -> String
showsPrec :: Int -> FlatClosure -> ShowS
$cshowsPrec :: Int -> FlatClosure -> ShowS
Show)

getBoxedClosureData :: Box -> IO FlatClosure
getBoxedClosureData :: Box -> IO FlatClosure
getBoxedClosureData Box
b = do
    Box -> IO ()
tryForceBox Box
b
    Closure -> IO FlatClosure
fromClosure (Closure -> IO FlatClosure) -> IO Closure -> IO FlatClosure
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Box -> IO Closure
H.getBoxedClosureData Box
b
  where
    fromClosure :: H.Closure -> IO FlatClosure
    fromClosure :: Closure -> IO FlatClosure
fromClosure = \case
        -- Indirections
        --
        -- For background on black holes, see "Implementing Lazy Functional
        -- Languages on Stock Hardware: The Spineless Tagless G-machine", Simon
        -- Peyton Jones, Journal of Functional Programming, July 1992, section
        -- 9.3.3 "Black holes".

        H.BlackholeClosure StgInfoTable
_ Box
x' -> Box -> IO FlatClosure
getBoxedClosureData Box
x'
        H.IndClosure       StgInfoTable
_ Box
x' -> Box -> IO FlatClosure
getBoxedClosureData Box
x'

        -- Constructor application

        H.ConstrClosure{[Box]
ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs :: [Box]
ptrArgs, String
pkg :: forall b. GenClosure b -> String
pkg :: String
pkg, String
modl :: forall b. GenClosure b -> String
modl :: String
modl, String
name :: forall b. GenClosure b -> String
name :: String
name} ->
          FlatClosure -> IO FlatClosure
forall (m :: * -> *) a. Monad m => a -> m a
return (FlatClosure -> IO FlatClosure) -> FlatClosure -> IO FlatClosure
forall a b. (a -> b) -> a -> b
$ ConstrClosure :: [Box] -> String -> String -> String -> FlatClosure
ConstrClosure{String
[Box]
name :: String
modl :: String
pkg :: String
ptrArgs :: [Box]
name :: String
modl :: String
pkg :: String
ptrArgs :: [Box]
..}

        -- Functions

        H.FunClosure{} -> FlatClosure -> IO FlatClosure
forall (m :: * -> *) a. Monad m => a -> m a
return (FlatClosure -> IO FlatClosure) -> FlatClosure -> IO FlatClosure
forall a b. (a -> b) -> a -> b
$ FlatClosure
FunClosure
        H.PAPClosure{} -> FlatClosure -> IO FlatClosure
forall (m :: * -> *) a. Monad m => a -> m a
return (FlatClosure -> IO FlatClosure) -> FlatClosure -> IO FlatClosure
forall a b. (a -> b) -> a -> b
$ FlatClosure
FunClosure
        H.BCOClosure{} -> FlatClosure -> IO FlatClosure
forall (m :: * -> *) a. Monad m => a -> m a
return (FlatClosure -> IO FlatClosure) -> FlatClosure -> IO FlatClosure
forall a b. (a -> b) -> a -> b
$ FlatClosure
FunClosure

        -- Other kinds of constructors

        Closure
otherClosure ->
          FlatClosure -> IO FlatClosure
forall (m :: * -> *) a. Monad m => a -> m a
return (FlatClosure -> IO FlatClosure) -> FlatClosure -> IO FlatClosure
forall a b. (a -> b) -> a -> b
$ Closure -> FlatClosure
OtherClosure Closure
otherClosure

-- | Force the value to WHNF, if possible
--
-- We /cannot/ force the argument until we know what kind of closure we're
-- dealing with. If this is an unlifted closure, forcing it will result in a
-- ghc runtime crash.
tryForceBox :: Box -> IO ()
tryForceBox :: Box -> IO ()
tryForceBox b :: Box
b@(Box Any
x) = do
    Closure
closure <- Box -> IO Closure
H.getBoxedClosureData Box
b
    case Closure
closure of

      H.APClosure{}       -> IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ Any -> IO Any
forall a. a -> IO a
evaluate Any
x
      H.ThunkClosure{}    -> IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ Any -> IO Any
forall a. a -> IO a
evaluate Any
x
      H.SelectorClosure{} -> IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ Any -> IO Any
forall a. a -> IO a
evaluate Any
x
      Closure
_otherwise          -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()