1 -----------------------------------------------------------------------------
3 -- GHC Interactive support for inspecting arbitrary closures at runtime
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
9 module RtClosureInspect(
10 cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
15 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
16 isFullyEvaluated, isFullyEvaluatedTerm,
17 termType, mapTermType, termTyVars,
18 foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
19 pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
23 Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection,
28 #include "HsVersions.h"
30 import ByteCodeItbls ( StgInfoTable )
31 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
37 import TypeRep -- I know I know, this is cheating
58 import Constants ( wORD_SIZE )
60 import GHC.Arr ( Array(..) )
62 import GHC.IOBase ( IO(IO) )
66 import Data.Array.Base
69 import qualified Data.Sequence as Seq
71 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
73 import System.IO.Unsafe
76 ---------------------------------------------
77 -- * A representation of semi evaluated Terms
78 ---------------------------------------------
80 data Term = Term { ty :: RttiType
81 , dc :: Either String DataCon
82 -- Carries a text representation if the datacon is
83 -- not exported by the .hi file, which is the case
84 -- for private constructors in -O0 compiled libraries
86 , subTerms :: [Term] }
88 | Prim { ty :: RttiType
91 | Suspension { ctype :: ClosureType
94 , bound_to :: Maybe Name -- Useful for printing
96 | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
97 -- newtype constructors. A NewtypeWrap is just a
98 -- made-up tag saying "heads up, there used to be
99 -- a newtype constructor here".
101 , dc :: Either String DataCon
102 , wrapped_term :: Term }
103 | RefWrap { -- The contents of a reference
105 , wrapped_term :: Term }
107 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
110 isSuspension Suspension{} = True
111 isSuspension _ = False
114 isNewtypeWrap NewtypeWrap{} = True
115 isNewtypeWrap _ = False
117 isFun Suspension{ctype=Fun} = True
120 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
123 termType :: Term -> RttiType
126 isFullyEvaluatedTerm :: Term -> Bool
127 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
128 isFullyEvaluatedTerm Prim {} = True
129 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
130 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
131 isFullyEvaluatedTerm _ = False
133 instance Outputable (Term) where
134 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
135 | otherwise = panic "Outputable Term instance"
137 -------------------------------------------------------------------------
138 -- Runtime Closure Datatype and functions for retrieving closure related stuff
139 -------------------------------------------------------------------------
140 data ClosureType = Constr
153 data Closure = Closure { tipe :: ClosureType
155 , infoTable :: StgInfoTable
156 , ptrs :: Array Int HValue
160 instance Outputable ClosureType where
163 #include "../includes/ClosureTypes.h"
165 aP_CODE, pAP_CODE :: Int
171 getClosureData :: a -> IO Closure
173 case unpackClosure# a of
174 (# iptr, ptrs, nptrs #) -> do
176 | ghciTablesNextToCode =
179 -- the info pointer we get back from unpackClosure#
180 -- is to the beginning of the standard info table,
181 -- but the Storable instance for info tables takes
182 -- into account the extra entry pointer when
183 -- !ghciTablesNextToCode, so we must adjust here:
184 Ptr iptr `plusPtr` negate wORD_SIZE
186 let tipe = readCType (BCI.tipe itbl)
187 elems = fromIntegral (BCI.ptrs itbl)
188 ptrsList = Array 0 (elems - 1) elems ptrs
189 nptrs_data = [W# (indexWordArray# nptrs i)
190 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
191 ASSERT(elems >= 0) return ()
193 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
195 readCType :: Integral a => a -> ClosureType
197 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
198 | i >= FUN && i <= FUN_STATIC = Fun
199 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
200 | i == THUNK_SELECTOR = ThunkSelector
201 | i == BLACKHOLE = Blackhole
202 | i >= IND && i <= IND_STATIC = Indirection i'
205 | i' == pAP_CODE = PAP
206 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
207 | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
208 | otherwise = Other i'
209 where i' = fromIntegral i
211 isConstr, isIndirection, isThunk :: ClosureType -> Bool
212 isConstr Constr = True
215 isIndirection (Indirection _) = True
216 isIndirection _ = False
218 isThunk (Thunk _) = True
219 isThunk ThunkSelector = True
223 isFullyEvaluated :: a -> IO Bool
224 isFullyEvaluated a = do
225 closure <- getClosureData a
227 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
228 return$ and are_subs_evaluated
230 where amapM f = sequence . amap' f
232 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
234 unsafeDeepSeq :: a -> b -> b
235 unsafeDeepSeq = unsafeDeepSeq1 2
236 where unsafeDeepSeq1 0 a b = seq a $! b
237 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
238 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
239 -- | unsafePerformIO (isFullyEvaluated a) = b
240 | otherwise = case unsafePerformIO (getClosureData a) of
241 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
242 where tipe = unsafePerformIO (getClosureType a)
245 -----------------------------------
246 -- * Traversals for Terms
247 -----------------------------------
248 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
250 data TermFold a = TermFold { fTerm :: TermProcessor a a
251 , fPrim :: RttiType -> [Word] -> a
252 , fSuspension :: ClosureType -> RttiType -> HValue
254 , fNewtypeWrap :: RttiType -> Either String DataCon
256 , fRefWrap :: RttiType -> a -> a
261 TermFoldM {fTermM :: TermProcessor a (m a)
262 , fPrimM :: RttiType -> [Word] -> m a
263 , fSuspensionM :: ClosureType -> RttiType -> HValue
265 , fNewtypeWrapM :: RttiType -> Either String DataCon
267 , fRefWrapM :: RttiType -> a -> m a
270 foldTerm :: TermFold a -> Term -> a
271 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
272 foldTerm tf (Prim ty v ) = fPrim tf ty v
273 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
274 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
275 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
278 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
279 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
280 foldTermM tf (Prim ty v ) = fPrimM tf ty v
281 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
282 foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
283 foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
285 idTermFold :: TermFold Term
286 idTermFold = TermFold {
289 fSuspension = Suspension,
290 fNewtypeWrap = NewtypeWrap,
294 mapTermType :: (RttiType -> Type) -> Term -> Term
295 mapTermType f = foldTerm idTermFold {
296 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
297 fSuspension = \ct ty hval n ->
298 Suspension ct (f ty) hval n,
299 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
300 fRefWrap = \ty t -> RefWrap (f ty) t}
302 mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
303 mapTermTypeM f = foldTermM TermFoldM {
304 fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
305 fPrimM = (return.) . Prim,
306 fSuspensionM = \ct ty hval n ->
307 f ty >>= \ty' -> return $ Suspension ct ty' hval n,
308 fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
309 fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
311 termTyVars :: Term -> TyVarSet
312 termTyVars = foldTerm TermFold {
313 fTerm = \ty _ _ tt ->
314 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
315 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
316 fPrim = \ _ _ -> emptyVarEnv,
317 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
318 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
319 where concatVarEnv = foldr plusVarEnv emptyVarEnv
321 ----------------------------------
322 -- Pretty printing of terms
323 ----------------------------------
325 type Precedence = Int
326 type TermPrinter = Precedence -> Term -> SDoc
327 type TermPrinterM m = Precedence -> Term -> m SDoc
329 app_prec,cons_prec, max_prec ::Int
332 cons_prec = 5 -- TODO Extract this info from GHC itself
334 pprTerm :: TermPrinter -> TermPrinter
335 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
336 pprTerm _ _ _ = panic "pprTerm"
338 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
339 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
341 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
342 tt_docs <- mapM (y app_prec) tt
343 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
345 ppr_termM y p Term{dc=Right dc, subTerms=tt}
346 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
347 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
348 <+> hsep (map (ppr_term1 True) tt)
349 -} -- TODO Printing infix constructors properly
350 | null tt = return$ ppr dc
352 tt_docs <- mapM (y app_prec) tt
353 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
355 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
356 ppr_termM y p RefWrap{wrapped_term=t} = do
357 contents <- y app_prec t
358 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
359 -- The constructor name is wired in here ^^^ for the sake of simplicity.
360 -- I don't think mutvars are going to change in a near future.
361 -- In any case this is solely a presentation matter: MutVar# is
362 -- a datatype with no constructors, implemented by the RTS
363 -- (hence there is no way to obtain a datacon and print it).
364 ppr_termM _ _ t = ppr_termM1 t
367 ppr_termM1 :: Monad m => Term -> m SDoc
368 ppr_termM1 Prim{value=words, ty=ty} =
369 return$ text$ repPrim (tyConAppTyCon ty) words
370 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
371 return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
372 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
373 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
374 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
375 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
376 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
377 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
379 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
380 | Just (tc,_) <- tcSplitTyConApp_maybe ty
381 , ASSERT(isNewTyCon tc) True
382 , Just new_dc <- tyConSingleDataCon_maybe tc = do
383 real_term <- y max_prec t
384 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
385 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
387 -------------------------------------------------------
388 -- Custom Term Pretty Printers
389 -------------------------------------------------------
391 -- We can want to customize the representation of a
392 -- term depending on its type.
393 -- However, note that custom printers have to work with
394 -- type representations, instead of directly with types.
395 -- We cannot use type classes here, unless we employ some
396 -- typerep trickery (e.g. Weirich's RepLib tricks),
397 -- which I didn't. Therefore, this code replicates a lot
398 -- of what type classes provide for free.
400 type CustomTermPrinter m = TermPrinterM m
401 -> [Precedence -> Term -> (m (Maybe SDoc))]
403 -- | Takes a list of custom printers with a explicit recursion knot and a term,
404 -- and returns the output of the first succesful printer, or the default printer
405 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
406 cPprTerm printers_ = go 0 where
407 printers = printers_ go
409 let default_ = Just `liftM` pprTermM go prec t
410 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
411 Just doc <- firstJustM mb_customDocs
412 return$ cparen (prec>app_prec+1) doc
414 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
415 firstJustM [] = return Nothing
417 -- Default set of custom printers. Note that the recursion knot is explicit
418 cPprTermBase :: Monad m => CustomTermPrinter m
420 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
423 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
424 (\ p Term{subTerms=[h,t]} -> doList p h t)
425 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
426 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
427 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
428 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
429 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
431 where ifTerm pred f prec t@Term{}
432 | pred t = Just `liftM` f prec t
433 ifTerm _ _ _ _ = return Nothing
435 isIntegerTy ty = fromMaybe False $ do
436 (tc,_) <- tcSplitTyConApp_maybe ty
437 return (tyConName tc == integerTyConName)
439 isTupleTy ty = fromMaybe False $ do
440 (tc,_) <- tcSplitTyConApp_maybe ty
441 return (isBoxedTupleTyCon tc)
443 isTyCon a_tc ty = fromMaybe False $ do
444 (tc,_) <- tcSplitTyConApp_maybe ty
447 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
449 --Note pprinting of list terms is not lazy
451 let elems = h : getListTerms t
452 isConsLast = not(termType(last elems) `coreEqType` termType h)
453 print_elems <- mapM (y cons_prec) elems
454 return$ if isConsLast
455 then cparen (p >= cons_prec)
457 . punctuate (space<>colon)
459 else brackets (pprDeeperList fcat$
460 punctuate comma print_elems)
462 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
463 getListTerms Term{subTerms=[]} = []
464 getListTerms t@Suspension{} = [t]
465 getListTerms t = pprPanic "getListTerms" (ppr t)
468 repPrim :: TyCon -> [Word] -> String
469 repPrim t = rep where
471 | t == charPrimTyCon = show (build x :: Char)
472 | t == intPrimTyCon = show (build x :: Int)
473 | t == wordPrimTyCon = show (build x :: Word)
474 | t == floatPrimTyCon = show (build x :: Float)
475 | t == doublePrimTyCon = show (build x :: Double)
476 | t == int32PrimTyCon = show (build x :: Int32)
477 | t == word32PrimTyCon = show (build x :: Word32)
478 | t == int64PrimTyCon = show (build x :: Int64)
479 | t == word64PrimTyCon = show (build x :: Word64)
480 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
481 | t == stablePtrPrimTyCon = "<stablePtr>"
482 | t == stableNamePrimTyCon = "<stableName>"
483 | t == statePrimTyCon = "<statethread>"
484 | t == realWorldTyCon = "<realworld>"
485 | t == threadIdPrimTyCon = "<ThreadId>"
486 | t == weakPrimTyCon = "<Weak>"
487 | t == arrayPrimTyCon = "<array>"
488 | t == byteArrayPrimTyCon = "<bytearray>"
489 | t == mutableArrayPrimTyCon = "<mutableArray>"
490 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
491 | t == mutVarPrimTyCon= "<mutVar>"
492 | t == mVarPrimTyCon = "<mVar>"
493 | t == tVarPrimTyCon = "<tVar>"
494 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
495 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
496 -- This ^^^ relies on the representation of Haskell heap values being
497 -- the same as in a C array.
499 -----------------------------------
500 -- Type Reconstruction
501 -----------------------------------
503 Type Reconstruction is type inference done on heap closures.
504 The algorithm walks the heap generating a set of equations, which
505 are solved with syntactic unification.
506 A type reconstruction equation looks like:
508 <datacon reptype> = <actual heap contents>
510 The full equation set is generated by traversing all the subterms, starting
513 The only difficult part is that newtypes are only found in the lhs of equations.
514 Right hand sides are missing them. We can either (a) drop them from the lhs, or
515 (b) reconstruct them in the rhs when possible.
517 The function congruenceNewtypes takes a shot at (b)
521 -- A (non-mutable) tau type containing
522 -- existentially quantified tyvars.
523 -- (since GHC type language currently does not support
524 -- existentials, we leave these variables unquantified)
527 -- An incomplete type as stored in GHCi:
528 -- no polymorphism: no quantifiers & all tyvars are skolem.
532 -- The Type Reconstruction monad
533 --------------------------------
536 runTR :: HscEnv -> TR a -> IO a
537 runTR hsc_env thing = do
538 mb_val <- runTR_maybe hsc_env thing
540 Nothing -> error "unable to :print the term"
543 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
544 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
546 traceTR :: SDoc -> TR ()
547 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
550 -- Semantically different to recoverM in TcRnMonad
551 -- recoverM retains the errors in the first action,
552 -- whereas recoverTc here does not
553 recoverTR :: TR a -> TR a -> TR a
554 recoverTR recover thing = do
555 (_,mb_res) <- tryTcErrs thing
558 Just res -> return res
561 trIO = liftTcM . liftIO
563 liftTcM :: TcM a -> TR a
566 newVar :: Kind -> TR TcType
567 newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
569 -- | Returns the instantiated type scheme ty', and the substitution sigma
570 -- such that sigma(ty') = ty
571 instScheme :: Type -> TR (TcType, TvSubst)
572 instScheme ty = liftTcM$ do
573 (tvs, _, _) <- tcInstType return ty
574 (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
575 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
577 -- Adds a constraint of the form t1 == t2
578 -- t1 is expected to come from walking the heap
579 -- t2 is expected to come from a datacon signature
580 -- Before unification, congruenceNewtypes needs to
582 addConstraint :: TcType -> TcType -> TR ()
583 addConstraint actual expected = do
584 traceTR $ fsep [text "add constraint:", ppr actual, equals, ppr expected]
585 recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
586 text "with", ppr expected])
587 (congruenceNewtypes actual expected >>=
588 uncurry boxyUnify >> return ())
589 -- TOMDO: what about the coercion?
590 -- we should consider family instances
593 -- Type & Term reconstruction
594 ------------------------------
595 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
596 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
597 -- we quantify existential tyvars as universal,
598 -- as this is needed to be able to manipulate
600 let sigma_old_ty = sigmaType old_ty
601 traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
603 if isMonomorphic sigma_old_ty
605 new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm
606 return $ fixFunDictionaries $ expandNewtypes new_ty
608 (old_ty', rev_subst) <- instScheme sigma_old_ty
609 my_ty <- newVar argTypeKind
610 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
611 addConstraint my_ty old_ty')
612 term <- go max_depth my_ty sigma_old_ty hval
613 zterm <- zonkTerm term
614 let new_ty = termType zterm
615 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
617 traceTR (text "check2 passed")
618 addConstraint (termType term) old_ty'
619 zterm' <- zonkTerm term
620 return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm')
622 traceTR (text "check2 failed" <+> parens
623 (ppr zterm <+> text "::" <+> ppr new_ty))
624 -- we have unsound types. Replace constructor types in
625 -- subterms with tyvars
626 zterm' <- mapTermTypeM
627 (\ty -> case tcSplitTyConApp_maybe ty of
628 Just (tc, _:_) | tc /= funTyCon
629 -> newVar argTypeKind
633 traceTR (text "Term reconstruction completed. Term obtained: " <> ppr term)
636 go :: Int -> Type -> Type -> HValue -> TcM Term
637 go max_depth _ _ _ | seq max_depth False = undefined
638 go 0 my_ty _old_ty a = do
639 clos <- trIO $ getClosureData a
640 return (Suspension (tipe clos) my_ty a Nothing)
641 go max_depth my_ty old_ty a = do
642 let monomorphic = not(isTyVarTy my_ty)
643 -- This ^^^ is a convention. The ancestor tests for
644 -- monomorphism and passes a type instead of a tv
645 clos <- trIO $ getClosureData a
647 -- Thunks we may want to force
648 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
649 -- force blackholes, because it would almost certainly result in deadlock,
650 -- and showing the '_' is more useful.
651 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
652 seq a (go (pred max_depth) my_ty old_ty a)
653 -- We always follow indirections
654 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
655 go max_depth my_ty old_ty $! (ptrs clos ! 0)
656 -- We also follow references
657 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
659 -- Deal with the MutVar# primitive
660 -- It does not have a constructor at all,
661 -- so we simulate the following one
662 -- MutVar# :: contents_ty -> MutVar# s contents_ty
663 traceTR (text "Following a MutVar")
664 contents_tv <- newVar liftedTypeKind
665 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
666 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
667 (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
668 contents_ty (mkTyConApp tycon [world,contents_ty])
669 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
670 x <- go (pred max_depth) contents_tv contents_ty contents
671 return (RefWrap my_ty x)
673 -- The interesting case
675 traceTR (text "entering a constructor")
676 Right dcname <- dataConInfoPtrToName (infoPtr clos)
677 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
679 Nothing -> do -- This can happen for private constructors compiled -O0
680 -- where the .hi descriptor does not export them
681 -- In such case, we return a best approximation:
682 -- ignore the unpointed args, and recover the pointeds
683 -- This preserves laziness, and should be safe.
684 let tag = showSDoc (ppr dcname)
685 vars <- replicateM (length$ elems$ ptrs clos)
686 (newVar (liftedTypeKind))
687 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
688 | (i, tv) <- zip [0..] vars]
689 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
691 let subTtypes = matchSubTypes dc old_ty
692 (subTtypesP, subTtypesNP) = partition (isLifted |.| isRefType) subTtypes
693 subTermTvs <- mapMif (not . isMonomorphic)
694 (\t -> newVar (typeKind t))
696 -- It is vital for newtype reconstruction that the unification step
697 -- is done right here, _before_ the subterms are RTTI reconstructed
698 when (not monomorphic) $ do
700 -- When we already have all the information, avoid solving
701 -- unnecessary constraints. Propagation of type information
702 -- to subterms is already being done via matching.
703 let myType = mkFunTys subTermTvs my_ty
704 (signatureType,_) <- instScheme (rttiView $ dataConUserType dc)
705 addConstraint myType signatureType
706 subTermsP <- sequence
707 [ appArr (go (pred max_depth) tv t) (ptrs clos) i
708 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
709 let unboxeds = extractUnboxed subTtypesNP clos
710 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
711 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
712 return (Term my_ty (Right dc) a subTerms)
713 -- The otherwise case: can be a Thunk,AP,PAP,etc.
715 return (Suspension tipe_clos my_ty a Nothing)
718 | ty' <- repType ty -- look through newtypes
719 , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
720 , dc `elem` tyConDataCons tc
721 -- It is necessary to check that dc is actually a constructor for tycon tc,
722 -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
723 -- has not removed it. In that case, we happily give up and don't match
724 = myDataConInstArgTys dc ty_args
725 | otherwise = dataConRepArgTys dc
727 -- put together pointed and nonpointed subterms in the
729 reOrderTerms _ _ [] = []
730 reOrderTerms pointed unpointed (ty:tys)
731 | isLifted ty || isRefType ty
732 = ASSERT2(not(null pointed)
733 , ptext (sLit "reOrderTerms") $$
734 (ppr pointed $$ ppr unpointed))
735 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
736 | otherwise = ASSERT2(not(null unpointed)
737 , ptext (sLit "Reorderterms") $$
738 (ppr pointed $$ ppr unpointed))
739 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
741 -- insert NewtypeWraps around newtypes
742 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
744 | Just (tc, args) <- tcSplitTyConApp_maybe ty
746 , wrapped_type <- newTyConInstRhs tc args
747 , Just dc' <- tyConSingleDataCon_maybe tc
748 , t' <- worker wrapped_type dc hval tt
749 = NewtypeWrap ty (Right dc') t'
750 | otherwise = Term ty dc hval tt
753 -- Avoid returning types where predicates have been expanded to dictionaries.
754 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
755 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
756 | otherwise = Suspension ct ty hval n
759 -- Fast, breadth-first Type reconstruction
760 ------------------------------------------
761 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
762 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
763 traceTR (text "RTTI started with initial type " <> ppr old_ty)
764 let sigma_old_ty = sigmaType old_ty
766 if isMonomorphic sigma_old_ty
769 (old_ty', rev_subst) <- instScheme sigma_old_ty
770 my_ty <- newVar argTypeKind
771 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
772 addConstraint my_ty old_ty')
773 search (isMonomorphic `fmap` zonkTcType my_ty)
775 (Seq.singleton (my_ty, hval))
777 new_ty <- zonkTcType my_ty
778 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
780 traceTR (text "check2 passed")
781 addConstraint my_ty old_ty'
782 new_ty' <- zonkTcType my_ty
783 return (substTy rev_subst new_ty')
784 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
786 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
789 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
790 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
791 int max_depth <> text " steps")
792 search stop expand l d =
795 x :< xx -> unlessM stop $ do
797 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
799 -- returns unification tasks,since we are going to want a breadth-first search
800 go :: Type -> HValue -> TR [(Type, HValue)]
802 clos <- trIO $ getClosureData a
804 Indirection _ -> go my_ty $! (ptrs clos ! 0)
806 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
807 tv' <- newVar liftedTypeKind
808 world <- newVar liftedTypeKind
809 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
810 return [(tv', contents)]
812 Right dcname <- dataConInfoPtrToName (infoPtr clos)
813 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
816 -- TODO: Check this case
817 forM [0..length (elems $ ptrs clos)] $ \i -> do
818 tv <- newVar liftedTypeKind
819 return$ appArr (\e->(tv,e)) (ptrs clos) i
822 subTtypes <- mapMif (not . isMonomorphic)
823 (\t -> newVar (typeKind t))
824 (dataConRepArgTys dc)
826 -- It is vital for newtype reconstruction that the unification step
827 -- is done right here, _before_ the subterms are RTTI reconstructed
828 let myType = mkFunTys subTtypes my_ty
829 (signatureType,_) <- instScheme(rttiView $ dataConUserType dc)
830 addConstraint myType signatureType
831 return $ [ appArr (\e->(t,e)) (ptrs clos) i
832 | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
835 -- Compute the difference between a base type and the type found by RTTI
836 -- improveType <base_type> <rtti_type>
837 -- The types can contain skolem type variables, which need to be treated as normal vars.
838 -- In particular, we want them to unify with things.
839 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
840 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
841 traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty]
842 (ty_tvs, _, _) <- tcInstType return ty
843 (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
844 (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
845 boxyUnify rtti_ty' ty'
846 tvs1_contents <- zonkTcTyVars ty_tvs'
847 let subst = (uncurry zipTopTvSubst . unzip)
848 [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
849 , getTyVar_maybe ty /= Just tv
850 --, not(isTyVarTy ty)
853 where ty = sigmaType _ty
855 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
856 myDataConInstArgTys dc args
857 | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
858 | otherwise = dataConRepArgTys dc
860 isRefType :: Type -> Bool
862 | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
864 where ty'= repType ty
866 isRefTyCon :: TyCon -> Bool
867 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
872 This is not formalized anywhere, so hold to your seats!
873 RTTI in the presence of newtypes can be a tricky and unsound business.
877 Suppose we are doing RTTI for a partially evaluated
878 closure t, the real type of which is t :: MkT Int, for
880 newtype MkT a = MkT [Maybe a]
882 The table below shows the results of RTTI and the improvement
883 calculated for different combinations of evaluatedness and :type t.
884 Regard the two first columns as input and the next two as output.
886 # | t | :type t | rtti(t) | improv. | result
887 ------------------------------------------------------------
888 1 | _ | t b | a | none | OK
889 2 | _ | MkT b | a | none | OK
890 3 | _ | t Int | a | none | OK
892 If t is not evaluated at *all*, we are safe.
894 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
895 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
896 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
898 If a is a minimal whnf, we run into trouble. Note that
899 row 5 above does newtype enrichment on the ty_rtty parameter.
901 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
904 8 | (Just _:_)| MkT b | MkT a | none | OK
905 9 | (Just _:_)| t Int | FAIL | none | OK
907 And if t is any more evaluated than whnf, we are still in trouble.
908 Because constraints are solved in top-down order, when we reach the
909 Maybe subterm what we got is already unsound. This explains why the
910 row 9 fails to complete.
912 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
913 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
915 We can undo the failure in row 9 by leaving out the constraint
916 coming from the type signature of t (i.e., the 2nd column).
917 Note that this type information is still used
918 to calculate the improvement. But we fail
919 when trying to calculate the improvement, as there is no unifier for
920 t Int = [Maybe a] or t Int = [Maybe Int].
923 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
925 # | t | :type t | rtti(t) | improvement | result
926 ---------------------------------------------------------------------
927 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
928 | | | | b = Maybe a |
932 Consider a function obtainType that takes a value and a type and produces
933 the Term representation and a substitution (the improvement).
934 Assume an auxiliar rtti' function which does the actual job if recovering
935 the type, but which may produce a false type.
939 rtti' :: a -> IO Type -- Does not use the static type information
941 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
942 obtainType v old_ty = do
944 if monomorphic rtti_ty || (check rtti_ty old_ty)
947 where check rtti_ty old_ty = check1 rtti_ty &&
948 check2 rtti_ty old_ty
950 check1 :: Type -> Bool
951 check2 :: Type -> Type -> Bool
953 Now, if rtti' returns a monomorphic type, we are safe.
954 If that is not the case, then we consider two conditions.
957 1. To prevent the class of unsoundness displayed by
958 rows 4 and 7 in the example: no higher kind tyvars
965 2. To prevent the class of unsoundness shown by row 6,
966 the rtti type should be structurally more
967 defined than the old type we are comparing it to.
968 check2 :: OldType -> NewTy pe -> Bool
971 check2 [a] (t Int) = False
972 check2 [a] (t a) = False -- By check1 we never reach this equation
973 check2 [Int] a = True
974 check2 [Int] (t Int) = True
975 check2 [Maybe a] (t Int) = False
976 check2 [Maybe Int] (t Int) = True
977 check2 (Maybe [a]) (m [Int]) = False
978 check2 (Maybe [Int]) (m [Int]) = True
982 check1 :: Type -> Bool
983 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
985 isHigherKind = not . null . fst . splitKindFunTys
987 check2 :: Type -> Type -> Bool
988 check2 sigma_rtti_ty sigma_old_ty
989 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
991 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
992 -> and$ zipWith check2 rttis olds
993 _ | Just _ <- splitAppTy_maybe old_ty
994 -> isMonomorphicOnNonPhantomArgs rtti_ty
997 where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
998 (_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty
1001 -- Dealing with newtypes
1002 --------------------------
1004 congruenceNewtypes does a parallel fold over two Type values,
1005 compensating for missing newtypes on both sides.
1006 This is necessary because newtypes are not present
1007 in runtime, but sometimes there is evidence available.
1008 Evidence can come from DataCon signatures or
1009 from compile-time type inference.
1010 What we are doing here is an approximation
1011 of unification modulo a set of equations derived
1012 from newtype definitions. These equations should be the
1013 same as the equality coercions generated for newtypes
1014 in System Fc. The idea is to perform a sort of rewriting,
1015 taking those equations as rules, before launching unification.
1017 The caller must ensure the following.
1018 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1019 The 2nd type (rhs) comes from a DataCon type signature.
1020 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1021 in both types, but in the rhs it is restricted to the result type.
1023 Note that it is very tricky to make this 'rewriting'
1024 work with the unification implemented by TcM, where
1025 substitutions are operationally inlined. The order in which
1026 constraints are unified is vital as we cannot modify
1027 anything that has been touched by a previous unification step.
1028 Therefore, congruenceNewtypes is sound only if the types
1029 recovered by the RTTI mechanism are unified Top-Down.
1031 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1032 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1035 -- TyVar lhs inductive case
1036 | Just tv <- getTyVar_maybe l
1037 = recoverTR (return r) $ do
1038 Indirect ty_v <- readMetaTyVar tv
1039 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1040 ppr tv, equals, ppr ty_v]
1042 -- FunTy inductive case
1043 | Just (l1,l2) <- splitFunTy_maybe l
1044 , Just (r1,r2) <- splitFunTy_maybe r
1045 = do r2' <- go l2 r2
1047 return (mkFunTy r1' r2')
1048 -- TyconApp Inductive case; this is the interesting bit.
1049 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1050 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1051 , tycon_l /= tycon_r
1054 | otherwise = return r
1056 where upgrade :: TyCon -> Type -> TR Type
1057 upgrade new_tycon ty
1058 | not (isNewTyCon new_tycon) = do
1059 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1060 ppr new_tycon <> text " for " <> ppr ty)
1063 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1064 text " in presence of newtype evidence " <> ppr new_tycon)
1065 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1066 let ty' = mkTyConApp new_tycon vars
1067 liftTcM (boxyUnify ty (repType ty'))
1068 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1072 zonkTerm :: Term -> TcM Term
1073 zonkTerm = foldTermM TermFoldM{
1074 fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' ->
1075 return (Term ty' dc v tt)
1076 ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1077 return (Suspension ct ty v b)
1078 ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1079 return$ NewtypeWrap ty' dc t
1080 ,fRefWrapM = \ty t ->
1081 return RefWrap `ap` zonkTcType ty `ap` return t
1082 ,fPrimM = (return.) . Prim
1085 --------------------------------------------------------------------------------
1086 -- representation types for thetas
1087 rttiView :: Type -> Type
1088 rttiView ty | Just ty' <- coreView ty = rttiView ty'
1090 | (tvs, theta, tau) <- tcSplitSigmaTy ty
1091 = mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau)
1093 -- Restore Class predicates out of a representation type
1094 dictsView :: Type -> Type
1095 -- dictsView ty = ty
1096 dictsView (FunTy (TyConApp tc_dict args) ty)
1097 | Just c <- tyConClass_maybe tc_dict
1098 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1100 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1101 , Just c <- tyConClass_maybe tc_dict
1102 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1106 -- Use only for RTTI types
1107 isMonomorphic :: RttiType -> Bool
1108 isMonomorphic ty = noExistentials && noUniversals
1109 where (tvs, _, ty') = tcSplitSigmaTy ty
1110 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1111 noUniversals = null tvs
1113 -- Use only for RTTI types
1114 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1115 isMonomorphicOnNonPhantomArgs ty
1116 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1117 , phantom_vars <- tyConPhantomTyVars tc
1118 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1119 , tyv `notElem` phantom_vars]
1120 = all isMonomorphicOnNonPhantomArgs concrete_args
1121 | Just (ty1, ty2) <- splitFunTy_maybe ty
1122 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1123 | otherwise = isMonomorphic ty
1125 tyConPhantomTyVars :: TyCon -> [TyVar]
1126 tyConPhantomTyVars tc
1128 , Just dcs <- tyConDataCons_maybe tc
1129 , dc_vars <- concatMap dataConUnivTyVars dcs
1130 = tyConTyVars tc \\ dc_vars
1131 tyConPhantomTyVars _ = []
1133 -- Is this defined elsewhere?
1134 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1135 sigmaType :: Type -> Type
1136 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1139 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1140 mapMif pred f xx = sequence $ mapMif_ pred f xx
1143 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1145 unlessM :: Monad m => m Bool -> m () -> m ()
1146 unlessM condM acc = condM >>= \c -> unless c acc
1149 -- Strict application of f at index i
1150 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1151 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1152 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1153 case indexArray# ptrs# i# of
1156 amap' :: (t -> b) -> Array Int t -> [b]
1157 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1158 where g (I# i#) = case indexArray# arr# i# of
1162 isLifted :: Type -> Bool
1163 isLifted = not . isUnLiftedType
1165 extractUnboxed :: [Type] -> Closure -> [[Word]]
1166 extractUnboxed tt clos = go tt (nonPtrs clos)
1168 | Just (tycon,_) <- tcSplitTyConApp_maybe t
1169 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1170 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1173 | (x, rest) <- splitAt (sizeofType t) xx
1176 sizeofTyCon :: TyCon -> Int -- in *words*
1177 sizeofTyCon = primRepSizeW . tyConPrimRep
1180 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1181 (f |.| g) x = f x || g x