{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-} -- | -- Module : Data.IsEvaluated -- Copyright : (c) 2009 Bertram Felgenhauer -- License : MIT -- -- Maintainer : Bertram Felgenhauer -- Stability : experimental -- Portability : ghc only -- -- 'isEvaluated' allows checking for expressions that have already been -- reduced to weak heaf normal form. This can be useful for racing -- computations against one another; if one computation can be shown to -- terminate instantly, there's no need to set up any threads for the race. -- The code below is based on compiler/ghci/RtClosureInspect.hs #include "ClosureTypes.h" module Data.IsEvaluated ( isEvaluated ) where import Foreign import GHC.Exts #if 0 -- for use with the ghc package: import qualified Util as X (ghciTablesNextToCode) import qualified Constants as X (wORD_SIZE) import qualified ByteCodeItbls as X (StgInfoTable(..)) #else -- for use with the vacuum package: import qualified GHC.Vacuum.Internal as X #endif -- | -- If @isEvaluated a@ returns 'True', the given value is in whnf. -- -- It may produce false negatives. {-# NOINLINE isEvaluated #-} isEvaluated :: a -> IO Bool isEvaluated a = case unpackClosure# a of (# iptr, ptrs, nptrs #) -> do let iptr' | X.ghciTablesNextToCode = Ptr iptr | otherwise = Ptr iptr `plusPtr` negate X.wORD_SIZE itbl <- peek iptr' let tipe = fromIntegral (X.tipe itbl) case () of _ | tipe >= IND && tipe <= IND_STATIC -- We found an indirection. Follow it. -- -- We can not assume that this value is fully evaluated: -- If a CAF evaluates to bottom, we end up with a IND_STATIC -- indirection pointing to a thunk that evaluates to bottom again. -- -- We have to be careful to actually do the array lookup without -- forcing the found element - this rules out using GHC.Arr.! -> case indexArray# ptrs 0# of (# a #) -> isEvaluated a | tipe >= CONSTR && tipe <= CONSTR_NOCAF_STATIC || tipe >= FUN && tipe <= FUN_STATIC || tipe == PAP -- We have an evaluated value. -> return True | otherwise -- We have a thunk, black hole, AP or AP_STACK node, or an RTS -- internal type like MutVar# that we usually only see wrapped -- in some data type. -> return False