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)
520 -- The Type Reconstruction monad
523 -- A (non-mutable) tau type containing
524 -- existentially quantified tyvars.
525 -- (since GHC type language currently does not support
526 -- existentials, we leave these variables unquantified)
529 -- An incomplete type as stored in GHCi:
530 -- no polymorphism: no quantifiers & all tyvars are skolem.
533 runTR :: HscEnv -> TR a -> IO a
535 mb_term <- runTR_maybe hsc_env c
537 Nothing -> panic "RTTI: Failed to reconstruct a term"
541 runTR :: HscEnv -> TR a -> IO a
542 runTR hsc_env thing = do
543 mb_val <- runTR_maybe hsc_env thing
545 Nothing -> error "RTTI error: probably due to :forcing an undefined"
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 $ fsep [text "add constraint:", 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 uncurry boxyUnify >> return ())
594 -- TOMDO: what about the coercion?
595 -- we should consider family instances
597 -- Type & Term reconstruction
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. Term obtained: " <> ppr term)
639 go :: Int -> Type -> Type -> HValue -> TcM Term
640 go max_depth _ _ _ | seq max_depth False = undefined
641 go 0 my_ty _old_ty a = do
642 clos <- trIO $ getClosureData a
643 return (Suspension (tipe clos) my_ty a Nothing)
644 go max_depth my_ty old_ty a = do
645 let monomorphic = not(isTyVarTy my_ty)
646 -- This ^^^ is a convention. The ancestor tests for
647 -- monomorphism and passes a type instead of a tv
648 clos <- trIO $ getClosureData a
650 -- Thunks we may want to force
651 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
652 -- force blackholes, because it would almost certainly result in deadlock,
653 -- and showing the '_' is more useful.
654 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
655 seq a (go (pred max_depth) my_ty old_ty a)
656 -- We always follow indirections
657 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
658 go max_depth my_ty old_ty $! (ptrs clos ! 0)
659 -- We also follow references
660 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
662 -- Deal with the MutVar# primitive
663 -- It does not have a constructor at all,
664 -- so we simulate the following one
665 -- MutVar# :: contents_ty -> MutVar# s contents_ty
666 traceTR (text "Following a MutVar")
667 contents_tv <- newVar liftedTypeKind
668 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
669 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
670 (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
671 contents_ty (mkTyConApp tycon [world,contents_ty])
672 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
673 x <- go (pred max_depth) contents_tv contents_ty contents
674 return (RefWrap my_ty x)
676 -- The interesting case
678 traceTR (text "entering a constructor")
679 Right dcname <- dataConInfoPtrToName (infoPtr clos)
680 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
682 Nothing -> do -- This can happen for private constructors compiled -O0
683 -- where the .hi descriptor does not export them
684 -- In such case, we return a best approximation:
685 -- ignore the unpointed args, and recover the pointeds
686 -- This preserves laziness, and should be safe.
687 let tag = showSDoc (ppr dcname)
688 vars <- replicateM (length$ elems$ ptrs clos)
689 (newVar (liftedTypeKind))
690 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
691 | (i, tv) <- zip [0..] vars]
692 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
694 let subTtypes = matchSubTypes dc old_ty
695 (subTtypesP, subTtypesNP) = partition (isLifted |.| isRefType) subTtypes
696 subTermTvs <- mapMif (not . isMonomorphic)
697 (\t -> newVar (typeKind t))
699 -- It is vital for newtype reconstruction that the unification step
700 -- is done right here, _before_ the subterms are RTTI reconstructed
701 when (not monomorphic) $ do
703 -- When we already have all the information, avoid solving
704 -- unnecessary constraints. Propagation of type information
705 -- to subterms is already being done via matching.
706 let myType = mkFunTys subTermTvs my_ty
707 (signatureType,_) <- instScheme (rttiView $ dataConUserType dc)
708 addConstraint myType signatureType
709 subTermsP <- sequence
710 [ appArr (go (pred max_depth) tv t) (ptrs clos) i
711 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
712 let unboxeds = extractUnboxed subTtypesNP clos
713 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
714 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
715 return (Term my_ty (Right dc) a subTerms)
716 -- The otherwise case: can be a Thunk,AP,PAP,etc.
718 return (Suspension tipe_clos my_ty a Nothing)
721 | ty' <- repType ty -- look through newtypes
722 , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
723 , dc `elem` tyConDataCons tc
724 -- It is necessary to check that dc is actually a constructor for tycon tc,
725 -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
726 -- has not removed it. In that case, we happily give up and don't match
727 = myDataConInstArgTys dc ty_args
728 | otherwise = dataConRepArgTys dc
730 -- put together pointed and nonpointed subterms in the
732 reOrderTerms _ _ [] = []
733 reOrderTerms pointed unpointed (ty:tys)
734 | isLifted ty || isRefType ty
735 = ASSERT2(not(null pointed)
736 , ptext (sLit "reOrderTerms") $$
737 (ppr pointed $$ ppr unpointed))
738 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
739 | otherwise = ASSERT2(not(null unpointed)
740 , ptext (sLit "Reorderterms") $$
741 (ppr pointed $$ ppr unpointed))
742 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
744 -- insert NewtypeWraps around newtypes
745 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
747 | Just (tc, args) <- tcSplitTyConApp_maybe ty
749 , wrapped_type <- newTyConInstRhs tc args
750 , Just dc' <- tyConSingleDataCon_maybe tc
751 , t' <- worker wrapped_type dc hval tt
752 = NewtypeWrap ty (Right dc') t'
753 | otherwise = Term ty dc hval tt
756 -- Avoid returning types where predicates have been expanded to dictionaries.
757 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
758 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
759 | otherwise = Suspension ct ty hval n
762 -- Fast, breadth-first Type reconstruction
763 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
764 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
765 traceTR (text "RTTI started with initial type " <> ppr old_ty)
766 let sigma_old_ty = sigmaType old_ty
768 if isMonomorphic sigma_old_ty
771 (old_ty', rev_subst) <- instScheme sigma_old_ty
772 my_ty <- newVar argTypeKind
773 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
774 addConstraint my_ty old_ty')
775 search (isMonomorphic `fmap` zonkTcType my_ty)
777 (Seq.singleton (my_ty, hval))
779 new_ty <- zonkTcType my_ty
780 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
782 traceTR (text "check2 passed")
783 addConstraint my_ty old_ty'
784 new_ty' <- zonkTcType my_ty
785 return (substTy rev_subst new_ty')
786 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
788 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
791 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
792 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
793 int max_depth <> text " steps")
794 search stop expand l d =
797 x :< xx -> unlessM stop $ do
799 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
801 -- returns unification tasks,since we are going to want a breadth-first search
802 go :: Type -> HValue -> TR [(Type, HValue)]
804 clos <- trIO $ getClosureData a
806 Indirection _ -> go my_ty $! (ptrs clos ! 0)
808 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
809 tv' <- newVar liftedTypeKind
810 world <- newVar liftedTypeKind
811 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
812 return [(tv', contents)]
814 Right dcname <- dataConInfoPtrToName (infoPtr clos)
815 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
818 -- TODO: Check this case
819 forM [0..length (elems $ ptrs clos)] $ \i -> do
820 tv <- newVar liftedTypeKind
821 return$ appArr (\e->(tv,e)) (ptrs clos) i
824 subTtypes <- mapMif (not . isMonomorphic)
825 (\t -> newVar (typeKind t))
826 (dataConRepArgTys dc)
828 -- It is vital for newtype reconstruction that the unification step
829 -- is done right here, _before_ the subterms are RTTI reconstructed
830 let myType = mkFunTys subTtypes my_ty
831 (signatureType,_) <- instScheme(rttiView $ dataConUserType dc)
832 addConstraint myType signatureType
833 return $ [ appArr (\e->(t,e)) (ptrs clos) i
834 | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
837 -- Compute the difference between a base type and the type found by RTTI
838 -- improveType <base_type> <rtti_type>
839 -- The types can contain skolem type variables, which need to be treated as normal vars.
840 -- In particular, we want them to unify with things.
841 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
842 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
843 traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty]
844 (ty_tvs, _, _) <- tcInstType return ty
845 (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
846 (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
847 boxyUnify rtti_ty' ty'
848 tvs1_contents <- zonkTcTyVars ty_tvs'
849 let subst = (uncurry zipTopTvSubst . unzip)
850 [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
851 , getTyVar_maybe ty /= Just tv
852 --, not(isTyVarTy ty)
855 where ty = sigmaType _ty
857 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
858 myDataConInstArgTys dc args
859 | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
860 | otherwise = dataConRepArgTys dc
862 isRefType :: Type -> Bool
864 | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
866 where ty'= repType ty
868 isRefTyCon :: TyCon -> Bool
869 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
874 This is not formalized anywhere, so hold to your seats!
875 RTTI in the presence of newtypes can be a tricky and unsound business.
879 Suppose we are doing RTTI for a partially evaluated
880 closure t, the real type of which is t :: MkT Int, for
882 newtype MkT a = MkT [Maybe a]
884 The table below shows the results of RTTI and the improvement
885 calculated for different combinations of evaluatedness and :type t.
886 Regard the two first columns as input and the next two as output.
888 # | t | :type t | rtti(t) | improv. | result
889 ------------------------------------------------------------
890 1 | _ | t b | a | none | OK
891 2 | _ | MkT b | a | none | OK
892 3 | _ | t Int | a | none | OK
894 If t is not evaluated at *all*, we are safe.
896 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
897 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
898 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
900 If a is a minimal whnf, we run into trouble. Note that
901 row 5 above does newtype enrichment on the ty_rtty parameter.
903 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
906 8 | (Just _:_)| MkT b | MkT a | none | OK
907 9 | (Just _:_)| t Int | FAIL | none | OK
909 And if t is any more evaluated than whnf, we are still in trouble.
910 Because constraints are solved in top-down order, when we reach the
911 Maybe subterm what we got is already unsound. This explains why the
912 row 9 fails to complete.
914 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
915 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
917 We can undo the failure in row 9 by leaving out the constraint
918 coming from the type signature of t (i.e., the 2nd column).
919 Note that this type information is still used
920 to calculate the improvement. But we fail
921 when trying to calculate the improvement, as there is no unifier for
922 t Int = [Maybe a] or t Int = [Maybe Int].
925 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
927 # | t | :type t | rtti(t) | improvement | result
928 ---------------------------------------------------------------------
929 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
930 | | | | b = Maybe a |
934 Consider a function obtainType that takes a value and a type and produces
935 the Term representation and a substitution (the improvement).
936 Assume an auxiliar rtti' function which does the actual job if recovering
937 the type, but which may produce a false type.
941 rtti' :: a -> IO Type -- Does not use the static type information
943 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
944 obtainType v old_ty = do
946 if monomorphic rtti_ty || (check rtti_ty old_ty)
949 where check rtti_ty old_ty = check1 rtti_ty &&
950 check2 rtti_ty old_ty
952 check1 :: Type -> Bool
953 check2 :: Type -> Type -> Bool
955 Now, if rtti' returns a monomorphic type, we are safe.
956 If that is not the case, then we consider two conditions.
959 1. To prevent the class of unsoundness displayed by
960 rows 4 and 7 in the example: no higher kind tyvars
967 2. To prevent the class of unsoundness shown by row 6,
968 the rtti type should be structurally more
969 defined than the old type we are comparing it to.
970 check2 :: OldType -> NewTy pe -> Bool
973 check2 [a] (t Int) = False
974 check2 [a] (t a) = False -- By check1 we never reach this equation
975 check2 [Int] a = True
976 check2 [Int] (t Int) = True
977 check2 [Maybe a] (t Int) = False
978 check2 [Maybe Int] (t Int) = True
979 check2 (Maybe [a]) (m [Int]) = False
980 check2 (Maybe [Int]) (m [Int]) = True
984 check1 :: Type -> Bool
985 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
987 isHigherKind = not . null . fst . splitKindFunTys
989 check2 :: Type -> Type -> Bool
990 check2 sigma_rtti_ty sigma_old_ty
991 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
993 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
994 -> and$ zipWith check2 rttis olds
995 _ | Just _ <- splitAppTy_maybe old_ty
996 -> isMonomorphicOnNonPhantomArgs rtti_ty
999 where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
1000 (_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty
1003 -- Dealing with newtypes
1004 --------------------------
1006 congruenceNewtypes does a parallel fold over two Type values,
1007 compensating for missing newtypes on both sides.
1008 This is necessary because newtypes are not present
1009 in runtime, but sometimes there is evidence available.
1010 Evidence can come from DataCon signatures or
1011 from compile-time type inference.
1012 What we are doing here is an approximation
1013 of unification modulo a set of equations derived
1014 from newtype definitions. These equations should be the
1015 same as the equality coercions generated for newtypes
1016 in System Fc. The idea is to perform a sort of rewriting,
1017 taking those equations as rules, before launching unification.
1019 The caller must ensure the following.
1020 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1021 The 2nd type (rhs) comes from a DataCon type signature.
1022 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1023 in both types, but in the rhs it is restricted to the result type.
1025 Note that it is very tricky to make this 'rewriting'
1026 work with the unification implemented by TcM, where
1027 substitutions are operationally inlined. The order in which
1028 constraints are unified is vital as we cannot modify
1029 anything that has been touched by a previous unification step.
1030 Therefore, congruenceNewtypes is sound only if the types
1031 recovered by the RTTI mechanism are unified Top-Down.
1033 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1034 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1037 -- TyVar lhs inductive case
1038 | Just tv <- getTyVar_maybe l
1039 = recoverTR (return r) $ do
1040 Indirect ty_v <- readMetaTyVar tv
1041 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1042 ppr tv, equals, ppr ty_v]
1044 -- FunTy inductive case
1045 | Just (l1,l2) <- splitFunTy_maybe l
1046 , Just (r1,r2) <- splitFunTy_maybe r
1047 = do r2' <- go l2 r2
1049 return (mkFunTy r1' r2')
1050 -- TyconApp Inductive case; this is the interesting bit.
1051 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1052 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1053 , tycon_l /= tycon_r
1056 | otherwise = return r
1058 where upgrade :: TyCon -> Type -> TR Type
1059 upgrade new_tycon ty
1060 | not (isNewTyCon new_tycon) = do
1061 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1062 ppr new_tycon <> text " for " <> ppr ty)
1065 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1066 text " in presence of newtype evidence " <> ppr new_tycon)
1067 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1068 let ty' = mkTyConApp new_tycon vars
1069 liftTcM (boxyUnify ty (repType ty'))
1070 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1074 zonkTerm :: Term -> TcM Term
1075 zonkTerm = foldTermM TermFoldM{
1076 fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' ->
1077 return (Term ty' dc v tt)
1078 ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1079 return (Suspension ct ty v b)
1080 ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1081 return$ NewtypeWrap ty' dc t
1082 ,fRefWrapM = \ty t ->
1083 return RefWrap `ap` zonkTcType ty `ap` return t
1084 ,fPrimM = (return.) . Prim
1087 --------------------------------------------------------------------------------
1088 -- representation types for thetas
1089 rttiView :: Type -> Type
1090 rttiView ty | Just ty' <- coreView ty = rttiView ty'
1092 | (tvs, theta, tau) <- tcSplitSigmaTy ty
1093 = mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau)
1095 -- Restore Class predicates out of a representation type
1096 dictsView :: Type -> Type
1097 -- dictsView ty = ty
1098 dictsView (FunTy (TyConApp tc_dict args) ty)
1099 | Just c <- tyConClass_maybe tc_dict
1100 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1102 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1103 , Just c <- tyConClass_maybe tc_dict
1104 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1108 -- Use only for RTTI types
1109 isMonomorphic :: RttiType -> Bool
1110 isMonomorphic ty = noExistentials && noUniversals
1111 where (tvs, _, ty') = tcSplitSigmaTy ty
1112 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1113 noUniversals = null tvs
1115 -- Use only for RTTI types
1116 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1117 isMonomorphicOnNonPhantomArgs ty
1118 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1119 , phantom_vars <- tyConPhantomTyVars tc
1120 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1121 , tyv `notElem` phantom_vars]
1122 = all isMonomorphicOnNonPhantomArgs concrete_args
1123 | Just (ty1, ty2) <- splitFunTy_maybe ty
1124 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1125 | otherwise = isMonomorphic ty
1127 tyConPhantomTyVars :: TyCon -> [TyVar]
1128 tyConPhantomTyVars tc
1130 , Just dcs <- tyConDataCons_maybe tc
1131 , dc_vars <- concatMap dataConUnivTyVars dcs
1132 = tyConTyVars tc \\ dc_vars
1133 tyConPhantomTyVars _ = []
1135 -- Is this defined elsewhere?
1136 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1137 sigmaType :: Type -> Type
1138 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1141 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1142 mapMif pred f xx = sequence $ mapMif_ pred f xx
1145 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1147 unlessM :: Monad m => m Bool -> m () -> m ()
1148 unlessM condM acc = condM >>= \c -> unless c acc
1151 -- Strict application of f at index i
1152 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1153 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1154 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1155 case indexArray# ptrs# i# of
1158 amap' :: (t -> b) -> Array Int t -> [b]
1159 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1160 where g (I# i#) = case indexArray# arr# i# of
1164 isLifted :: Type -> Bool
1165 isLifted = not . isUnLiftedType
1167 extractUnboxed :: [Type] -> Closure -> [[Word]]
1168 extractUnboxed tt clos = go tt (nonPtrs clos)
1170 | Just (tycon,_) <- tcSplitTyConApp_maybe t
1171 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1172 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1175 | (x, rest) <- splitAt (sizeofType t) xx
1178 sizeofTyCon :: TyCon -> Int -- in *words*
1179 sizeofTyCon = primRepSizeW . tyConPrimRep
1182 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1183 (f |.| g) x = f x || g x