isFullyEvaluated,
isPointed,
isFullyEvaluatedTerm,
+ mapTermType,
+ termTyVars
-- unsafeDeepSeq,
) where
import PrelNames
import TysWiredIn
-import Constants ( wORD_SIZE )
+import Constants
import Outputable
import Maybes
import Panic
import GHC.Arr ( Array(..) )
import GHC.Ptr ( Ptr(..), castPtr )
-import GHC.Exts
-import GHC.Int ( Int32(..), Int64(..) )
-import GHC.Word ( Word32(..), Word64(..) )
+import GHC.Exts
import Control.Monad
import Data.Maybe
import Data.Array.Base
-import Data.List ( partition )
-import Foreign.Storable
-
-import IO
+import Data.List ( partition, nub )
+import Foreign
---------------------------------------------
-- * A representation of semi evaluated Terms
, subTerms :: [Term] }
| Prim { ty :: Type
- , value :: String }
+ , value :: [Word] }
| Suspension { ctype :: ClosureType
, mb_ty :: Maybe Type
, infoPtr :: Ptr ()
, infoTable :: StgInfoTable
, ptrs :: Array Int HValue
- , nonPtrs :: ByteArray#
+ , nonPtrs :: [Word]
}
instance Outputable ClosureType where
let tipe = readCType (BCI.tipe itbl)
elems = BCI.ptrs itbl
ptrsList = Array 0 (fromIntegral$ elems) ptrs
- ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
+ nptrs_data = [W# (indexWordArray# nptrs i)
+ | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
+ ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
readCType :: Integral a => a -> ClosureType
readCType i
| 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
isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
isPointed _ = True
-#define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
-
-extractUnboxed :: [Type] -> ByteArray# -> [String]
-extractUnboxed tt ba = helper tt (byteArrayContents# ba)
- where helper :: [Type] -> Addr# -> [String]
- helper (t:tt) addr
- | Just ( tycon,_) <- splitTyConApp_maybe t
- = let (offset, txt) = decode tycon addr
- (I# word_offset) = offset*wORD_SIZE
- in txt : helper tt (plusAddr# addr word_offset)
- | otherwise
- = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
- panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
- helper [] addr = []
- decode :: TyCon -> Addr# -> (Int, String)
- decode t addr
- | t == charPrimTyCon = MKDECODER(1,C#,indexCharOffAddr#)
- | t == intPrimTyCon = MKDECODER(1,I#,indexIntOffAddr#)
- | t == wordPrimTyCon = MKDECODER(1,W#,indexWordOffAddr#)
- | t == floatPrimTyCon = MKDECODER(1,F#,indexFloatOffAddr#)
- | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
- | t == int32PrimTyCon = MKDECODER(1,I32#,indexInt32OffAddr#)
- | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
- | t == int64PrimTyCon = MKDECODER(2,I64#,indexInt64OffAddr#)
- | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
- | t == addrPrimTyCon = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off))) --OPT Improve the presentation of addresses
- | t == stablePtrPrimTyCon = (1, "<stablePtr>")
- | t == stableNamePrimTyCon = (1, "<stableName>")
- | t == statePrimTyCon = (1, "<statethread>")
- | t == realWorldTyCon = (1, "<realworld>")
- | t == threadIdPrimTyCon = (1, "<ThreadId>")
- | t == weakPrimTyCon = (1, "<Weak>")
- | t == arrayPrimTyCon = (1,"<array>")
- | t == byteArrayPrimTyCon = (1,"<bytearray>")
- | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
- | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
- | t == mutVarPrimTyCon= (1, "<mutVar>")
- | t == mVarPrimTyCon = (1, "<mVar>")
- | t == tVarPrimTyCon = (1, "<tVar>")
- | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
- -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
- -- TODO: Improve the offset handling in decode (make it machine dependant)
+extractUnboxed :: [Type] -> Closure -> [[Word]]
+extractUnboxed tt clos = go tt (nonPtrs clos)
+ where sizeofType t
+ | Just (tycon,_) <- splitTyConApp_maybe t
+ = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
+ | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
+ go [] _ = []
+ go (t:tt) xx
+ | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
+ = x : go tt rest
+
+sizeofTyCon = sizeofPrimRep . tyConPrimRep
-----------------------------------
-- * Traversals for Terms
-----------------------------------
data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
- , fPrim :: Type -> String -> a
+ , fPrim :: Type -> [Word] -> a
, fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
}
fSuspension = (((return.).).). Suspension
}
+mapTermType f = foldTerm idTermFold {
+ fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
+ fSuspension = \ct mb_ty hval n ->
+ Suspension ct (fmap f mb_ty) hval n }
+
+termTyVars = foldTerm TermFold {
+ fTerm = \ty _ _ tt ->
+ tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
+ fSuspension = \_ mb_ty _ _ ->
+ maybe emptyVarEnv tyVarsOfType mb_ty,
+ fPrim = \ _ _ -> emptyVarEnv }
+ where concatVarEnv = foldr plusVarEnv emptyVarEnv
----------------------------------
-- Pretty printing of terms
----------------------------------
pprTerm _ t = pprTerm1 t
-pprTerm1 Prim{value=value} = text value
+pprTerm1 Prim{value=words, ty=ty} = text$ repPrim (tyConAppTyCon ty) words
pprTerm1 t@Term{} = pprTerm 0 t
pprTerm1 Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n}
getListTerms t@Suspension{} = [t]
getListTerms t = pprPanic "getListTerms" (ppr t)
+repPrim :: TyCon -> [Word] -> String
+repPrim t = rep where
+ rep x
+ | t == charPrimTyCon = show (build x :: Char)
+ | t == intPrimTyCon = show (build x :: Int)
+ | t == wordPrimTyCon = show (build x :: Word)
+ | t == floatPrimTyCon = show (build x :: Float)
+ | t == doublePrimTyCon = show (build x :: Double)
+ | t == int32PrimTyCon = show (build x :: Int32)
+ | t == word32PrimTyCon = show (build x :: Word32)
+ | t == int64PrimTyCon = show (build x :: Int64)
+ | t == word64PrimTyCon = show (build x :: Word64)
+ | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
+ | t == stablePtrPrimTyCon = "<stablePtr>"
+ | t == stableNamePrimTyCon = "<stableName>"
+ | t == statePrimTyCon = "<statethread>"
+ | t == realWorldTyCon = "<realworld>"
+ | t == threadIdPrimTyCon = "<ThreadId>"
+ | t == weakPrimTyCon = "<Weak>"
+ | t == arrayPrimTyCon = "<array>"
+ | t == byteArrayPrimTyCon = "<bytearray>"
+ | t == mutableArrayPrimTyCon = "<mutableArray>"
+ | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
+ | t == mutVarPrimTyCon= "<mutVar>"
+ | t == mVarPrimTyCon = "<mVar>"
+ | t == tVarPrimTyCon = "<tVar>"
+ | otherwise = showSDoc (char '<' <> ppr t <> char '>')
+ where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
-----------------------------------
-- Type Reconstruction
-----------------------------------
runTR :: HscEnv -> TR Term -> IO Term
runTR hsc_env c = do
- mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
+ mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
case mb_term of
Nothing -> panic "Can't unify"
Just term -> return term
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
+ Nothing -> go tv tv hval >>= zonkTerm
+ Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
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
+ term <- go tv tv hval >>= zonkTerm
--restore original Tyvars
- return$ flip foldTerm term idTermFold {
- fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
- fSuspension = \ct mb_ty hval n ->
- Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
+ return$ mapTermType (substTy rev_subst) term
where
go tv ty a = do
let monomorphic = not(isTyVarTy tv) -- This is a convention. The ancestor tests for
clos <- trIO $ getClosureData a
case tipe clos of
-- Thunks we may want to force
- Thunk _ | force -> seq a $ go tv ty a
+-- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
+-- force blackholes, because it would almost certainly result in deadlock,
+-- and showing the '_' is more useful.
+ t | isThunk t && force -> seq a $ go tv ty a
-- We always follow indirections
Indirection _ -> go tv ty $! (ptrs clos ! 0)
-- The interesting case
subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
[ appArr (go tv t) (ptrs clos) i
| (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
- let unboxeds = extractUnboxed subTtypesNP (nonPtrs clos)
+ let unboxeds = extractUnboxed subTtypesNP clos
subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
subTerms = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes)
return (Term tv dc a subTerms)
, 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 {
projects / ghc-hetmet.git / blobdiff