unsafeIsEvaluated.hs

module Data.Evaluated where

import Data.Word
import GHC.Prim
import GHC.Exts
import Foreign

#include "ghcconfig.h"


#if SIZEOF_VOID_P == 8
type HalfWord = Word32
#else
type HalfWord = Word16
#endif

tablesNextToCode :: Bool
#if i386_BUILD_ARCH
#define TABLES_NEXT_TO_CODE
tablesNextToCode = True
#else
tablesNextToCode = False
#endif

getIPtr :: a -> Ptr ()
getIPtr i = case GHC.Prim.unpackClosure# i of (# iptr, _ , _ #) -> GHC.Exts.Ptr iptr

newtype ClosureType = ClosureType Int deriving Show

getClosureType :: a -> IO ClosureType
getClosureType a = do
  let p = getIPtr a
#ifdef TABLES_NEXT_TO_CODE
  (ClosureType . fromIntegral) `fmap` (peek (castPtr p `plusPtr` SIZEOF_INT) :: IO HalfWord)
#else
  (ClosureType . fromIntegral) `fmap` (peek (castPtr p `plusPtr` (SIZEOF_INT*2)) :: IO HalfWord)
#endif

isConstr, isIndirection :: ClosureType -> Bool
isConstr (ClosureType i) = i >= 1 && i<= 8
isIndirection (ClosureType i) = i >= 28 && i <= 32

unsafeIsEvaluated = unsafePerformIO . fmap (\ct -> isConstr ct || isIndirection ct) . getClosureType