diff --git a/Data/IsEvaluated.hs b/Data/IsEvaluated.hs --- a/Data/IsEvaluated.hs +++ b/Data/IsEvaluated.hs @@ -1,47 +1,72 @@ -module Data.IsEvaluated(isEvaluated) where +{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-} -import GHC.Vacuum -import GHC.Vacuum.ClosureType +-- | +-- 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. --- |Checks whether Control.Exception.evaluate (or rwhnf) would do no work --- when applied to the value. May produce false negatives (where isEvaluated --- thinks it would, but it actually wouldn't) in some cases. +-- 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. -- --- Use case: if isEvaluated foo returns True, then evaluate foo will never --- throw an exception, or indeed take more than constant (small) time. +-- It may produce false negatives. +{-# NOINLINE isEvaluated #-} isEvaluated :: a -> IO Bool -isEvaluated a = discriminate `fmap` closureType a - where - discriminate CONSTR = True - discriminate CONSTR_1_0 = True - discriminate CONSTR_0_1 = True - discriminate CONSTR_2_0 = True - discriminate CONSTR_1_1 = True - discriminate CONSTR_0_2 = True - discriminate CONSTR_STATIC = True - discriminate CONSTR_NOCAF_STATIC = True - discriminate FUN = True - discriminate FUN_1_0 = True - discriminate FUN_0_1 = True - discriminate FUN_2_0 = True - discriminate FUN_1_1 = True - discriminate FUN_0_2 = True - discriminate FUN_STATIC = True - discriminate PAP = True - discriminate IND = True - discriminate IND_OLDGEN = True - discriminate IND_PERM = True - discriminate IND_OLDGEN_PERM = True - discriminate IND_STATIC = True --- MVAR_CLEAN -- These are questionable --- MVAR_DIRTY --- ARR_WORDS --- MUT_ARR_PTRS_CLEAN --- MUT_ARR_PTRS_DIRTY --- MUT_ARR_PTRS_FROZEN0 --- MUT_ARR_PTRS_FROZEN --- MUT_VAR_CLEAN --- MUT_VAR_DIRTY --- WEAK - -- It might be possible to handle THUNK_SELECTOR specially - discriminate _ = False +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2009 Svein Ove Aas and Bertram Felgenhauer + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple +#! /usr/bin/env runghc +> import Distribution.Simple (defaultMain) > main = defaultMain diff --git a/isevaluated.cabal b/isevaluated.cabal --- a/isevaluated.cabal +++ b/isevaluated.cabal @@ -1,18 +1,19 @@ -name: isevaluated -version: 0.2 -synopsis: Check whether a value has been evaluated -description: An IO action to check whether some value has been evaluated. - . - If isEvaluated returns True, evaluating it to weak-head - normal form won't throw exceptions or take time. -category: Control, Data, GHC, Debug -license: PublicDomain -author: Svein Ove Aas -maintainer: svein.ove@aas.no -build-type: Simple -cabal-version: >= 1.2 -stability: experimental +Name: isevaluated +Version: 0.3 +Category: Data, GHC +Stability: experimental +Copyright: (c) 2009 Svein Ove Aas and Bertram Felgenhauer +Maintainer: Bertram Felgenhauer +License: MIT +License-File: LICENSE +Synopsis: Check whether a value has been evaluated +Description: An IO action to check whether some value has been evaluated. + . + If isEvaluated returns True, evaluating it to weak-head normal + form won't throw exceptions and take constant time. +Cabal-Version: >= 1.4 +Build-Type: Simple Library - build-depends: base, vacuum - Exposed-Modules: Data.IsEvaluated + Exposed-Modules: Data.IsEvaluated + Build-Depends: base >= 4 && < 5, vacuum >= 0.0.94 && < 0.0.95