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 hiding (null, length, index, take, drop, splitAt, reverse)
79 import System.IO.Unsafe
82 ---------------------------------------------
83 -- * A representation of semi evaluated Terms
84 ---------------------------------------------
86 data Term = Term { ty :: RttiType
87 , dc :: Either String DataCon
88 -- Carries a text representation if the datacon is
89 -- not exported by the .hi file, which is the case
90 -- for private constructors in -O0 compiled libraries
92 , subTerms :: [Term] }
94 | Prim { ty :: RttiType
97 | Suspension { ctype :: ClosureType
100 , bound_to :: Maybe Name -- Useful for printing
102 | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
103 -- newtype constructors. A NewtypeWrap is just a
104 -- made-up tag saying "heads up, there used to be
105 -- a newtype constructor here".
107 , dc :: Either String DataCon
108 , wrapped_term :: Term }
109 | RefWrap { -- The contents of a reference
111 , wrapped_term :: Term }
113 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
116 isSuspension Suspension{} = True
117 isSuspension _ = False
120 isNewtypeWrap NewtypeWrap{} = True
121 isNewtypeWrap _ = False
123 isFun Suspension{ctype=Fun} = True
126 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
129 termType :: Term -> RttiType
132 isFullyEvaluatedTerm :: Term -> Bool
133 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
134 isFullyEvaluatedTerm Prim {} = True
135 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
136 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
137 isFullyEvaluatedTerm _ = False
139 instance Outputable (Term) where
140 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
141 | otherwise = panic "Outputable Term instance"
143 -------------------------------------------------------------------------
144 -- Runtime Closure Datatype and functions for retrieving closure related stuff
145 -------------------------------------------------------------------------
146 data ClosureType = Constr
159 data Closure = Closure { tipe :: ClosureType
161 , infoTable :: StgInfoTable
162 , ptrs :: Array Int HValue
166 instance Outputable ClosureType where
169 #include "../includes/ClosureTypes.h"
171 aP_CODE, pAP_CODE :: Int
177 getClosureData :: a -> IO Closure
179 case unpackClosure# a of
180 (# iptr, ptrs, nptrs #) -> do
182 | ghciTablesNextToCode =
185 -- the info pointer we get back from unpackClosure#
186 -- is to the beginning of the standard info table,
187 -- but the Storable instance for info tables takes
188 -- into account the extra entry pointer when
189 -- !ghciTablesNextToCode, so we must adjust here:
190 Ptr iptr `plusPtr` negate wORD_SIZE
192 let tipe = readCType (BCI.tipe itbl)
193 elems = fromIntegral (BCI.ptrs itbl)
194 ptrsList = Array 0 (elems - 1) elems ptrs
195 nptrs_data = [W# (indexWordArray# nptrs i)
196 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
197 ASSERT(elems >= 0) return ()
199 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
201 readCType :: Integral a => a -> ClosureType
203 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
204 | i >= FUN && i <= FUN_STATIC = Fun
205 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
206 | i == THUNK_SELECTOR = ThunkSelector
207 | i == BLACKHOLE = Blackhole
208 | i >= IND && i <= IND_STATIC = Indirection i'
211 | i' == pAP_CODE = PAP
212 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
213 | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
214 | otherwise = Other i'
215 where i' = fromIntegral i
217 isConstr, isIndirection, isThunk :: ClosureType -> Bool
218 isConstr Constr = True
221 isIndirection (Indirection _) = True
222 isIndirection _ = False
224 isThunk (Thunk _) = True
225 isThunk ThunkSelector = True
229 isFullyEvaluated :: a -> IO Bool
230 isFullyEvaluated a = do
231 closure <- getClosureData a
233 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
234 return$ and are_subs_evaluated
236 where amapM f = sequence . amap' f
238 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
240 unsafeDeepSeq :: a -> b -> b
241 unsafeDeepSeq = unsafeDeepSeq1 2
242 where unsafeDeepSeq1 0 a b = seq a $! b
243 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
244 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
245 -- | unsafePerformIO (isFullyEvaluated a) = b
246 | otherwise = case unsafePerformIO (getClosureData a) of
247 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
248 where tipe = unsafePerformIO (getClosureType a)
251 -----------------------------------
252 -- * Traversals for Terms
253 -----------------------------------
254 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
256 data TermFold a = TermFold { fTerm :: TermProcessor a a
257 , fPrim :: RttiType -> [Word] -> a
258 , fSuspension :: ClosureType -> RttiType -> HValue
260 , fNewtypeWrap :: RttiType -> Either String DataCon
262 , fRefWrap :: RttiType -> a -> a
267 TermFoldM {fTermM :: TermProcessor a (m a)
268 , fPrimM :: RttiType -> [Word] -> m a
269 , fSuspensionM :: ClosureType -> RttiType -> HValue
271 , fNewtypeWrapM :: RttiType -> Either String DataCon
273 , fRefWrapM :: RttiType -> a -> m a
276 foldTerm :: TermFold a -> Term -> a
277 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
278 foldTerm tf (Prim ty v ) = fPrim tf ty v
279 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
280 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
281 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
284 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
285 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
286 foldTermM tf (Prim ty v ) = fPrimM tf ty v
287 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
288 foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
289 foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
291 idTermFold :: TermFold Term
292 idTermFold = TermFold {
295 fSuspension = Suspension,
296 fNewtypeWrap = NewtypeWrap,
300 mapTermType :: (RttiType -> Type) -> Term -> Term
301 mapTermType f = foldTerm idTermFold {
302 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
303 fSuspension = \ct ty hval n ->
304 Suspension ct (f ty) hval n,
305 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
306 fRefWrap = \ty t -> RefWrap (f ty) t}
308 mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
309 mapTermTypeM f = foldTermM TermFoldM {
310 fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
311 fPrimM = (return.) . Prim,
312 fSuspensionM = \ct ty hval n ->
313 f ty >>= \ty' -> return $ Suspension ct ty' hval n,
314 fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
315 fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
317 termTyVars :: Term -> TyVarSet
318 termTyVars = foldTerm TermFold {
319 fTerm = \ty _ _ tt ->
320 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
321 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
322 fPrim = \ _ _ -> emptyVarEnv,
323 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
324 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
325 where concatVarEnv = foldr plusVarEnv emptyVarEnv
327 ----------------------------------
328 -- Pretty printing of terms
329 ----------------------------------
331 type Precedence = Int
332 type TermPrinter = Precedence -> Term -> SDoc
333 type TermPrinterM m = Precedence -> Term -> m SDoc
335 app_prec,cons_prec, max_prec ::Int
338 cons_prec = 5 -- TODO Extract this info from GHC itself
340 pprTerm :: TermPrinter -> TermPrinter
341 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
342 pprTerm _ _ _ = panic "pprTerm"
344 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
345 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
347 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
348 tt_docs <- mapM (y app_prec) tt
349 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
351 ppr_termM y p Term{dc=Right dc, subTerms=tt}
352 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
353 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
354 <+> hsep (map (ppr_term1 True) tt)
355 -} -- TODO Printing infix constructors properly
356 | null tt = return$ ppr dc
358 tt_docs <- mapM (y app_prec) tt
359 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
361 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
362 ppr_termM y p RefWrap{wrapped_term=t} = do
363 contents <- y app_prec t
364 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
365 -- The constructor name is wired in here ^^^ for the sake of simplicity.
366 -- I don't think mutvars are going to change in a near future.
367 -- In any case this is solely a presentation matter: MutVar# is
368 -- a datatype with no constructors, implemented by the RTS
369 -- (hence there is no way to obtain a datacon and print it).
370 ppr_termM _ _ t = ppr_termM1 t
373 ppr_termM1 :: Monad m => Term -> m SDoc
374 ppr_termM1 Prim{value=words, ty=ty} =
375 return$ text$ repPrim (tyConAppTyCon ty) words
376 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
377 return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
378 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
379 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
380 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
381 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
382 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
383 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
385 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
386 | Just (tc,_) <- tcSplitTyConApp_maybe ty
387 , ASSERT(isNewTyCon tc) True
388 , Just new_dc <- tyConSingleDataCon_maybe tc = do
389 if integerDataConName == dataConName new_dc
390 then return $ text $ show $ (unsafeCoerce# $ val t :: Integer)
391 else do real_term <- y max_prec t
392 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
393 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
395 -------------------------------------------------------
396 -- Custom Term Pretty Printers
397 -------------------------------------------------------
399 -- We can want to customize the representation of a
400 -- term depending on its type.
401 -- However, note that custom printers have to work with
402 -- type representations, instead of directly with types.
403 -- We cannot use type classes here, unless we employ some
404 -- typerep trickery (e.g. Weirich's RepLib tricks),
405 -- which I didn't. Therefore, this code replicates a lot
406 -- of what type classes provide for free.
408 type CustomTermPrinter m = TermPrinterM m
409 -> [Precedence -> Term -> (m (Maybe SDoc))]
411 -- | Takes a list of custom printers with a explicit recursion knot and a term,
412 -- and returns the output of the first succesful printer, or the default printer
413 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
414 cPprTerm printers_ = go 0 where
415 printers = printers_ go
417 let default_ = Just `liftM` pprTermM go prec t
418 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
419 Just doc <- firstJustM mb_customDocs
420 return$ cparen (prec>app_prec+1) doc
422 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
423 firstJustM [] = return Nothing
425 -- Default set of custom printers. Note that the recursion knot is explicit
426 cPprTermBase :: Monad m => CustomTermPrinter m
428 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
431 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
432 (\ p Term{subTerms=[h,t]} -> doList p h t)
433 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
434 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
435 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
436 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
438 where ifTerm pred f prec t@Term{}
439 | pred t = Just `liftM` f prec t
440 ifTerm _ _ _ _ = return Nothing
442 isTupleTy ty = fromMaybe False $ do
443 (tc,_) <- tcSplitTyConApp_maybe ty
444 return (isBoxedTupleTyCon tc)
446 isTyCon a_tc ty = fromMaybe False $ do
447 (tc,_) <- tcSplitTyConApp_maybe ty
450 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
452 --Note pprinting of list terms is not lazy
454 let elems = h : getListTerms t
455 isConsLast = not(termType(last elems) `coreEqType` termType h)
456 print_elems <- mapM (y cons_prec) elems
457 return$ if isConsLast
458 then cparen (p >= cons_prec)
460 . punctuate (space<>colon)
462 else brackets (pprDeeperList fcat$
463 punctuate comma print_elems)
465 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
466 getListTerms Term{subTerms=[]} = []
467 getListTerms t@Suspension{} = [t]
468 getListTerms t = pprPanic "getListTerms" (ppr t)
471 repPrim :: TyCon -> [Word] -> String
472 repPrim t = rep where
474 | t == charPrimTyCon = show (build x :: Char)
475 | t == intPrimTyCon = show (build x :: Int)
476 | t == wordPrimTyCon = show (build x :: Word)
477 | t == floatPrimTyCon = show (build x :: Float)
478 | t == doublePrimTyCon = show (build x :: Double)
479 | t == int32PrimTyCon = show (build x :: Int32)
480 | t == word32PrimTyCon = show (build x :: Word32)
481 | t == int64PrimTyCon = show (build x :: Int64)
482 | t == word64PrimTyCon = show (build x :: Word64)
483 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
484 | t == stablePtrPrimTyCon = "<stablePtr>"
485 | t == stableNamePrimTyCon = "<stableName>"
486 | t == statePrimTyCon = "<statethread>"
487 | t == realWorldTyCon = "<realworld>"
488 | t == threadIdPrimTyCon = "<ThreadId>"
489 | t == weakPrimTyCon = "<Weak>"
490 | t == arrayPrimTyCon = "<array>"
491 | t == byteArrayPrimTyCon = "<bytearray>"
492 | t == mutableArrayPrimTyCon = "<mutableArray>"
493 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
494 | t == mutVarPrimTyCon= "<mutVar>"
495 | t == mVarPrimTyCon = "<mVar>"
496 | t == tVarPrimTyCon = "<tVar>"
497 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
498 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
499 -- This ^^^ relies on the representation of Haskell heap values being
500 -- the same as in a C array.
502 -----------------------------------
503 -- Type Reconstruction
504 -----------------------------------
506 Type Reconstruction is type inference done on heap closures.
507 The algorithm walks the heap generating a set of equations, which
508 are solved with syntactic unification.
509 A type reconstruction equation looks like:
511 <datacon reptype> = <actual heap contents>
513 The full equation set is generated by traversing all the subterms, starting
516 The only difficult part is that newtypes are only found in the lhs of equations.
517 Right hand sides are missing them. We can either (a) drop them from the lhs, or
518 (b) reconstruct them in the rhs when possible.
520 The function congruenceNewtypes takes a shot at (b)
524 -- A (non-mutable) tau type containing
525 -- existentially quantified tyvars.
526 -- (since GHC type language currently does not support
527 -- existentials, we leave these variables unquantified)
530 -- An incomplete type as stored in GHCi:
531 -- no polymorphism: no quantifiers & all tyvars are skolem.
535 -- The Type Reconstruction monad
536 --------------------------------
539 runTR :: HscEnv -> TR a -> IO a
540 runTR hsc_env thing = do
541 mb_val <- runTR_maybe hsc_env thing
543 Nothing -> error "unable to :print the term"
546 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
547 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
549 traceTR :: SDoc -> TR ()
550 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
553 -- Semantically different to recoverM in TcRnMonad
554 -- recoverM retains the errors in the first action,
555 -- whereas recoverTc here does not
556 recoverTR :: TR a -> TR a -> TR a
557 recoverTR recover thing = do
558 (_,mb_res) <- tryTcErrs thing
561 Just res -> return res
564 trIO = liftTcM . liftIO
566 liftTcM :: TcM a -> TR a
569 newVar :: Kind -> TR TcType
570 newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
572 -- | Returns the instantiated type scheme ty', and the substitution sigma
573 -- such that sigma(ty') = ty
574 instScheme :: Type -> TR (TcType, TvSubst)
575 instScheme ty = liftTcM$ do
576 (tvs, _, _) <- tcInstType return ty
577 (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
578 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
580 -- Adds a constraint of the form t1 == t2
581 -- t1 is expected to come from walking the heap
582 -- t2 is expected to come from a datacon signature
583 -- Before unification, congruenceNewtypes needs to
585 addConstraint :: TcType -> TcType -> TR ()
586 addConstraint actual expected = do
587 traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
588 recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
589 text "with", ppr expected])
590 (congruenceNewtypes actual expected >>=
591 (getLIE . uncurry boxyUnify) >> return ())
592 -- TOMDO: what about the coercion?
593 -- we should consider family instances
596 -- Type & Term reconstruction
597 ------------------------------
598 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
599 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
600 -- we quantify existential tyvars as universal,
601 -- as this is needed to be able to manipulate
603 let sigma_old_ty = sigmaType old_ty
604 traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
606 if isMonomorphic sigma_old_ty
608 new_ty <- go max_depth sigma_old_ty sigma_old_ty hval >>= zonkTerm
609 return $ fixFunDictionaries $ expandNewtypes new_ty
611 (old_ty', rev_subst) <- instScheme sigma_old_ty
612 my_ty <- newVar argTypeKind
613 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
614 addConstraint my_ty old_ty')
615 term <- go max_depth my_ty sigma_old_ty hval
616 zterm <- zonkTerm term
617 let new_ty = termType zterm
618 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
620 traceTR (text "check2 passed")
621 addConstraint (termType term) old_ty'
622 zterm' <- zonkTerm term
623 return ((fixFunDictionaries . expandNewtypes . mapTermType (substTy rev_subst)) zterm')
625 traceTR (text "check2 failed" <+> parens
626 (ppr zterm <+> text "::" <+> ppr new_ty))
627 -- we have unsound types. Replace constructor types in
628 -- subterms with tyvars
629 zterm' <- mapTermTypeM
630 (\ty -> case tcSplitTyConApp_maybe ty of
631 Just (tc, _:_) | tc /= funTyCon
632 -> newVar argTypeKind
636 traceTR (text "Term reconstruction completed." $$
637 text "Term obtained: " <> ppr term $$
638 text "Type obtained: " <> ppr (termType term))
641 go :: Int -> Type -> Type -> HValue -> TcM Term
642 go max_depth _ _ _ | seq max_depth False = undefined
643 go 0 my_ty _old_ty a = do
644 traceTR (text "Gave up reconstructing a term after" <>
645 int max_depth <> text " steps")
646 clos <- trIO $ getClosureData a
647 return (Suspension (tipe clos) my_ty a Nothing)
648 go max_depth my_ty old_ty a = do
649 let monomorphic = not(isTyVarTy my_ty)
650 -- This ^^^ is a convention. The ancestor tests for
651 -- monomorphism and passes a type instead of a tv
652 clos <- trIO $ getClosureData a
654 -- Thunks we may want to force
655 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
656 -- force blackholes, because it would almost certainly result in deadlock,
657 -- and showing the '_' is more useful.
658 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
659 seq a (go (pred max_depth) my_ty old_ty a)
660 -- We always follow indirections
661 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
662 go max_depth my_ty old_ty $! (ptrs clos ! 0)
663 -- We also follow references
664 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
666 -- Deal with the MutVar# primitive
667 -- It does not have a constructor at all,
668 -- so we simulate the following one
669 -- MutVar# :: contents_ty -> MutVar# s contents_ty
670 traceTR (text "Following a MutVar")
671 contents_tv <- newVar liftedTypeKind
672 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
673 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
674 (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
675 contents_ty (mkTyConApp tycon [world,contents_ty])
676 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
677 x <- go (pred max_depth) contents_tv contents_ty contents
678 return (RefWrap my_ty x)
680 -- The interesting case
682 traceTR (text "entering a constructor " <>
684 then parens (text "already monomorphic: " <> ppr my_ty)
685 else Outputable.empty)
686 Right dcname <- dataConInfoPtrToName (infoPtr clos)
687 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
689 Nothing -> do -- This can happen for private constructors compiled -O0
690 -- where the .hi descriptor does not export them
691 -- In such case, we return a best approximation:
692 -- ignore the unpointed args, and recover the pointeds
693 -- This preserves laziness, and should be safe.
694 let tag = showSDoc (ppr dcname)
695 vars <- replicateM (length$ elems$ ptrs clos)
696 (newVar (liftedTypeKind))
697 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
698 | (i, tv) <- zip [0..] vars]
699 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
701 let subTtypes = matchSubTypes dc old_ty
702 subTermTvs <- mapMif (not . isMonomorphic)
703 (\t -> newVar (typeKind t))
705 let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
707 (zip subTtypes subTermTvs)
708 (subTtypesP, subTermTvsP ) = unzip subTermsP
709 (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
711 -- When we already have all the information, avoid solving
712 -- unnecessary constraints. Propagation of type information
713 -- to subterms is already being done via matching.
714 when (not monomorphic) $ do
715 let myType = mkFunTys subTermTvs my_ty
716 (signatureType,_) <- instScheme (mydataConType dc)
717 -- It is vital for newtype reconstruction that the unification step
718 -- is done right here, _before_ the subterms are RTTI reconstructed
719 addConstraint myType signatureType
720 subTermsP <- sequence
721 [ appArr (go (pred max_depth) tv t) (ptrs clos) i
722 | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
723 let unboxeds = extractUnboxed subTtypesNP clos
724 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
725 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
726 return (Term my_ty (Right dc) a subTerms)
727 -- The otherwise case: can be a Thunk,AP,PAP,etc.
729 return (Suspension tipe_clos my_ty a Nothing)
732 | ty' <- repType ty -- look through newtypes
733 , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
734 , dc `elem` tyConDataCons tc
735 -- It is necessary to check that dc is actually a constructor for tycon tc,
736 -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
737 -- has not removed it. In that case, we happily give up and don't match
738 = myDataConInstArgTys dc ty_args
739 | otherwise = dataConRepArgTys dc
741 -- put together pointed and nonpointed subterms in the
743 reOrderTerms _ _ [] = []
744 reOrderTerms pointed unpointed (ty:tys)
745 | isLifted ty || isRefType ty
746 = ASSERT2(not(null pointed)
747 , ptext (sLit "reOrderTerms") $$
748 (ppr pointed $$ ppr unpointed))
749 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
750 | otherwise = ASSERT2(not(null unpointed)
751 , ptext (sLit "reOrderTerms") $$
752 (ppr pointed $$ ppr unpointed))
753 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
755 -- insert NewtypeWraps around newtypes
756 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
758 | Just (tc, args) <- tcSplitTyConApp_maybe ty
760 , wrapped_type <- newTyConInstRhs tc args
761 , Just dc' <- tyConSingleDataCon_maybe tc
762 , t' <- worker wrapped_type dc hval tt
763 = NewtypeWrap ty (Right dc') t'
764 | otherwise = Term ty dc hval tt
767 -- Avoid returning types where predicates have been expanded to dictionaries.
768 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
769 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
770 | otherwise = Suspension ct ty hval n
773 -- Fast, breadth-first Type reconstruction
774 ------------------------------------------
775 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
776 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
777 traceTR (text "RTTI started with initial type " <> ppr old_ty)
778 let sigma_old_ty = sigmaType old_ty
780 if isMonomorphic sigma_old_ty
783 (old_ty', rev_subst) <- instScheme sigma_old_ty
784 my_ty <- newVar argTypeKind
785 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
786 addConstraint my_ty old_ty')
787 search (isMonomorphic `fmap` zonkTcType my_ty)
789 (Seq.singleton (my_ty, hval))
791 new_ty <- zonkTcType my_ty
792 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
794 traceTR (text "check2 passed")
795 addConstraint my_ty old_ty'
796 new_ty' <- zonkTcType my_ty
797 return (substTy rev_subst new_ty')
798 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
800 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
803 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
804 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
805 int max_depth <> text " steps")
806 search stop expand l d =
809 x :< xx -> unlessM stop $ do
811 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
813 -- returns unification tasks,since we are going to want a breadth-first search
814 go :: Type -> HValue -> TR [(Type, HValue)]
816 clos <- trIO $ getClosureData a
818 Indirection _ -> go my_ty $! (ptrs clos ! 0)
820 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
821 tv' <- newVar liftedTypeKind
822 world <- newVar liftedTypeKind
823 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
824 return [(tv', contents)]
826 Right dcname <- dataConInfoPtrToName (infoPtr clos)
827 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
830 -- TODO: Check this case
831 forM [0..length (elems $ ptrs clos)] $ \i -> do
832 tv <- newVar liftedTypeKind
833 return$ appArr (\e->(tv,e)) (ptrs clos) i
836 subTtypes <- mapMif (not . isMonomorphic)
837 (\t -> newVar (typeKind t))
838 (dataConRepArgTys dc)
840 -- It is vital for newtype reconstruction that the unification step
841 -- is done right here, _before_ the subterms are RTTI reconstructed
842 let myType = mkFunTys subTtypes my_ty
843 (signatureType,_) <- instScheme(mydataConType dc)
844 addConstraint myType signatureType
845 return $ [ appArr (\e->(t,e)) (ptrs clos) i
846 | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
849 -- Compute the difference between a base type and the type found by RTTI
850 -- improveType <base_type> <rtti_type>
851 -- The types can contain skolem type variables, which need to be treated as normal vars.
852 -- In particular, we want them to unify with things.
853 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
854 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
855 traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
856 (ty_tvs, _, _) <- tcInstType return ty
857 (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
858 (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
859 getLIE(boxyUnify rtti_ty' ty')
860 tvs1_contents <- zonkTcTyVars ty_tvs'
861 let subst = (uncurry zipTopTvSubst . unzip)
862 [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
863 , getTyVar_maybe ty /= Just tv
864 --, not(isTyVarTy ty)
867 where ty = sigmaType _ty
869 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
870 myDataConInstArgTys dc args
871 | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
872 | otherwise = dataConRepArgTys dc
874 mydataConType :: DataCon -> Type
875 -- ^ Custom version of DataCon.dataConUserType where we
876 -- - remove the equality constraints
877 -- - use the representation types for arguments, including dictionaries
878 -- - keep the original result type
880 = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
883 where univ_tvs = dataConUnivTyVars dc
884 ex_tvs = dataConExTyVars dc
885 eq_spec = dataConEqSpec dc
887 PredTy p -> predTypeRep p
889 | a <- dataConRepArgTys dc]
890 res_ty = dataConOrigResTy dc
892 isRefType :: Type -> Bool
894 | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
896 where ty'= repType ty
898 isRefTyCon :: TyCon -> Bool
899 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
904 This is not formalized anywhere, so hold to your seats!
905 RTTI in the presence of newtypes can be a tricky and unsound business.
909 Suppose we are doing RTTI for a partially evaluated
910 closure t, the real type of which is t :: MkT Int, for
912 newtype MkT a = MkT [Maybe a]
914 The table below shows the results of RTTI and the improvement
915 calculated for different combinations of evaluatedness and :type t.
916 Regard the two first columns as input and the next two as output.
918 # | t | :type t | rtti(t) | improv. | result
919 ------------------------------------------------------------
920 1 | _ | t b | a | none | OK
921 2 | _ | MkT b | a | none | OK
922 3 | _ | t Int | a | none | OK
924 If t is not evaluated at *all*, we are safe.
926 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
927 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
928 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
930 If a is a minimal whnf, we run into trouble. Note that
931 row 5 above does newtype enrichment on the ty_rtty parameter.
933 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
936 8 | (Just _:_)| MkT b | MkT a | none | OK
937 9 | (Just _:_)| t Int | FAIL | none | OK
939 And if t is any more evaluated than whnf, we are still in trouble.
940 Because constraints are solved in top-down order, when we reach the
941 Maybe subterm what we got is already unsound. This explains why the
942 row 9 fails to complete.
944 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
945 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
947 We can undo the failure in row 9 by leaving out the constraint
948 coming from the type signature of t (i.e., the 2nd column).
949 Note that this type information is still used
950 to calculate the improvement. But we fail
951 when trying to calculate the improvement, as there is no unifier for
952 t Int = [Maybe a] or t Int = [Maybe Int].
955 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
957 # | t | :type t | rtti(t) | improvement | result
958 ---------------------------------------------------------------------
959 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
960 | | | | b = Maybe a |
964 Consider a function obtainType that takes a value and a type and produces
965 the Term representation and a substitution (the improvement).
966 Assume an auxiliar rtti' function which does the actual job if recovering
967 the type, but which may produce a false type.
971 rtti' :: a -> IO Type -- Does not use the static type information
973 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
974 obtainType v old_ty = do
976 if monomorphic rtti_ty || (check rtti_ty old_ty)
979 where check rtti_ty old_ty = check1 rtti_ty &&
980 check2 rtti_ty old_ty
982 check1 :: Type -> Bool
983 check2 :: Type -> Type -> Bool
985 Now, if rtti' returns a monomorphic type, we are safe.
986 If that is not the case, then we consider two conditions.
989 1. To prevent the class of unsoundness displayed by
990 rows 4 and 7 in the example: no higher kind tyvars
997 2. To prevent the class of unsoundness shown by row 6,
998 the rtti type should be structurally more
999 defined than the old type we are comparing it to.
1000 check2 :: NewType -> OldType -> Bool
1003 check2 [a] (t Int) = False
1004 check2 [a] (t a) = False -- By check1 we never reach this equation
1005 check2 [Int] a = True
1006 check2 [Int] (t Int) = True
1007 check2 [Maybe a] (t Int) = False
1008 check2 [Maybe Int] (t Int) = True
1009 check2 (Maybe [a]) (m [Int]) = False
1010 check2 (Maybe [Int]) (m [Int]) = True
1014 check1 :: Type -> Bool
1015 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
1017 isHigherKind = not . null . fst . splitKindFunTys
1019 check2 :: Type -> Type -> Bool
1020 check2 sigma_rtti_ty sigma_old_ty
1021 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1023 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1024 -> and$ zipWith check2 rttis olds
1025 _ | Just _ <- splitAppTy_maybe old_ty
1026 -> isMonomorphicOnNonPhantomArgs rtti_ty
1029 where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
1030 (_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty
1033 -- Dealing with newtypes
1034 --------------------------
1036 congruenceNewtypes does a parallel fold over two Type values,
1037 compensating for missing newtypes on both sides.
1038 This is necessary because newtypes are not present
1039 in runtime, but sometimes there is evidence available.
1040 Evidence can come from DataCon signatures or
1041 from compile-time type inference.
1042 What we are doing here is an approximation
1043 of unification modulo a set of equations derived
1044 from newtype definitions. These equations should be the
1045 same as the equality coercions generated for newtypes
1046 in System Fc. The idea is to perform a sort of rewriting,
1047 taking those equations as rules, before launching unification.
1049 The caller must ensure the following.
1050 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1051 The 2nd type (rhs) comes from a DataCon type signature.
1052 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1053 in both types, but in the rhs it is restricted to the result type.
1055 Note that it is very tricky to make this 'rewriting'
1056 work with the unification implemented by TcM, where
1057 substitutions are operationally inlined. The order in which
1058 constraints are unified is vital as we cannot modify
1059 anything that has been touched by a previous unification step.
1060 Therefore, congruenceNewtypes is sound only if the types
1061 recovered by the RTTI mechanism are unified Top-Down.
1063 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1064 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1067 -- TyVar lhs inductive case
1068 | Just tv <- getTyVar_maybe l
1069 = recoverTR (return r) $ do
1070 Indirect ty_v <- readMetaTyVar tv
1071 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1072 ppr tv, equals, ppr ty_v]
1074 -- FunTy inductive case
1075 | Just (l1,l2) <- splitFunTy_maybe l
1076 , Just (r1,r2) <- splitFunTy_maybe r
1077 = do r2' <- go l2 r2
1079 return (mkFunTy r1' r2')
1080 -- TyconApp Inductive case; this is the interesting bit.
1081 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1082 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1083 , tycon_l /= tycon_r
1086 | otherwise = return r
1088 where upgrade :: TyCon -> Type -> TR Type
1089 upgrade new_tycon ty
1090 | not (isNewTyCon new_tycon) = do
1091 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1092 ppr new_tycon <> text " for " <> ppr ty)
1095 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1096 text " in presence of newtype evidence " <> ppr new_tycon)
1097 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1098 let ty' = mkTyConApp new_tycon vars
1099 liftTcM (boxyUnify ty (repType ty'))
1100 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1104 zonkTerm :: Term -> TcM Term
1105 zonkTerm = foldTermM TermFoldM{
1106 fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' ->
1107 return (Term ty' dc v tt)
1108 ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1109 return (Suspension ct ty v b)
1110 ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1111 return$ NewtypeWrap ty' dc t
1112 ,fRefWrapM = \ty t ->
1113 return RefWrap `ap` zonkTcType ty `ap` return t
1114 ,fPrimM = (return.) . Prim
1117 --------------------------------------------------------------------------------
1118 -- Restore Class predicates out of a representation type
1119 dictsView :: Type -> Type
1120 -- dictsView ty = ty
1121 dictsView (FunTy (TyConApp tc_dict args) ty)
1122 | Just c <- tyConClass_maybe tc_dict
1123 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1125 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1126 , Just c <- tyConClass_maybe tc_dict
1127 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1131 -- Use only for RTTI types
1132 isMonomorphic :: RttiType -> Bool
1133 isMonomorphic ty = noExistentials && noUniversals
1134 where (tvs, _, ty') = tcSplitSigmaTy ty
1135 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1136 noUniversals = null tvs
1138 -- Use only for RTTI types
1139 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1140 isMonomorphicOnNonPhantomArgs ty
1141 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1142 , phantom_vars <- tyConPhantomTyVars tc
1143 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1144 , tyv `notElem` phantom_vars]
1145 = all isMonomorphicOnNonPhantomArgs concrete_args
1146 | Just (ty1, ty2) <- splitFunTy_maybe ty
1147 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1148 | otherwise = isMonomorphic ty
1150 tyConPhantomTyVars :: TyCon -> [TyVar]
1151 tyConPhantomTyVars tc
1153 , Just dcs <- tyConDataCons_maybe tc
1154 , dc_vars <- concatMap dataConUnivTyVars dcs
1155 = tyConTyVars tc \\ dc_vars
1156 tyConPhantomTyVars _ = []
1158 -- Is this defined elsewhere?
1159 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1160 sigmaType :: Type -> Type
1161 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1164 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1165 mapMif pred f xx = sequence $ mapMif_ pred f xx
1168 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1170 unlessM :: Monad m => m Bool -> m () -> m ()
1171 unlessM condM acc = condM >>= \c -> unless c acc
1174 -- Strict application of f at index i
1175 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1176 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1177 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1178 case indexArray# ptrs# i# of
1181 amap' :: (t -> b) -> Array Int t -> [b]
1182 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1183 where g (I# i#) = case indexArray# arr# i# of
1187 isLifted :: Type -> Bool
1188 isLifted = not . isUnLiftedType
1190 extractUnboxed :: [Type] -> Closure -> [[Word]]
1191 extractUnboxed tt clos = go tt (nonPtrs clos)
1193 | Just (tycon,_) <- tcSplitTyConApp_maybe t
1194 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1195 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1198 | (x, rest) <- splitAt (sizeofType t) xx
1201 sizeofTyCon :: TyCon -> Int -- in *words*
1202 sizeofTyCon = primRepSizeW . tyConPrimRep
1205 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1206 (f |.| g) x = f x || g x