cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
- ClosureType(..),
- getClosureData, -- :: a -> IO Closure
- Closure ( tipe, infoPtr, ptrs, nonPtrs ),
- isConstr, -- :: ClosureType -> Bool
- isIndirection, -- :: ClosureType -> Bool
-
- Term(..),
+ Term(..),
pprTerm,
cPprTerm,
cPprTermBase,
import Control.Monad
import Data.Maybe
import Data.Array.Base
-import Data.List ( partition )
+import Data.List ( partition, nub )
import Foreign.Storable
import IO
| i == BLACKHOLE = Blackhole
| i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
| fromIntegral i == aP_CODE = AP
+ | i == AP_STACK = AP
| fromIntegral i == pAP_CODE = PAP
| otherwise = Other (fromIntegral i)
--isIndirection ThunkSelector = True
isIndirection _ = False
+isThunk (Thunk _) = True
+isThunk ThunkSelector = True
+isThunk AP = True
+isThunk _ = False
+
isFullyEvaluated :: a -> IO Bool
isFullyEvaluated a = do
closure <- getClosureData a
return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm hsc_env force mb_ty a = do
- -- Obtain the term and tidy the type before returning it
- term <- cvObtainTerm1 hsc_env force mb_ty a
- return $ tidyTypes term
- where
- tidyTypes = foldTerm idTermFold {
- fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
- fSuspension = \ct mb_ty hval n ->
- Suspension ct (fmap tidy mb_ty) hval n
- }
- tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty
- tidyVarEnv ty = mkVarEnv$
- [ (v, setTyVarName v (tyVarName tv))
- | (tv,v) <- zip alphaTyVars vars]
- where vars = varSetElems$ tyVarsOfType ty
-
-cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
-cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
+cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
tv <- liftM mkTyVarTy (newVar argTypeKind)
case mb_ty of
Nothing -> go tv tv hval
Just ty | isMonomorphic ty -> go ty ty hval
Just ty -> do
- (ty',rev_subst) <- instScheme (sigmaType$ fromJust mb_ty)
+ (ty',rev_subst) <- instScheme (sigmaType ty)
addConstraint tv ty'
term <- go tv tv hval
--restore original Tyvars
clos <- trIO $ getClosureData a
case tipe clos of
-- Thunks we may want to force
- Thunk _ | force -> seq a $ go tv ty a
+ t | isThunk t && force -> seq a $ go tv ty a
-- We always follow indirections
Indirection _ -> go tv ty $! (ptrs clos ! 0)
-- The interesting case
, ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
head unpointed : reOrderTerms pointed (tail unpointed) tys
-isMonomorphic = isEmptyVarSet . tyVarsOfType
+isMonomorphic ty | isForAllTy ty = False
+isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
zonkTerm :: Term -> TcM Term
zonkTerm = foldTerm idTermFoldM {