module RtClosureInspect(
cvObtainTerm,
cvReconstructType,
improveRTTIType,
Term(..),
isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
isFullyEvaluated, isFullyEvaluatedTerm,
termType, mapTermType, termTyCoVars,
foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
constrClosToName, isConstr, isIndirection
) where
#include "HsVersions.h"
import GhcPrelude
import GHCi.RemoteTypes
import HscTypes
import DataCon
import Type
import RepType
import qualified Unify as U
import Var
import TcRnMonad
import TcType
import TcMType
import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv )
import TcUnify
import TcEnv
import TyCon
import Name
import OccName
import Module
import IfaceEnv
import Util
import VarSet
import BasicTypes ( Boxity(..) )
import TysPrim
import PrelNames
import TysWiredIn
import DynFlags
import Outputable as Ppr
import GHC.Char
import GHC.Exts
import GHC.Exts.Heap
import GHC.IO ( IO(..) )
import SMRep ( roundUpTo )
import Control.Monad
import Data.Maybe
import Data.List
import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign
import System.IO.Unsafe
data Term = Term { ty :: RttiType
, dc :: Either String DataCon
, val :: HValue
, subTerms :: [Term] }
| Prim { ty :: RttiType
, valRaw :: [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 Suspension{ctype=FUN_1_0} = True
isFun Suspension{ctype=FUN_0_1} = True
isFun Suspension{ctype=FUN_2_0} = True
isFun Suspension{ctype=FUN_1_1} = True
isFun Suspension{ctype=FUN_0_2} = True
isFun Suspension{ctype=FUN_STATIC} = 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"
isConstr, isIndirection, isThunk :: GenClosure a -> Bool
isConstr ConstrClosure{} = True
isConstr _ = False
isIndirection IndClosure{} = True
isIndirection _ = False
isThunk ThunkClosure{} = True
isThunk APClosure{} = True
isThunk APStackClosure{} = True
isThunk _ = False
isFullyEvaluated :: a -> IO Bool
isFullyEvaluated a = do
closure <- getClosureData a
if isConstr closure
then do are_subs_evaluated <- amapM isFullyEvaluated (ptrArgs closure)
return$ and are_subs_evaluated
else return False
where amapM f = sequence . map (\(Box x) -> f x)
constrClosToName :: HscEnv -> Closure -> IO (Either String Name)
constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
let occName = mkOccName OccName.dataName occ
modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
Right `fmap` lookupOrigIO hsc_env modName occName
constrClosToName _hsc_env clos =
return (Left ("conClosToName: Expected ConstrClosure, got " ++ show clos))
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}
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = foldTerm TermFold {
fTerm = \ty _ _ tt ->
tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
fPrim = \ _ _ -> emptyVarSet,
fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
where concatVarEnv = foldr unionVarSet emptyVarSet
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}
= do { tt_docs' <- mapM (y app_prec) tt
; return $ ifPprDebug (show_tm tt_docs')
(show_tm (dropList (dataConTheta dc) tt_docs'))
}
where
show_tm tt_docs
| null tt_docs = ppr dc
| otherwise = cparen (p >= app_prec) $
sep [ppr dc, nest 2 (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{valRaw=words, ty=ty} =
return $ repPrim (tyConAppTyCon ty) words
ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
return (char '_' <+> whenPprDebug (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_]
mdoc <- firstJustM mb_customDocs
case mdoc of
Nothing -> panic "cPprTerm"
Just doc -> return $ cparen (prec>app_prec+1) doc
firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
firstJustM [] = return Nothing
cPprTermBase :: forall m. 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)
ppr_list
, ifTerm (isTyCon intTyCon . ty) ppr_int
, ifTerm (isTyCon charTyCon . ty) ppr_char
, ifTerm (isTyCon floatTyCon . ty) ppr_float
, ifTerm (isTyCon doubleTyCon . ty) ppr_double
, ifTerm (isIntegerTy . ty) ppr_integer
]
where
ifTerm :: (Term -> Bool)
-> (Precedence -> Term -> m SDoc)
-> Precedence -> Term -> m (Maybe SDoc)
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)
ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
:: Precedence -> Term -> m SDoc
ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
ppr_list :: Precedence -> Term -> m SDoc
ppr_list p (Term{subTerms=[h,t]}) = do
let elems = h : getListTerms t
isConsLast = not (termType (last elems) `eqType` termType h)
is_string = all (isCharTy . ty) elems
print_elems <- mapM (y cons_prec) elems
if is_string
then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
else if isConsLast
then return $ cparen (p >= cons_prec)
$ pprDeeperList fsep
$ punctuate (space<>colon) print_elems
else return $ 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)
ppr_list _ _ = panic "doList"
repPrim :: TyCon -> [Word] -> SDoc
repPrim t = rep where
rep x
| t == charPrimTyCon = text $ show (chr (build x :: Int))
| t == intPrimTyCon = text $ show (build x :: Int)
| t == wordPrimTyCon = text $ show (build x :: Word)
| t == floatPrimTyCon = text $ show (build x :: Float)
| t == doublePrimTyCon = text $ show (build x :: Double)
| t == int32PrimTyCon = text $ show (build x :: Int32)
| t == word32PrimTyCon = text $ show (build x :: Word32)
| t == int64PrimTyCon = text $ show (build x :: Int64)
| t == word64PrimTyCon = text $ show (build x :: Word64)
| t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x)
| t == stablePtrPrimTyCon = text "<stablePtr>"
| t == stableNamePrimTyCon = text "<stableName>"
| t == statePrimTyCon = text "<statethread>"
| t == proxyPrimTyCon = text "<proxy>"
| t == realWorldTyCon = text "<realworld>"
| t == threadIdPrimTyCon = text "<ThreadId>"
| t == weakPrimTyCon = text "<Weak>"
| t == arrayPrimTyCon = text "<array>"
| t == smallArrayPrimTyCon = text "<smallArray>"
| t == byteArrayPrimTyCon = text "<bytearray>"
| t == mutableArrayPrimTyCon = text "<mutableArray>"
| t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
| t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
| t == mutVarPrimTyCon = text "<mutVar>"
| t == mVarPrimTyCon = text "<mVar>"
| t == tVarPrimTyCon = text "<tVar>"
| otherwise = 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 thing_inside
= do { (_errs, res) <- initTcInteractive hsc_env thing_inside
; return res }
traceTR :: SDoc -> TR ()
traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
recoverTR :: TR a -> TR a -> TR a
recoverTR = tryTcDiscardingErrs
trIO :: IO a -> TR a
trIO = liftTcM . liftIO
liftTcM :: TcM a -> TR a
liftTcM = id
newVar :: Kind -> TR TcType
newVar = liftTcM . newFlexiTyVarTy
newOpenVar :: TR TcType
newOpenVar = liftTcM newOpenFlexiTyVarTy
instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
instTyVars tvs
= liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
type RttiInstantiation = [(TcTyVar, TyVar)]
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme (tvs, ty)
= do { (subst, tvs') <- instTyVars tvs
; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
; return (substTy subst ty, rtti_inst) }
applyRevSubst :: RttiInstantiation -> TR ()
applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
where
do_pair (tc_tv, rtti_tv)
= do { tc_ty <- zonkTcTyVar tc_tv
; case tcGetTyVar_maybe tc_ty of
Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
_ -> return () }
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]) $
discardResult $
captureConstraints $
do { (ty1, ty2) <- congruenceNewtypes actual expected
; unifyType Nothing ty1 ty2 }
cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
sigma_old_ty = mkInvForAllTys old_tvs old_tau
traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
term <-
if null old_tvs
then do
term <- go max_depth sigma_old_ty sigma_old_ty hval
term' <- zonkTerm term
return $ fixFunDictionaries $ expandNewtypes term'
else do
(old_ty', rev_subst) <- instScheme quant_old_ty
my_ty <- newOpenVar
when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
addConstraint my_ty old_ty')
term <- go max_depth my_ty sigma_old_ty hval
new_ty <- zonkTcType (termType term)
if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
then do
traceTR (text "check2 passed")
addConstraint new_ty old_ty'
applyRevSubst rev_subst
zterm' <- zonkTerm term
return ((fixFunDictionaries . expandNewtypes) zterm')
else do
traceTR (text "check2 failed" <+> parens
(ppr term <+> text "::" <+> ppr new_ty))
zterm' <- mapTermTypeM
(\ty -> case tcSplitTyConApp_maybe ty of
Just (tc, _:_) | tc /= funTyCon
-> newOpenVar
_ -> return ty)
term
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 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 (info 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 clos of
t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
seq a (go (pred max_depth) my_ty old_ty a)
BlackholeClosure{indirectee=ind} -> do
traceTR (text "Following a BLACKHOLE")
(\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind
IndClosure{indirectee=ind} -> do
traceTR (text "Following an indirection" )
(\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind
MutVarClosure{}
| 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(isUnliftedType my_ty) return ()
(mutvar_ty,_) <- instScheme $ quantifyType $ 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)
ConstrClosure{ptrArgs=pArgs} -> do
traceTR (text "entering a constructor " <>
if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty)
else Ppr.empty)
Right dcname <- liftIO $ constrClosToName hsc_env clos
(_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing -> do
traceTR (text "Not constructor" <+> ppr dcname)
let dflags = hsc_dflags hsc_env
tag = showPpr dflags dcname
vars <- replicateM (length pArgs)
(newVar liftedTypeKind)
subTerms <- sequence $ zipWith (\(Box x) tv ->
go (pred max_depth) tv tv (HValue x)) pArgs vars
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
subTtypes <- getDataConArgTys dc my_ty
subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
return (Term my_ty (Right dc) a subTerms)
_ -> do
traceTR (text "Unknown closure:" <+> text (show clos))
return (Suspension (tipe (info clos)) my_ty a Nothing)
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
extractSubTerms :: (Type -> HValue -> TcM Term)
-> Closure -> [Type] -> TcM [Term]
extractSubTerms recurse clos = liftM thdOf3 . go 0 0
where
array = dataArgs clos
go ptr_i arr_i [] = return (ptr_i, arr_i, [])
go ptr_i arr_i (ty:tys)
| Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
, isUnboxedTupleTyCon tc
= do (ptr_i, arr_i, terms0) <-
go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
(ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
| otherwise
= case typePrimRepArgs ty of
[rep_ty] -> do
(ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty
(ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
return (ptr_i, arr_i, term0 : terms1)
rep_tys -> do
(ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
(ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
tv <- newVar liftedTypeKind
(ptr_i, arr_i, term0) <- go_rep ptr_i arr_i tv rep_ty
(ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
return (ptr_i, arr_i, term0 : terms1)
go_rep ptr_i arr_i ty rep
| isGcPtrRep rep = do
t <- (\(Box x) -> recurse ty (HValue x)) $ (ptrArgs clos)!!ptr_i
return (ptr_i + 1, arr_i, t)
| otherwise = do
dflags <- getDynFlags
let word_size = wORD_SIZE dflags
big_endian = wORDS_BIGENDIAN dflags
size_b = primRepSizeB dflags rep
!aligned_idx = roundUpTo arr_i (min word_size size_b)
!new_arr_i = aligned_idx + size_b
ws | size_b < word_size =
[index size_b aligned_idx word_size big_endian]
| otherwise =
let (q, r) = size_b `quotRem` word_size
in ASSERT( r == 0 )
[ array!!i
| o <- [0.. q 1]
, let i = (aligned_idx `quot` word_size) + o
]
return (ptr_i, new_arr_i, Prim ty ws)
unboxedTupleTerm ty terms
= Term ty (Right (tupleDataCon Unboxed (length terms)))
(error "unboxedTupleTerm: no HValue for unboxed tuple") terms
index item_size_b index_b word_size big_endian =
(word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
where
mask :: Word
mask = case item_size_b of
1 -> 0xFF
2 -> 0xFFFF
4 -> 0xFFFFFFFF
_ -> panic ("Weird byte-index: " ++ show index_b)
(q,r) = index_b `quotRem` word_size
word = array!!q
moveBytes = if big_endian
then word_size (r + item_size_b) * 8
else r * 8
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@(old_tvs, _) = quantifyType old_ty
new_ty <-
if null old_tvs
then return old_ty
else do
(old_ty', rev_subst) <- instScheme sigma_old_ty
my_ty <- newOpenVar
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 (quantifyType new_ty) sigma_old_ty
then do
traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
addConstraint my_ty old_ty'
applyRevSubst rev_subst
zonkRttiType 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
traceTR (text "go" <+> ppr my_ty)
clos <- trIO $ getClosureData a
case clos of
BlackholeClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind
IndClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind
MutVarClosure{} -> 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)]
ConstrClosure{ptrArgs=pArgs} -> do
Right dcname <- liftIO $ constrClosToName hsc_env clos
traceTR (text "Constr1" <+> ppr dcname)
(_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
forM pArgs $ \(Box x) -> do
tv <- newVar liftedTypeKind
return (tv, HValue x)
Just dc -> do
arg_tys <- getDataConArgTys dc my_ty
(_, itys) <- findPtrTyss 0 arg_tys
traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
return $ zipWith (\(_,ty) (Box x) -> (ty, HValue x)) itys pArgs
_ -> return []
findPtrTys :: Int
-> Type
-> TR (Int, [(Int, Type)])
findPtrTys i ty
| Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
, isUnboxedTupleTyCon tc
= findPtrTyss i elem_tys
| otherwise
= case typePrimRep ty of
[rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])
| otherwise -> return (i, [])
prim_reps ->
foldM (\(i, extras) prim_rep ->
if isGcPtrRep prim_rep
then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
else return (i, extras))
(i, []) prim_reps
findPtrTyss :: Int
-> [Type]
-> TR (Int, [(Int, Type)])
findPtrTyss i tys = foldM step (i, []) tys
where step (i, discovered) elem_ty = do
(i, extras) <- findPtrTys i elem_ty
return (i, discovered ++ extras)
improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty
getDataConArgTys :: DataCon -> Type -> TR [Type]
getDataConArgTys dc con_app_ty
= do { let rep_con_app_ty = unwrapType con_app_ty
; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
$$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
; let con_arg_tys = substTys subst (dataConRepArgTys dc)
; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst))
; return con_arg_tys }
where
univ_tvs = dataConUnivTyVars dc
ex_tvs = dataConExTyVars dc
check1 :: QuantifiedType -> Bool
check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
where
isHigherKind = not . null . fst . splitPiTys
check2 :: QuantifiedType -> QuantifiedType -> Bool
check2 (_, rtti_ty) (_, old_ty)
| Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
= case () of
_ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
-> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
_ | Just _ <- splitAppTy_maybe old_ty
-> isMonomorphicOnNonPhantomArgs rtti_ty
_ -> True
| otherwise = True
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
, isTcTyVar tv
, isMetaTyVar tv
= 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) <- instTyVars (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
rep_ty = unwrapType ty'
_ <- liftTcM (unifyType Nothing ty rep_ty)
return ty'
zonkTerm :: Term -> TcM Term
zonkTerm = foldTermM (TermFoldM
{ fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' ->
return (Term ty' dc v tt)
, fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty ->
return (Suspension ct ty v b)
, fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
return$ NewtypeWrap ty' dc t
, fRefWrapM = \ty t -> return RefWrap `ap`
zonkRttiType ty `ap` return t
, fPrimM = (return.) . Prim })
zonkRttiType :: TcType -> TcM Type
zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
where
zonk_unbound_meta tv
= ASSERT( isTcTyVar tv )
do { tv' <- skolemiseRuntimeUnk tv
; return (mkTyVarTy tv') }
dictsView :: Type -> Type
dictsView ty = ty
isMonomorphic :: RttiType -> Bool
isMonomorphic ty = noExistentials && noUniversals
where (tvs, _, ty') = tcSplitSigmaTy ty
noExistentials = noFreeVarsOfType ty'
noUniversals = null tvs
isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
isMonomorphicOnNonPhantomArgs ty
| Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType 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 _ = []
type QuantifiedType = ([TyVar], Type)
quantifyType :: Type -> QuantifiedType
quantifyType ty = ( filter isTyVar $
tyCoVarsOfTypeWellScoped rho
, rho)
where
(_tvs, rho) = tcSplitForAllTys ty