module RtClosureInspect(
cvObtainTerm,
cvReconstructType,
improveRTTIType,
Term(..),
isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
isFullyEvaluated, isFullyEvaluatedTerm,
termType, mapTermType, termTyVars,
foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection,
sigmaType
) where
#include "HsVersions.h"
import ByteCodeItbls ( StgInfoTable )
import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
import HscTypes
import Linker
import DataCon
import Type
import TypeRep
import Var
import TcRnMonad
import TcType
import TcMType
import TcUnify
import TcEnv
import TyCon
import Name
import VarEnv
import Util
import ListSetOps
import VarSet
import TysPrim
import PrelNames
import TysWiredIn
import DynFlags
import Outputable
import FastString
import Constants ( wORD_SIZE )
import GHC.Arr ( Array(..) )
import GHC.Exts
#if __GLASGOW_HASKELL__ >= 611
import GHC.IO ( IO(..) )
#else
import GHC.IOBase ( IO(..) )
#endif
import Control.Monad
import Data.Maybe
import Data.Array.Base
import Data.Ix
import Data.List
import qualified Data.Sequence as Seq
import Data.Monoid
import Data.Sequence (viewl, ViewL(..))
import Foreign
data Term = Term { ty :: RttiType
, dc :: Either String DataCon
, val :: HValue
, subTerms :: [Term] }
| Prim { ty :: RttiType
, value :: [Word] }
| Suspension { ctype :: ClosureType
, ty :: RttiType
, val :: HValue
, bound_to :: Maybe Name
}
| NewtypeWrap{
ty :: RttiType
, dc :: Either String DataCon
, wrapped_term :: Term }
| RefWrap {
ty :: RttiType
, wrapped_term :: Term }
isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
isTerm Term{} = True
isTerm _ = False
isSuspension Suspension{} = True
isSuspension _ = False
isPrim Prim{} = True
isPrim _ = False
isNewtypeWrap NewtypeWrap{} = True
isNewtypeWrap _ = False
isFun Suspension{ctype=Fun} = True
isFun _ = False
isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
isFunLike _ = False
termType :: Term -> RttiType
termType t = ty t
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Prim {} = True
isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
isFullyEvaluatedTerm _ = False
instance Outputable (Term) where
ppr t | Just doc <- cPprTerm cPprTermBase t = doc
| otherwise = panic "Outputable Term instance"
data ClosureType = Constr
| Fun
| Thunk Int
| ThunkSelector
| Blackhole
| AP
| PAP
| Indirection Int
| MutVar Int
| MVar Int
| Other Int
deriving (Show, Eq)
data Closure = Closure { tipe :: ClosureType
, infoPtr :: Ptr ()
, infoTable :: StgInfoTable
, ptrs :: Array Int HValue
, nonPtrs :: [Word]
}
instance Outputable ClosureType where
ppr = text . show
#include "../includes/rts/storage/ClosureTypes.h"
aP_CODE, pAP_CODE :: Int
aP_CODE = AP
pAP_CODE = PAP
#undef AP
#undef PAP
getClosureData :: a -> IO Closure
getClosureData a =
case unpackClosure# a of
(# iptr, ptrs, nptrs #) -> do
let iptr'
| ghciTablesNextToCode =
Ptr iptr
| otherwise =
Ptr iptr `plusPtr` negate wORD_SIZE
itbl <- peek iptr'
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems 1) elems ptrs
nptrs_data = [W# (indexWordArray# nptrs i)
| I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
ASSERT(elems >= 0) return ()
ptrsList `seq`
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
readCType :: Integral a => a -> ClosureType
readCType i
| i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
| i >= FUN && i <= FUN_STATIC = Fun
| i >= THUNK && i < THUNK_SELECTOR = Thunk i'
| i == THUNK_SELECTOR = ThunkSelector
| i == BLACKHOLE = Blackhole
| i >= IND && i <= IND_STATIC = Indirection i'
| i' == aP_CODE = AP
| i == AP_STACK = AP
| i' == pAP_CODE = PAP
| i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
| i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
| otherwise = Other i'
where i' = fromIntegral i
isConstr, isIndirection, isThunk :: ClosureType -> Bool
isConstr Constr = True
isConstr _ = False
isIndirection (Indirection _) = True
isIndirection _ = False
isThunk (Thunk _) = True
isThunk ThunkSelector = True
isThunk AP = True
isThunk _ = False
isFullyEvaluated :: a -> IO Bool
isFullyEvaluated a = do
closure <- getClosureData a
case tipe closure of
Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
return$ and are_subs_evaluated
_ -> return False
where amapM f = sequence . amap' f
type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
data TermFold a = TermFold { fTerm :: TermProcessor a a
, fPrim :: RttiType -> [Word] -> a
, fSuspension :: ClosureType -> RttiType -> HValue
-> Maybe Name -> a
, fNewtypeWrap :: RttiType -> Either String DataCon
-> a -> a
, fRefWrap :: RttiType -> a -> a
}
data TermFoldM m a =
TermFoldM {fTermM :: TermProcessor a (m a)
, fPrimM :: RttiType -> [Word] -> m a
, fSuspensionM :: ClosureType -> RttiType -> HValue
-> Maybe Name -> m a
, fNewtypeWrapM :: RttiType -> Either String DataCon
-> a -> m a
, fRefWrapM :: RttiType -> a -> m a
}
foldTerm :: TermFold a -> Term -> a
foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
foldTerm tf (Prim ty v ) = fPrim tf ty v
foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
foldTermM :: Monad m => TermFoldM m a -> Term -> m a
foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
foldTermM tf (Prim ty v ) = fPrimM tf ty v
foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
idTermFold :: TermFold Term
idTermFold = TermFold {
fTerm = Term,
fPrim = Prim,
fSuspension = Suspension,
fNewtypeWrap = NewtypeWrap,
fRefWrap = RefWrap
}
mapTermType :: (RttiType -> Type) -> Term -> Term
mapTermType f = foldTerm idTermFold {
fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
fSuspension = \ct ty hval n ->
Suspension ct (f ty) hval n,
fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
fRefWrap = \ty t -> RefWrap (f ty) t}
mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
mapTermTypeM f = foldTermM TermFoldM {
fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
fPrimM = (return.) . Prim,
fSuspensionM = \ct ty hval n ->
f ty >>= \ty' -> return $ Suspension ct ty' hval n,
fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
termTyVars :: Term -> TyVarSet
termTyVars = foldTerm TermFold {
fTerm = \ty _ _ tt ->
tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
fSuspension = \_ ty _ _ -> tyVarsOfType ty,
fPrim = \ _ _ -> emptyVarEnv,
fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
where concatVarEnv = foldr plusVarEnv emptyVarEnv
type Precedence = Int
type TermPrinter = Precedence -> Term -> SDoc
type TermPrinterM m = Precedence -> Term -> m SDoc
app_prec,cons_prec, max_prec ::Int
max_prec = 10
app_prec = max_prec
cons_prec = 5
pprTerm :: TermPrinter -> TermPrinter
pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
pprTerm _ _ _ = panic "pprTerm"
pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
tt_docs <- mapM (y app_prec) tt
return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
ppr_termM y p Term{dc=Right dc, subTerms=tt}
| null tt = return$ ppr dc
| otherwise = do
tt_docs <- mapM (y app_prec) tt
return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
ppr_termM y p RefWrap{wrapped_term=t} = do
contents <- y app_prec t
return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
ppr_termM _ _ t = ppr_termM1 t
ppr_termM1 :: Monad m => Term -> m SDoc
ppr_termM1 Prim{value=words, ty=ty} =
return$ text$ repPrim (tyConAppTyCon ty) words
ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
ppr_termM1 Suspension{ty=ty, bound_to=Just n}
| otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
ppr_termM1 Term{} = panic "ppr_termM1 - Term"
ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
| Just (tc,_) <- tcSplitTyConApp_maybe ty
, ASSERT(isNewTyCon tc) True
, Just new_dc <- tyConSingleDataCon_maybe tc = do
real_term <- y max_prec t
return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
type CustomTermPrinter m = TermPrinterM m
-> [Precedence -> Term -> (m (Maybe SDoc))]
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
cPprTerm printers_ = go 0 where
printers = printers_ go
go prec t = do
let default_ = Just `liftM` pprTermM go prec t
mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
Just doc <- firstJustM mb_customDocs
return$ cparen (prec>app_prec+1) doc
firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
firstJustM [] = return Nothing
cPprTermBase :: Monad m => CustomTermPrinter m
cPprTermBase y =
[ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
. mapM (y (1))
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
(\ p Term{subTerms=[h,t]} -> doList p h t)
, ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
, ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
, ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
, ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
, ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
]
where ifTerm pred f prec t@Term{}
| pred t = Just `liftM` f prec t
ifTerm _ _ _ _ = return Nothing
isTupleTy ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
return (isBoxedTupleTyCon tc)
isTyCon a_tc ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
return (a_tc == tc)
isIntegerTy ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
return (tyConName tc == integerTyConName)
coerceShow f _p = return . text . show . f . unsafeCoerce# . val
doList p h t = do
let elems = h : getListTerms t
isConsLast = not(termType(last elems) `coreEqType` termType h)
print_elems <- mapM (y cons_prec) elems
return$ if isConsLast
then cparen (p >= cons_prec)
. pprDeeperList fsep
. punctuate (space<>colon)
$ print_elems
else brackets (pprDeeperList fcat$
punctuate comma print_elems)
where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
getListTerms Term{subTerms=[]} = []
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 RttiType = Type
type GhciType = Type
type TR a = TcM a
runTR :: HscEnv -> TR a -> IO a
runTR hsc_env thing = do
mb_val <- runTR_maybe hsc_env thing
case mb_val of
Nothing -> error "unable to :print the term"
Just x -> return x
runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
traceTR :: SDoc -> TR ()
traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
recoverTR :: TR a -> TR a -> TR a
recoverTR recover thing = do
(_,mb_res) <- tryTcErrs thing
case mb_res of
Nothing -> recover
Just res -> return res
trIO :: IO a -> TR a
trIO = liftTcM . liftIO
liftTcM :: TcM a -> TR a
liftTcM = id
newVar :: Kind -> TR TcType
newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
instScheme :: Type -> TR (TcType, TvSubst)
instScheme ty = liftTcM$ do
(tvs, _, _) <- tcInstType return ty
(tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
addConstraint :: TcType -> TcType -> TR ()
addConstraint actual expected = do
traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
text "with", ppr expected])
(congruenceNewtypes actual expected >>=
(getLIE . uncurry boxyUnify) >> return ())
cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
let sigma_old_ty = sigmaType old_ty
traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
term <-
if isMonomorphic sigma_old_ty
then do
new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm
return $ fixFunDictionaries $ expandNewtypes new_ty
else do
(old_ty', rev_subst) <- instScheme sigma_old_ty
my_ty <- newVar argTypeKind
when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
addConstraint my_ty old_ty')
term <- go max_depth my_ty sigma_old_ty hval
zterm <- zonkTerm term
let new_ty = termType zterm
if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
then do
traceTR (text "check2 passed")
addConstraint (termType term) old_ty'
zterm' <- zonkTerm term
return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm')
else do
traceTR (text "check2 failed" <+> parens
(ppr zterm <+> text "::" <+> ppr new_ty))
zterm' <- mapTermTypeM
(\ty -> case tcSplitTyConApp_maybe ty of
Just (tc, _:_) | tc /= funTyCon
-> newVar argTypeKind
_ -> return ty)
zterm
zonkTerm zterm'
traceTR (text "Term reconstruction completed." $$
text "Term obtained: " <> ppr term $$
text "Type obtained: " <> ppr (termType term))
return term
where
go :: Int -> Type -> Type -> HValue -> TcM Term
go max_depth _ _ _ | seq max_depth False = undefined
go 0 my_ty _old_ty a = do
traceTR (text "Gave up reconstructing a term after" <>
int max_depth <> text " steps")
clos <- trIO $ getClosureData a
return (Suspension (tipe clos) my_ty a Nothing)
go max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty)
clos <- trIO $ getClosureData a
case tipe clos of
t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
seq a (go (pred max_depth) my_ty old_ty a)
Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
go max_depth my_ty old_ty $! (ptrs clos ! 0)
MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
-> do
traceTR (text "Following a MutVar")
contents_tv <- newVar liftedTypeKind
contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
(mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
contents_ty (mkTyConApp tycon [world,contents_ty])
addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
x <- go (pred max_depth) contents_tv contents_ty contents
return (RefWrap my_ty x)
Constr -> do
traceTR (text "entering a constructor " <>
if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty)
else Outputable.empty)
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
Nothing -> do
let tag = showSDoc (ppr dcname)
vars <- replicateM (length$ elems$ ptrs clos)
(newVar (liftedTypeKind))
subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
| (i, tv) <- zip [0..] vars]
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
let subTtypes = matchSubTypes dc old_ty
subTermTvs <- mapMif (not . isMonomorphic)
(\t -> newVar (typeKind t))
subTtypes
let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
|| isRefType ty)
(zip subTtypes subTermTvs)
(subTtypesP, subTermTvsP ) = unzip subTermsP
(subTtypesNP, _subTermTvsNP) = unzip subTermsNP
when (not monomorphic) $ do
let myType = mkFunTys subTermTvs my_ty
(signatureType,_) <- instScheme (mydataConType dc)
addConstraint myType signatureType
subTermsP <- sequence
[ appArr (go (pred max_depth) tv t) (ptrs clos) i
| (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
subTerms = reOrderTerms subTermsP subTermsNP subTtypes
return (Term my_ty (Right dc) a subTerms)
tipe_clos ->
return (Suspension tipe_clos my_ty a Nothing)
matchSubTypes dc ty
| ty' <- repType ty
, Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
, dc `elem` tyConDataCons tc
= myDataConInstArgTys dc ty_args
| otherwise = dataConRepArgTys dc
reOrderTerms _ _ [] = []
reOrderTerms pointed unpointed (ty:tys)
| isLifted ty || isRefType ty
= ASSERT2(not(null pointed)
, ptext (sLit "reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
| otherwise = ASSERT2(not(null unpointed)
, ptext (sLit "reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
expandNewtypes = foldTerm idTermFold { fTerm = worker } where
worker ty dc hval tt
| Just (tc, args) <- tcSplitTyConApp_maybe ty
, isNewTyCon tc
, wrapped_type <- newTyConInstRhs tc args
, Just dc' <- tyConSingleDataCon_maybe tc
, t' <- worker wrapped_type dc hval tt
= NewtypeWrap ty (Right dc') t'
| otherwise = Term ty dc hval tt
fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
| otherwise = Suspension ct ty hval n
cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
traceTR (text "RTTI started with initial type " <> ppr old_ty)
let sigma_old_ty = sigmaType old_ty
new_ty <-
if isMonomorphic sigma_old_ty
then return old_ty
else do
(old_ty', rev_subst) <- instScheme sigma_old_ty
my_ty <- newVar argTypeKind
when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
addConstraint my_ty old_ty')
search (isMonomorphic `fmap` zonkTcType my_ty)
(\(ty,a) -> go ty a)
(Seq.singleton (my_ty, hval))
max_depth
new_ty <- zonkTcType my_ty
if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
then do
traceTR (text "check2 passed")
addConstraint my_ty old_ty'
new_ty' <- zonkTcType my_ty
return (substTy rev_subst new_ty')
else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
return old_ty
traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
return new_ty
where
search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
int max_depth <> text " steps")
search stop expand l d =
case viewl l of
EmptyL -> return ()
x :< xx -> unlessM stop $ do
new <- expand x
search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
go :: Type -> HValue -> TR [(Type, HValue)]
go my_ty a = do
clos <- trIO $ getClosureData a
case tipe clos of
Indirection _ -> go my_ty $! (ptrs clos ! 0)
MutVar _ -> do
contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
tv' <- newVar liftedTypeKind
world <- newVar liftedTypeKind
addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
return [(tv', contents)]
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
forM [0..length (elems $ ptrs clos)] $ \i -> do
tv <- newVar liftedTypeKind
return$ appArr (\e->(tv,e)) (ptrs clos) i
Just dc -> do
subTtypes <- mapMif (not . isMonomorphic)
(\t -> newVar (typeKind t))
(dataConRepArgTys dc)
let myType = mkFunTys subTtypes my_ty
(signatureType,_) <- instScheme(mydataConType dc)
addConstraint myType signatureType
return $ [ appArr (\e->(t,e)) (ptrs clos) i
| (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
_ -> return []
improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
(ty_tvs, _, _) <- tcInstType return ty
(ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
(_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
_ <- getLIE(boxyUnify rtti_ty' ty')
tvs1_contents <- zonkTcTyVars ty_tvs'
let subst = (uncurry zipTopTvSubst . unzip)
[(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
, getTyVar_maybe ty /= Just tv
]
return subst
where ty = sigmaType _ty
myDataConInstArgTys :: DataCon -> [Type] -> [Type]
myDataConInstArgTys dc args
| null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
| otherwise = dataConRepArgTys dc
mydataConType :: DataCon -> Type
mydataConType dc
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys arg_tys $
res_ty
where univ_tvs = dataConUnivTyVars dc
ex_tvs = dataConExTyVars dc
eq_spec = dataConEqSpec dc
arg_tys = [case a of
PredTy p -> predTypeRep p
_ -> a
| a <- dataConRepArgTys dc]
res_ty = dataConOrigResTy dc
isRefType :: Type -> Bool
isRefType ty
| Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
| otherwise = False
where ty'= repType ty
isRefTyCon :: TyCon -> Bool
isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
check1 :: Type -> Bool
check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
where
isHigherKind = not . null . fst . splitKindFunTys
check2 :: Type -> Type -> Bool
check2 sigma_rtti_ty sigma_old_ty
| Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
= case () of
_ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
-> and$ zipWith check2 rttis olds
_ | Just _ <- splitAppTy_maybe old_ty
-> isMonomorphicOnNonPhantomArgs rtti_ty
_ -> True
| otherwise = True
where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
(_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty
congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
where
go l r
| Just tv <- getTyVar_maybe l
= recoverTR (return r) $ do
Indirect ty_v <- readMetaTyVar tv
traceTR $ fsep [text "(congruence) Following indirect tyvar:",
ppr tv, equals, ppr ty_v]
go ty_v r
| Just (l1,l2) <- splitFunTy_maybe l
, Just (r1,r2) <- splitFunTy_maybe r
= do r2' <- go l2 r2
r1' <- go l1 r1
return (mkFunTy r1' r2')
| Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
, Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
, tycon_l /= tycon_r
= upgrade tycon_l r
| otherwise = return r
where upgrade :: TyCon -> Type -> TR Type
upgrade new_tycon ty
| not (isNewTyCon new_tycon) = do
traceTR (text "(Upgrade) Not matching newtype evidence: " <>
ppr new_tycon <> text " for " <> ppr ty)
return ty
| otherwise = do
traceTR (text "(Upgrade) upgraded " <> ppr ty <>
text " in presence of newtype evidence " <> ppr new_tycon)
vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon vars
_ <- liftTcM (boxyUnify ty (repType ty'))
return ty'
zonkTerm :: Term -> TcM Term
zonkTerm = foldTermM TermFoldM{
fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' ->
return (Term ty' dc v tt)
,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
return (Suspension ct ty v b)
,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
return$ NewtypeWrap ty' dc t
,fRefWrapM = \ty t ->
return RefWrap `ap` zonkTcType ty `ap` return t
,fPrimM = (return.) . Prim
}
dictsView :: Type -> Type
dictsView (FunTy (TyConApp tc_dict args) ty)
| Just c <- tyConClass_maybe tc_dict
= FunTy (PredTy (ClassP c args)) (dictsView ty)
dictsView ty
| Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
, Just c <- tyConClass_maybe tc_dict
= mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
dictsView ty = ty
isMonomorphic :: RttiType -> Bool
isMonomorphic ty = noExistentials && noUniversals
where (tvs, _, ty') = tcSplitSigmaTy ty
noExistentials = isEmptyVarSet (tyVarsOfType ty')
noUniversals = null tvs
isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
isMonomorphicOnNonPhantomArgs ty
| Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
, phantom_vars <- tyConPhantomTyVars tc
, concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
, tyv `notElem` phantom_vars]
= all isMonomorphicOnNonPhantomArgs concrete_args
| Just (ty1, ty2) <- splitFunTy_maybe ty
= all isMonomorphicOnNonPhantomArgs [ty1,ty2]
| otherwise = isMonomorphic ty
tyConPhantomTyVars :: TyCon -> [TyVar]
tyConPhantomTyVars tc
| isAlgTyCon tc
, Just dcs <- tyConDataCons_maybe tc
, dc_vars <- concatMap dataConUnivTyVars dcs
= tyConTyVars tc \\ dc_vars
tyConPhantomTyVars _ = []
sigmaType :: Type -> Type
sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
mapMif pred f xx = sequence $ mapMif_ pred f xx
where
mapMif_ _ _ [] = []
mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM condM acc = condM >>= \c -> unless c acc
appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
= ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
case indexArray# ptrs# i# of
(# e #) -> f e
amap' :: (t -> b) -> Array Int t -> [b]
amap' f (Array i0 i _ arr#) = map g [0 .. i i0]
where g (I# i#) = case indexArray# arr# i# of
(# e #) -> f e
isLifted :: Type -> Bool
isLifted = not . isUnLiftedType
extractUnboxed :: [Type] -> Closure -> [[Word]]
extractUnboxed tt clos = go tt (nonPtrs clos)
where sizeofType t
| Just (tycon,_) <- tcSplitTyConApp_maybe t
= ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
| otherwise = pprPanic "Expected a TcTyCon" (ppr t)
go [] _ = []
go (t:tt) xx
| (x, rest) <- splitAt (sizeofType t) xx
= x : go tt rest
sizeofTyCon :: TyCon -> Int
sizeofTyCon = primRepSizeW . tyConPrimRep
(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
(f |.| g) x = f x || g x