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
59 import Constants ( wORD_SIZE )
61 import GHC.Arr ( Array(..) )
64 #if __GLASGOW_HASKELL__ >= 611
65 import GHC.IO ( IO(..) )
67 import GHC.IOBase ( IO(..) )
72 import Data.Array.Base
75 import qualified Data.Sequence as Seq
77 import Data.Sequence (viewl, ViewL(..))
79 -- import System.IO.Unsafe
81 ---------------------------------------------
82 -- * A representation of semi evaluated Terms
83 ---------------------------------------------
85 data Term = Term { ty :: RttiType
86 , dc :: Either String DataCon
87 -- Carries a text representation if the datacon is
88 -- not exported by the .hi file, which is the case
89 -- for private constructors in -O0 compiled libraries
91 , subTerms :: [Term] }
93 | Prim { ty :: RttiType
96 | Suspension { ctype :: ClosureType
99 , bound_to :: Maybe Name -- Useful for printing
101 | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
102 -- newtype constructors. A NewtypeWrap is just a
103 -- made-up tag saying "heads up, there used to be
104 -- a newtype constructor here".
106 , dc :: Either String DataCon
107 , wrapped_term :: Term }
108 | RefWrap { -- The contents of a reference
110 , wrapped_term :: Term }
112 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
115 isSuspension Suspension{} = True
116 isSuspension _ = False
119 isNewtypeWrap NewtypeWrap{} = True
120 isNewtypeWrap _ = False
122 isFun Suspension{ctype=Fun} = True
125 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
128 termType :: Term -> RttiType
131 isFullyEvaluatedTerm :: Term -> Bool
132 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
133 isFullyEvaluatedTerm Prim {} = True
134 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
135 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
136 isFullyEvaluatedTerm _ = False
138 instance Outputable (Term) where
139 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
140 | otherwise = panic "Outputable Term instance"
142 -------------------------------------------------------------------------
143 -- Runtime Closure Datatype and functions for retrieving closure related stuff
144 -------------------------------------------------------------------------
145 data ClosureType = Constr
158 data Closure = Closure { tipe :: ClosureType
160 , infoTable :: StgInfoTable
161 , ptrs :: Array Int HValue
165 instance Outputable ClosureType where
168 #include "../includes/rts/storage/ClosureTypes.h"
170 aP_CODE, pAP_CODE :: Int
176 getClosureData :: a -> IO Closure
178 case unpackClosure# a of
179 (# iptr, ptrs, nptrs #) -> do
181 | ghciTablesNextToCode =
184 -- the info pointer we get back from unpackClosure#
185 -- is to the beginning of the standard info table,
186 -- but the Storable instance for info tables takes
187 -- into account the extra entry pointer when
188 -- !ghciTablesNextToCode, so we must adjust here:
189 Ptr iptr `plusPtr` negate wORD_SIZE
191 let tipe = readCType (BCI.tipe itbl)
192 elems = fromIntegral (BCI.ptrs itbl)
193 ptrsList = Array 0 (elems - 1) elems ptrs
194 nptrs_data = [W# (indexWordArray# nptrs i)
195 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
196 ASSERT(elems >= 0) return ()
198 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
200 readCType :: Integral a => a -> ClosureType
202 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
203 | i >= FUN && i <= FUN_STATIC = Fun
204 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
205 | i == THUNK_SELECTOR = ThunkSelector
206 | i == BLACKHOLE = Blackhole
207 | i >= IND && i <= IND_STATIC = Indirection i'
210 | i' == pAP_CODE = PAP
211 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
212 | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
213 | otherwise = Other i'
214 where i' = fromIntegral i
216 isConstr, isIndirection, isThunk :: ClosureType -> Bool
217 isConstr Constr = True
220 isIndirection (Indirection _) = True
221 isIndirection _ = False
223 isThunk (Thunk _) = True
224 isThunk ThunkSelector = True
228 isFullyEvaluated :: a -> IO Bool
229 isFullyEvaluated a = do
230 closure <- getClosureData a
232 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
233 return$ and are_subs_evaluated
235 where amapM f = sequence . amap' f
237 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
239 unsafeDeepSeq :: a -> b -> b
240 unsafeDeepSeq = unsafeDeepSeq1 2
241 where unsafeDeepSeq1 0 a b = seq a $! b
242 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
243 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
244 -- | unsafePerformIO (isFullyEvaluated a) = b
245 | otherwise = case unsafePerformIO (getClosureData a) of
246 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
247 where tipe = unsafePerformIO (getClosureType a)
250 -----------------------------------
251 -- * Traversals for Terms
252 -----------------------------------
253 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
255 data TermFold a = TermFold { fTerm :: TermProcessor a a
256 , fPrim :: RttiType -> [Word] -> a
257 , fSuspension :: ClosureType -> RttiType -> HValue
259 , fNewtypeWrap :: RttiType -> Either String DataCon
261 , fRefWrap :: RttiType -> a -> a
266 TermFoldM {fTermM :: TermProcessor a (m a)
267 , fPrimM :: RttiType -> [Word] -> m a
268 , fSuspensionM :: ClosureType -> RttiType -> HValue
270 , fNewtypeWrapM :: RttiType -> Either String DataCon
272 , fRefWrapM :: RttiType -> a -> m a
275 foldTerm :: TermFold a -> Term -> a
276 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
277 foldTerm tf (Prim ty v ) = fPrim tf ty v
278 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
279 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
280 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
283 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
284 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
285 foldTermM tf (Prim ty v ) = fPrimM tf ty v
286 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
287 foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
288 foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
290 idTermFold :: TermFold Term
291 idTermFold = TermFold {
294 fSuspension = Suspension,
295 fNewtypeWrap = NewtypeWrap,
299 mapTermType :: (RttiType -> Type) -> Term -> Term
300 mapTermType f = foldTerm idTermFold {
301 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
302 fSuspension = \ct ty hval n ->
303 Suspension ct (f ty) hval n,
304 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
305 fRefWrap = \ty t -> RefWrap (f ty) t}
307 mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
308 mapTermTypeM f = foldTermM TermFoldM {
309 fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
310 fPrimM = (return.) . Prim,
311 fSuspensionM = \ct ty hval n ->
312 f ty >>= \ty' -> return $ Suspension ct ty' hval n,
313 fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
314 fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
316 termTyVars :: Term -> TyVarSet
317 termTyVars = foldTerm TermFold {
318 fTerm = \ty _ _ tt ->
319 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
320 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
321 fPrim = \ _ _ -> emptyVarEnv,
322 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
323 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
324 where concatVarEnv = foldr plusVarEnv emptyVarEnv
326 ----------------------------------
327 -- Pretty printing of terms
328 ----------------------------------
330 type Precedence = Int
331 type TermPrinter = Precedence -> Term -> SDoc
332 type TermPrinterM m = Precedence -> Term -> m SDoc
334 app_prec,cons_prec, max_prec ::Int
337 cons_prec = 5 -- TODO Extract this info from GHC itself
339 pprTerm :: TermPrinter -> TermPrinter
340 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
341 pprTerm _ _ _ = panic "pprTerm"
343 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
344 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
346 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
347 tt_docs <- mapM (y app_prec) tt
348 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
350 ppr_termM y p Term{dc=Right dc, subTerms=tt}
351 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
352 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
353 <+> hsep (map (ppr_term1 True) tt)
354 -} -- TODO Printing infix constructors properly
355 | null tt = return$ ppr dc
357 tt_docs <- mapM (y app_prec) tt
358 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
360 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
361 ppr_termM y p RefWrap{wrapped_term=t} = do
362 contents <- y app_prec t
363 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
364 -- The constructor name is wired in here ^^^ for the sake of simplicity.
365 -- I don't think mutvars are going to change in a near future.
366 -- In any case this is solely a presentation matter: MutVar# is
367 -- a datatype with no constructors, implemented by the RTS
368 -- (hence there is no way to obtain a datacon and print it).
369 ppr_termM _ _ t = ppr_termM1 t
372 ppr_termM1 :: Monad m => Term -> m SDoc
373 ppr_termM1 Prim{value=words, ty=ty} =
374 return$ text$ repPrim (tyConAppTyCon ty) words
375 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
376 return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
377 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
378 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
379 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
380 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
381 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
382 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
384 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
385 | Just (tc,_) <- tcSplitTyConApp_maybe ty
386 , ASSERT(isNewTyCon tc) True
387 , Just new_dc <- tyConSingleDataCon_maybe tc = do
388 real_term <- y max_prec t
389 return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
390 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
392 -------------------------------------------------------
393 -- Custom Term Pretty Printers
394 -------------------------------------------------------
396 -- We can want to customize the representation of a
397 -- term depending on its type.
398 -- However, note that custom printers have to work with
399 -- type representations, instead of directly with types.
400 -- We cannot use type classes here, unless we employ some
401 -- typerep trickery (e.g. Weirich's RepLib tricks),
402 -- which I didn't. Therefore, this code replicates a lot
403 -- of what type classes provide for free.
405 type CustomTermPrinter m = TermPrinterM m
406 -> [Precedence -> Term -> (m (Maybe SDoc))]
408 -- | Takes a list of custom printers with a explicit recursion knot and a term,
409 -- and returns the output of the first succesful printer, or the default printer
410 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
411 cPprTerm printers_ = go 0 where
412 printers = printers_ go
414 let default_ = Just `liftM` pprTermM go prec t
415 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
416 Just doc <- firstJustM mb_customDocs
417 return$ cparen (prec>app_prec+1) doc
419 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
420 firstJustM [] = return Nothing
422 -- Default set of custom printers. Note that the recursion knot is explicit
423 cPprTermBase :: Monad m => CustomTermPrinter m
425 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
428 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
429 (\ p Term{subTerms=[h,t]} -> doList p h t)
430 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
431 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
432 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
433 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
434 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
436 where ifTerm pred f prec t@Term{}
437 | pred t = Just `liftM` f prec t
438 ifTerm _ _ _ _ = return Nothing
440 isTupleTy ty = fromMaybe False $ do
441 (tc,_) <- tcSplitTyConApp_maybe ty
442 return (isBoxedTupleTyCon tc)
444 isTyCon a_tc ty = fromMaybe False $ do
445 (tc,_) <- tcSplitTyConApp_maybe ty
448 isIntegerTy ty = fromMaybe False $ do
449 (tc,_) <- tcSplitTyConApp_maybe ty
450 return (tyConName tc == integerTyConName)
452 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
454 --Note pprinting of list terms is not lazy
456 let elems = h : getListTerms t
457 isConsLast = not(termType(last elems) `coreEqType` termType h)
458 print_elems <- mapM (y cons_prec) elems
459 return$ if isConsLast
460 then cparen (p >= cons_prec)
462 . punctuate (space<>colon)
464 else brackets (pprDeeperList fcat$
465 punctuate comma print_elems)
467 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
468 getListTerms Term{subTerms=[]} = []
469 getListTerms t@Suspension{} = [t]
470 getListTerms t = pprPanic "getListTerms" (ppr t)
473 repPrim :: TyCon -> [Word] -> String
474 repPrim t = rep where
476 | t == charPrimTyCon = show (build x :: Char)
477 | t == intPrimTyCon = show (build x :: Int)
478 | t == wordPrimTyCon = show (build x :: Word)
479 | t == floatPrimTyCon = show (build x :: Float)
480 | t == doublePrimTyCon = show (build x :: Double)
481 | t == int32PrimTyCon = show (build x :: Int32)
482 | t == word32PrimTyCon = show (build x :: Word32)
483 | t == int64PrimTyCon = show (build x :: Int64)
484 | t == word64PrimTyCon = show (build x :: Word64)
485 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
486 | t == stablePtrPrimTyCon = "<stablePtr>"
487 | t == stableNamePrimTyCon = "<stableName>"
488 | t == statePrimTyCon = "<statethread>"
489 | t == realWorldTyCon = "<realworld>"
490 | t == threadIdPrimTyCon = "<ThreadId>"
491 | t == weakPrimTyCon = "<Weak>"
492 | t == arrayPrimTyCon = "<array>"
493 | t == byteArrayPrimTyCon = "<bytearray>"
494 | t == mutableArrayPrimTyCon = "<mutableArray>"
495 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
496 | t == mutVarPrimTyCon= "<mutVar>"
497 | t == mVarPrimTyCon = "<mVar>"
498 | t == tVarPrimTyCon = "<tVar>"
499 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
500 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
501 -- This ^^^ relies on the representation of Haskell heap values being
502 -- the same as in a C array.
504 -----------------------------------
505 -- Type Reconstruction
506 -----------------------------------
508 Type Reconstruction is type inference done on heap closures.
509 The algorithm walks the heap generating a set of equations, which
510 are solved with syntactic unification.
511 A type reconstruction equation looks like:
513 <datacon reptype> = <actual heap contents>
515 The full equation set is generated by traversing all the subterms, starting
518 The only difficult part is that newtypes are only found in the lhs of equations.
519 Right hand sides are missing them. We can either (a) drop them from the lhs, or
520 (b) reconstruct them in the rhs when possible.
522 The function congruenceNewtypes takes a shot at (b)
526 -- A (non-mutable) tau type containing
527 -- existentially quantified tyvars.
528 -- (since GHC type language currently does not support
529 -- existentials, we leave these variables unquantified)
532 -- An incomplete type as stored in GHCi:
533 -- no polymorphism: no quantifiers & all tyvars are skolem.
537 -- The Type Reconstruction monad
538 --------------------------------
541 runTR :: HscEnv -> TR a -> IO a
542 runTR hsc_env thing = do
543 mb_val <- runTR_maybe hsc_env thing
545 Nothing -> error "unable to :print the term"
548 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
549 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
551 traceTR :: SDoc -> TR ()
552 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
555 -- Semantically different to recoverM in TcRnMonad
556 -- recoverM retains the errors in the first action,
557 -- whereas recoverTc here does not
558 recoverTR :: TR a -> TR a -> TR a
559 recoverTR recover thing = do
560 (_,mb_res) <- tryTcErrs thing
563 Just res -> return res
566 trIO = liftTcM . liftIO
568 liftTcM :: TcM a -> TR a
571 newVar :: Kind -> TR TcType
572 newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
574 -- | Returns the instantiated type scheme ty', and the substitution sigma
575 -- such that sigma(ty') = ty
576 instScheme :: Type -> TR (TcType, TvSubst)
577 instScheme ty = liftTcM$ do
578 (tvs, _, _) <- tcInstType return ty
579 (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
580 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
582 -- Adds a constraint of the form t1 == t2
583 -- t1 is expected to come from walking the heap
584 -- t2 is expected to come from a datacon signature
585 -- Before unification, congruenceNewtypes needs to
587 addConstraint :: TcType -> TcType -> TR ()
588 addConstraint actual expected = do
589 traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
590 recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
591 text "with", ppr expected])
592 (congruenceNewtypes actual expected >>=
593 (getLIE . uncurry boxyUnify) >> return ())
594 -- TOMDO: what about the coercion?
595 -- we should consider family instances
598 -- Type & Term reconstruction
599 ------------------------------
600 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
601 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
602 -- we quantify existential tyvars as universal,
603 -- as this is needed to be able to manipulate
605 let sigma_old_ty = sigmaType old_ty
606 traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
608 if isMonomorphic sigma_old_ty
610 new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm
611 return $ fixFunDictionaries $ expandNewtypes new_ty
613 (old_ty', rev_subst) <- instScheme sigma_old_ty
614 my_ty <- newVar argTypeKind
615 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
616 addConstraint my_ty old_ty')
617 term <- go max_depth my_ty sigma_old_ty hval
618 zterm <- zonkTerm term
619 let new_ty = termType zterm
620 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
622 traceTR (text "check2 passed")
623 addConstraint (termType term) old_ty'
624 zterm' <- zonkTerm term
625 return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm')
627 traceTR (text "check2 failed" <+> parens
628 (ppr zterm <+> text "::" <+> ppr new_ty))
629 -- we have unsound types. Replace constructor types in
630 -- subterms with tyvars
631 zterm' <- mapTermTypeM
632 (\ty -> case tcSplitTyConApp_maybe ty of
633 Just (tc, _:_) | tc /= funTyCon
634 -> newVar argTypeKind
638 traceTR (text "Term reconstruction completed." $$
639 text "Term obtained: " <> ppr term $$
640 text "Type obtained: " <> ppr (termType term))
643 go :: Int -> Type -> Type -> HValue -> TcM Term
644 go max_depth _ _ _ | seq max_depth False = undefined
645 go 0 my_ty _old_ty a = do
646 traceTR (text "Gave up reconstructing a term after" <>
647 int max_depth <> text " steps")
648 clos <- trIO $ getClosureData a
649 return (Suspension (tipe clos) my_ty a Nothing)
650 go max_depth my_ty old_ty a = do
651 let monomorphic = not(isTyVarTy my_ty)
652 -- This ^^^ is a convention. The ancestor tests for
653 -- monomorphism and passes a type instead of a tv
654 clos <- trIO $ getClosureData a
656 -- Thunks we may want to force
657 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
658 seq a (go (pred max_depth) my_ty old_ty a)
659 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
660 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
661 -- showing '_' which is what we want.
662 Blackhole -> do traceTR (text "Following a BLACKHOLE")
663 appArr (go max_depth my_ty old_ty) (ptrs clos) 0
664 -- We always follow indirections
665 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
666 go max_depth my_ty old_ty $! (ptrs clos ! 0)
667 -- We also follow references
668 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
670 -- Deal with the MutVar# primitive
671 -- It does not have a constructor at all,
672 -- so we simulate the following one
673 -- MutVar# :: contents_ty -> MutVar# s contents_ty
674 traceTR (text "Following a MutVar")
675 contents_tv <- newVar liftedTypeKind
676 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
677 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
678 (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
679 contents_ty (mkTyConApp tycon [world,contents_ty])
680 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
681 x <- go (pred max_depth) contents_tv contents_ty contents
682 return (RefWrap my_ty x)
684 -- The interesting case
686 traceTR (text "entering a constructor " <>
688 then parens (text "already monomorphic: " <> ppr my_ty)
689 else Outputable.empty)
690 Right dcname <- dataConInfoPtrToName (infoPtr clos)
691 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
693 Nothing -> do -- This can happen for private constructors compiled -O0
694 -- where the .hi descriptor does not export them
695 -- In such case, we return a best approximation:
696 -- ignore the unpointed args, and recover the pointeds
697 -- This preserves laziness, and should be safe.
698 let tag = showSDoc (ppr dcname)
699 vars <- replicateM (length$ elems$ ptrs clos)
700 (newVar (liftedTypeKind))
701 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
702 | (i, tv) <- zip [0..] vars]
703 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
705 let subTtypes = matchSubTypes dc old_ty
706 subTermTvs <- mapMif (not . isMonomorphic)
707 (\t -> newVar (typeKind t))
709 let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
711 (zip subTtypes subTermTvs)
712 (subTtypesP, subTermTvsP ) = unzip subTermsP
713 (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
715 -- When we already have all the information, avoid solving
716 -- unnecessary constraints. Propagation of type information
717 -- to subterms is already being done via matching.
718 when (not monomorphic) $ do
719 let myType = mkFunTys subTermTvs my_ty
720 (signatureType,_) <- instScheme (mydataConType dc)
721 -- It is vital for newtype reconstruction that the unification step
722 -- is done right here, _before_ the subterms are RTTI reconstructed
723 addConstraint myType signatureType
724 subTermsP <- sequence
725 [ appArr (go (pred max_depth) tv t) (ptrs clos) i
726 | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
727 let unboxeds = extractUnboxed subTtypesNP clos
728 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
729 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
730 return (Term my_ty (Right dc) a subTerms)
731 -- The otherwise case: can be a Thunk,AP,PAP,etc.
733 return (Suspension tipe_clos my_ty a Nothing)
736 | ty' <- repType ty -- look through newtypes
737 , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
738 , dc `elem` tyConDataCons tc
739 -- It is necessary to check that dc is actually a constructor for tycon tc,
740 -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
741 -- has not removed it. In that case, we happily give up and don't match
742 = myDataConInstArgTys dc ty_args
743 | otherwise = dataConRepArgTys dc
745 -- put together pointed and nonpointed subterms in the
747 reOrderTerms _ _ [] = []
748 reOrderTerms pointed unpointed (ty:tys)
749 | isLifted ty || isRefType ty
750 = ASSERT2(not(null pointed)
751 , ptext (sLit "reOrderTerms") $$
752 (ppr pointed $$ ppr unpointed))
753 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
754 | otherwise = ASSERT2(not(null unpointed)
755 , ptext (sLit "reOrderTerms") $$
756 (ppr pointed $$ ppr unpointed))
757 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
759 -- insert NewtypeWraps around newtypes
760 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
762 | Just (tc, args) <- tcSplitTyConApp_maybe ty
764 , wrapped_type <- newTyConInstRhs tc args
765 , Just dc' <- tyConSingleDataCon_maybe tc
766 , t' <- worker wrapped_type dc hval tt
767 = NewtypeWrap ty (Right dc') t'
768 | otherwise = Term ty dc hval tt
771 -- Avoid returning types where predicates have been expanded to dictionaries.
772 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
773 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
774 | otherwise = Suspension ct ty hval n
777 -- Fast, breadth-first Type reconstruction
778 ------------------------------------------
779 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
780 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
781 traceTR (text "RTTI started with initial type " <> ppr old_ty)
782 let sigma_old_ty = sigmaType old_ty
784 if isMonomorphic sigma_old_ty
787 (old_ty', rev_subst) <- instScheme sigma_old_ty
788 my_ty <- newVar argTypeKind
789 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
790 addConstraint my_ty old_ty')
791 search (isMonomorphic `fmap` zonkTcType my_ty)
793 (Seq.singleton (my_ty, hval))
795 new_ty <- zonkTcType my_ty
796 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
798 traceTR (text "check2 passed")
799 addConstraint my_ty old_ty'
800 new_ty' <- zonkTcType my_ty
801 return (substTy rev_subst new_ty')
802 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
804 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
807 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
808 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
809 int max_depth <> text " steps")
810 search stop expand l d =
813 x :< xx -> unlessM stop $ do
815 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
817 -- returns unification tasks,since we are going to want a breadth-first search
818 go :: Type -> HValue -> TR [(Type, HValue)]
820 clos <- trIO $ getClosureData a
822 Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
823 Indirection _ -> go my_ty $! (ptrs clos ! 0)
825 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
826 tv' <- newVar liftedTypeKind
827 world <- newVar liftedTypeKind
828 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
829 return [(tv', contents)]
831 Right dcname <- dataConInfoPtrToName (infoPtr clos)
832 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
835 -- TODO: Check this case
836 forM [0..length (elems $ ptrs clos)] $ \i -> do
837 tv <- newVar liftedTypeKind
838 return$ appArr (\e->(tv,e)) (ptrs clos) i
841 subTtypes <- mapMif (not . isMonomorphic)
842 (\t -> newVar (typeKind t))
843 (dataConRepArgTys dc)
845 -- It is vital for newtype reconstruction that the unification step
846 -- is done right here, _before_ the subterms are RTTI reconstructed
847 let myType = mkFunTys subTtypes my_ty
848 (signatureType,_) <- instScheme(mydataConType dc)
849 addConstraint myType signatureType
850 return $ [ appArr (\e->(t,e)) (ptrs clos) i
851 | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
854 -- Compute the difference between a base type and the type found by RTTI
855 -- improveType <base_type> <rtti_type>
856 -- The types can contain skolem type variables, which need to be treated as normal vars.
857 -- In particular, we want them to unify with things.
858 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
859 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
860 traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
861 (ty_tvs, _, _) <- tcInstType return ty
862 (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
863 (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
864 _ <- getLIE(boxyUnify rtti_ty' ty')
865 tvs1_contents <- zonkTcTyVars ty_tvs'
866 let subst = (uncurry zipTopTvSubst . unzip)
867 [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
868 , getTyVar_maybe ty /= Just tv
869 --, not(isTyVarTy ty)
872 where ty = sigmaType _ty
874 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
875 myDataConInstArgTys dc args
876 | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
877 | otherwise = dataConRepArgTys dc
879 mydataConType :: DataCon -> Type
880 -- ^ Custom version of DataCon.dataConUserType where we
881 -- - remove the equality constraints
882 -- - use the representation types for arguments, including dictionaries
883 -- - keep the original result type
885 = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
888 where univ_tvs = dataConUnivTyVars dc
889 ex_tvs = dataConExTyVars dc
890 eq_spec = dataConEqSpec dc
892 PredTy p -> predTypeRep p
894 | a <- dataConRepArgTys dc]
895 res_ty = dataConOrigResTy dc
897 isRefType :: Type -> Bool
899 | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
901 where ty'= repType ty
903 isRefTyCon :: TyCon -> Bool
904 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
909 This is not formalized anywhere, so hold to your seats!
910 RTTI in the presence of newtypes can be a tricky and unsound business.
914 Suppose we are doing RTTI for a partially evaluated
915 closure t, the real type of which is t :: MkT Int, for
917 newtype MkT a = MkT [Maybe a]
919 The table below shows the results of RTTI and the improvement
920 calculated for different combinations of evaluatedness and :type t.
921 Regard the two first columns as input and the next two as output.
923 # | t | :type t | rtti(t) | improv. | result
924 ------------------------------------------------------------
925 1 | _ | t b | a | none | OK
926 2 | _ | MkT b | a | none | OK
927 3 | _ | t Int | a | none | OK
929 If t is not evaluated at *all*, we are safe.
931 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
932 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
933 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
935 If a is a minimal whnf, we run into trouble. Note that
936 row 5 above does newtype enrichment on the ty_rtty parameter.
938 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
941 8 | (Just _:_)| MkT b | MkT a | none | OK
942 9 | (Just _:_)| t Int | FAIL | none | OK
944 And if t is any more evaluated than whnf, we are still in trouble.
945 Because constraints are solved in top-down order, when we reach the
946 Maybe subterm what we got is already unsound. This explains why the
947 row 9 fails to complete.
949 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
950 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
952 We can undo the failure in row 9 by leaving out the constraint
953 coming from the type signature of t (i.e., the 2nd column).
954 Note that this type information is still used
955 to calculate the improvement. But we fail
956 when trying to calculate the improvement, as there is no unifier for
957 t Int = [Maybe a] or t Int = [Maybe Int].
960 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
962 # | t | :type t | rtti(t) | improvement | result
963 ---------------------------------------------------------------------
964 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
965 | | | | b = Maybe a |
969 Consider a function obtainType that takes a value and a type and produces
970 the Term representation and a substitution (the improvement).
971 Assume an auxiliar rtti' function which does the actual job if recovering
972 the type, but which may produce a false type.
976 rtti' :: a -> IO Type -- Does not use the static type information
978 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
979 obtainType v old_ty = do
981 if monomorphic rtti_ty || (check rtti_ty old_ty)
984 where check rtti_ty old_ty = check1 rtti_ty &&
985 check2 rtti_ty old_ty
987 check1 :: Type -> Bool
988 check2 :: Type -> Type -> Bool
990 Now, if rtti' returns a monomorphic type, we are safe.
991 If that is not the case, then we consider two conditions.
994 1. To prevent the class of unsoundness displayed by
995 rows 4 and 7 in the example: no higher kind tyvars
1002 2. To prevent the class of unsoundness shown by row 6,
1003 the rtti type should be structurally more
1004 defined than the old type we are comparing it to.
1005 check2 :: NewType -> OldType -> Bool
1008 check2 [a] (t Int) = False
1009 check2 [a] (t a) = False -- By check1 we never reach this equation
1010 check2 [Int] a = True
1011 check2 [Int] (t Int) = True
1012 check2 [Maybe a] (t Int) = False
1013 check2 [Maybe Int] (t Int) = True
1014 check2 (Maybe [a]) (m [Int]) = False
1015 check2 (Maybe [Int]) (m [Int]) = True
1019 check1 :: Type -> Bool
1020 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
1022 isHigherKind = not . null . fst . splitKindFunTys
1024 check2 :: Type -> Type -> Bool
1025 check2 sigma_rtti_ty sigma_old_ty
1026 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1028 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1029 -> and$ zipWith check2 rttis olds
1030 _ | Just _ <- splitAppTy_maybe old_ty
1031 -> isMonomorphicOnNonPhantomArgs rtti_ty
1034 where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
1035 (_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty
1038 -- Dealing with newtypes
1039 --------------------------
1041 congruenceNewtypes does a parallel fold over two Type values,
1042 compensating for missing newtypes on both sides.
1043 This is necessary because newtypes are not present
1044 in runtime, but sometimes there is evidence available.
1045 Evidence can come from DataCon signatures or
1046 from compile-time type inference.
1047 What we are doing here is an approximation
1048 of unification modulo a set of equations derived
1049 from newtype definitions. These equations should be the
1050 same as the equality coercions generated for newtypes
1051 in System Fc. The idea is to perform a sort of rewriting,
1052 taking those equations as rules, before launching unification.
1054 The caller must ensure the following.
1055 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1056 The 2nd type (rhs) comes from a DataCon type signature.
1057 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1058 in both types, but in the rhs it is restricted to the result type.
1060 Note that it is very tricky to make this 'rewriting'
1061 work with the unification implemented by TcM, where
1062 substitutions are operationally inlined. The order in which
1063 constraints are unified is vital as we cannot modify
1064 anything that has been touched by a previous unification step.
1065 Therefore, congruenceNewtypes is sound only if the types
1066 recovered by the RTTI mechanism are unified Top-Down.
1068 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1069 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1072 -- TyVar lhs inductive case
1073 | Just tv <- getTyVar_maybe l
1074 = recoverTR (return r) $ do
1075 Indirect ty_v <- readMetaTyVar tv
1076 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1077 ppr tv, equals, ppr ty_v]
1079 -- FunTy inductive case
1080 | Just (l1,l2) <- splitFunTy_maybe l
1081 , Just (r1,r2) <- splitFunTy_maybe r
1082 = do r2' <- go l2 r2
1084 return (mkFunTy r1' r2')
1085 -- TyconApp Inductive case; this is the interesting bit.
1086 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1087 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1088 , tycon_l /= tycon_r
1091 | otherwise = return r
1093 where upgrade :: TyCon -> Type -> TR Type
1094 upgrade new_tycon ty
1095 | not (isNewTyCon new_tycon) = do
1096 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1097 ppr new_tycon <> text " for " <> ppr ty)
1100 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1101 text " in presence of newtype evidence " <> ppr new_tycon)
1102 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1103 let ty' = mkTyConApp new_tycon vars
1104 _ <- liftTcM (boxyUnify ty (repType ty'))
1105 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1109 zonkTerm :: Term -> TcM Term
1110 zonkTerm = foldTermM TermFoldM{
1111 fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' ->
1112 return (Term ty' dc v tt)
1113 ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1114 return (Suspension ct ty v b)
1115 ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1116 return$ NewtypeWrap ty' dc t
1117 ,fRefWrapM = \ty t ->
1118 return RefWrap `ap` zonkTcType ty `ap` return t
1119 ,fPrimM = (return.) . Prim
1122 --------------------------------------------------------------------------------
1123 -- Restore Class predicates out of a representation type
1124 dictsView :: Type -> Type
1125 -- dictsView ty = ty
1126 dictsView (FunTy (TyConApp tc_dict args) ty)
1127 | Just c <- tyConClass_maybe tc_dict
1128 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1130 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1131 , Just c <- tyConClass_maybe tc_dict
1132 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1136 -- Use only for RTTI types
1137 isMonomorphic :: RttiType -> Bool
1138 isMonomorphic ty = noExistentials && noUniversals
1139 where (tvs, _, ty') = tcSplitSigmaTy ty
1140 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1141 noUniversals = null tvs
1143 -- Use only for RTTI types
1144 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1145 isMonomorphicOnNonPhantomArgs ty
1146 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1147 , phantom_vars <- tyConPhantomTyVars tc
1148 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1149 , tyv `notElem` phantom_vars]
1150 = all isMonomorphicOnNonPhantomArgs concrete_args
1151 | Just (ty1, ty2) <- splitFunTy_maybe ty
1152 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1153 | otherwise = isMonomorphic ty
1155 tyConPhantomTyVars :: TyCon -> [TyVar]
1156 tyConPhantomTyVars tc
1158 , Just dcs <- tyConDataCons_maybe tc
1159 , dc_vars <- concatMap dataConUnivTyVars dcs
1160 = tyConTyVars tc \\ dc_vars
1161 tyConPhantomTyVars _ = []
1163 -- Is this defined elsewhere?
1164 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1165 sigmaType :: Type -> Type
1166 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1169 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1170 mapMif pred f xx = sequence $ mapMif_ pred f xx
1173 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1175 unlessM :: Monad m => m Bool -> m () -> m ()
1176 unlessM condM acc = condM >>= \c -> unless c acc
1179 -- Strict application of f at index i
1180 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1181 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1182 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1183 case indexArray# ptrs# i# of
1186 amap' :: (t -> b) -> Array Int t -> [b]
1187 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1188 where g (I# i#) = case indexArray# arr# i# of
1192 isLifted :: Type -> Bool
1193 isLifted = not . isUnLiftedType
1195 extractUnboxed :: [Type] -> Closure -> [[Word]]
1196 extractUnboxed tt clos = go tt (nonPtrs clos)
1198 | Just (tycon,_) <- tcSplitTyConApp_maybe t
1199 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1200 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1203 | (x, rest) <- splitAt (sizeofType t) xx
1206 sizeofTyCon :: TyCon -> Int -- in *words*
1207 sizeofTyCon = primRepSizeW . tyConPrimRep
1210 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1211 (f |.| g) x = f x || g x