{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-}

-- |
-- Module      : Data.IsEvaluated
-- Copyright   : (c) 2009 Bertram Felgenhauer
-- License     : MIT
--
-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>
-- 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 "rts/storage/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 cannot 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 perform 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