1 -----------------------------------------------------------------------------
3 -- GHC Interactive support for inspecting arbitrary closures at runtime
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
9 module RtClosureInspect(
11 cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
42 #include "HsVersions.h"
44 import ByteCodeItbls ( StgInfoTable )
45 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
46 import HscTypes ( HscEnv )
51 import TcRnMonad ( TcM, initTc, ioToTcRn,
74 import GHC.Arr ( Array(..) )
79 import Data.Array.Base
81 import Data.List ( partition )
82 import qualified Data.Sequence as Seq
84 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
86 import System.IO.Unsafe
88 ---------------------------------------------
89 -- * A representation of semi evaluated Terms
90 ---------------------------------------------
92 A few examples in this representation:
94 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
96 > (('a',_,_),_,('b',_,_)) =
97 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
98 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
100 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
103 data Term = Term { ty :: Type
104 , dc :: Either String DataCon
105 -- Empty if the datacon aint exported by the .hi
106 -- (private constructors in -O0 libraries)
108 , subTerms :: [Term] }
113 | Suspension { ctype :: ClosureType
114 , mb_ty :: Maybe Type
116 , bound_to :: Maybe Name -- Useful for printing
118 | NewtypeWrap{ ty :: Type
119 , dc :: Either String DataCon
120 , wrapped_term :: Term }
122 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
125 isSuspension Suspension{} = True
126 isSuspension _ = False
129 isNewtypeWrap NewtypeWrap{} = True
130 isNewtypeWrap _ = False
132 termType :: Term -> Maybe Type
133 termType t@(Suspension {}) = mb_ty t
134 termType t = Just$ ty t
136 isFullyEvaluatedTerm :: Term -> Bool
137 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
138 isFullyEvaluatedTerm Prim {} = True
139 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
140 isFullyEvaluatedTerm _ = False
142 instance Outputable (Term) where
143 ppr = head . cPprTerm cPprTermBase
145 -------------------------------------------------------------------------
146 -- Runtime Closure Datatype and functions for retrieving closure related stuff
147 -------------------------------------------------------------------------
148 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
181 itbl <- peek (Ptr iptr)
182 let tipe = readCType (BCI.tipe itbl)
183 elems = fromIntegral (BCI.ptrs itbl)
184 ptrsList = Array 0 (elems - 1) elems ptrs
185 nptrs_data = [W# (indexWordArray# nptrs i)
186 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
187 ASSERT(elems >= 0) return ()
189 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
191 readCType :: Integral a => a -> ClosureType
193 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
194 | i >= FUN && i <= FUN_STATIC = Fun
195 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
196 | i == THUNK_SELECTOR = ThunkSelector
197 | i == BLACKHOLE = Blackhole
198 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
199 | fromIntegral i == aP_CODE = AP
201 | fromIntegral i == pAP_CODE = PAP
202 | otherwise = Other (fromIntegral i)
204 isConstr, isIndirection, isThunk :: ClosureType -> Bool
205 isConstr Constr = True
208 isIndirection (Indirection _) = True
209 --isIndirection ThunkSelector = True
210 isIndirection _ = False
212 isThunk (Thunk _) = True
213 isThunk ThunkSelector = True
217 isFullyEvaluated :: a -> IO Bool
218 isFullyEvaluated a = do
219 closure <- getClosureData a
221 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
222 return$ and are_subs_evaluated
224 where amapM f = sequence . amap' f
226 amap' :: (t -> b) -> Array Int t -> [b]
227 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
228 where g (I# i#) = case indexArray# arr# i# of
231 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
233 unsafeDeepSeq :: a -> b -> b
234 unsafeDeepSeq = unsafeDeepSeq1 2
235 where unsafeDeepSeq1 0 a b = seq a $! b
236 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
237 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
238 -- | unsafePerformIO (isFullyEvaluated a) = b
239 | otherwise = case unsafePerformIO (getClosureData a) of
240 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
241 where tipe = unsafePerformIO (getClosureType a)
243 isPointed :: Type -> Bool
244 isPointed t | Just (t, _) <- splitTyConApp_maybe t
245 = not$ isUnliftedTypeKind (tyConKind t)
248 extractUnboxed :: [Type] -> Closure -> [[Word]]
249 extractUnboxed tt clos = go tt (nonPtrs clos)
251 | Just (tycon,_) <- splitTyConApp_maybe t
252 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
253 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
256 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
259 sizeofTyCon :: TyCon -> Int
260 sizeofTyCon = sizeofPrimRep . tyConPrimRep
262 -----------------------------------
263 -- * Traversals for Terms
264 -----------------------------------
265 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
267 data TermFold a = TermFold { fTerm :: TermProcessor a a
268 , fPrim :: Type -> [Word] -> a
269 , fSuspension :: ClosureType -> Maybe Type -> HValue
271 , fNewtypeWrap :: Type -> Either String DataCon
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)
281 idTermFold :: TermFold Term
282 idTermFold = TermFold {
285 fSuspension = Suspension,
286 fNewtypeWrap = NewtypeWrap
288 idTermFoldM :: Monad m => TermFold (m Term)
289 idTermFoldM = TermFold {
290 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
291 fPrim = (return.). Prim,
292 fSuspension = (((return.).).). Suspension,
293 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t
296 mapTermType :: (Type -> Type) -> Term -> Term
297 mapTermType f = foldTerm idTermFold {
298 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
299 fSuspension = \ct mb_ty hval n ->
300 Suspension ct (fmap f mb_ty) hval n,
301 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t}
303 termTyVars :: Term -> TyVarSet
304 termTyVars = foldTerm TermFold {
305 fTerm = \ty _ _ tt ->
306 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
307 fSuspension = \_ mb_ty _ _ ->
308 maybe emptyVarEnv tyVarsOfType mb_ty,
309 fPrim = \ _ _ -> emptyVarEnv,
310 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t}
311 where concatVarEnv = foldr plusVarEnv emptyVarEnv
313 ----------------------------------
314 -- Pretty printing of terms
315 ----------------------------------
317 app_prec,cons_prec ::Int
319 cons_prec = 5 -- TODO Extract this info from GHC itself
321 pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
322 pprTerm y p t | Just doc <- pprTermM y p t = doc
323 pprTerm _ _ _ = panic "pprTerm"
325 pprTermM, pprNewtypeWrap :: Monad m =>
326 (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
327 pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
328 tt_docs <- mapM (y app_prec) tt
329 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
331 pprTermM y p Term{dc=Right dc, subTerms=tt}
332 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
333 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
334 <+> hsep (map (pprTerm1 True) tt)
335 -} -- TODO Printing infix constructors properly
336 | null tt = return$ ppr dc
338 tt_docs <- mapM (y app_prec) tt
339 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
341 pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
343 pprTermM _ _ t = pprTermM1 t
345 pprTermM1 :: Monad m => Term -> m SDoc
346 pprTermM1 Prim{value=words, ty=ty} =
347 return$ text$ repPrim (tyConAppTyCon ty) words
348 pprTermM1 Term{} = panic "pprTermM1 - unreachable"
349 pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
350 pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
351 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
352 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
353 pprTermM1 _ = panic "pprTermM1"
355 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
356 | Just (tc,_) <- splitNewTyConApp_maybe ty
357 , ASSERT(isNewTyCon tc) True
358 , Just new_dc <- maybeTyConSingleCon tc = do
360 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
361 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
363 -------------------------------------------------------
364 -- Custom Term Pretty Printers
365 -------------------------------------------------------
367 -- We can want to customize the representation of a
368 -- term depending on its type.
369 -- However, note that custom printers have to work with
370 -- type representations, instead of directly with types.
371 -- We cannot use type classes here, unless we employ some
372 -- typerep trickery (e.g. Weirich's RepLib tricks),
373 -- which I didn't. Therefore, this code replicates a lot
374 -- of what type classes provide for free.
376 -- Concretely a custom term printer takes an explicit
377 -- recursion knot, and produces a list of Term Processors,
378 -- which additionally need a precedence value to
379 -- either produce a SDoc or fail (and they do this in some monad m).
381 type Precedence = Int
382 type RecursionKnot m = Precedence -> Term -> m SDoc
383 type CustomTermPrinter m = RecursionKnot m
384 -> [Precedence -> Term -> (m (Maybe SDoc))]
386 -- Takes a list of custom printers with a explicit recursion knot and a term,
387 -- and returns the output of the first succesful printer, or the default printer
388 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
389 cPprTerm printers_ = go 0 where
390 printers = printers_ go
391 go prec t | isTerm t || isNewtypeWrap t = do
392 let default_ = Just `liftM` pprTermM go prec t
393 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
394 Just doc <- firstJustM mb_customDocs
395 return$ cparen (prec>app_prec+1) doc
398 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
399 firstJustM [] = return Nothing
401 -- Default set of custom printers. Note that the recursion knot is explicit
402 cPprTermBase :: Monad m => CustomTermPrinter m
404 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
407 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
408 (\ p Term{subTerms=[h,t]} -> doList p h t)
409 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
410 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
411 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
412 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
413 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
415 where ifTerm pred f prec t@Term{}
416 | pred t = Just `liftM` f prec t
417 ifTerm _ _ _ _ = return Nothing
419 isIntegerTy ty = fromMaybe False $ do
420 (tc,_) <- splitTyConApp_maybe ty
421 return (tyConName tc == integerTyConName)
423 isTupleTy ty = fromMaybe False $ do
424 (tc,_) <- splitTyConApp_maybe ty
425 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
427 isTyCon a_tc ty = fromMaybe False $ do
428 (tc,_) <- splitTyConApp_maybe ty
431 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
433 --TODO pprinting of list terms is not lazy
435 let elems = h : getListTerms t
436 isConsLast = termType(last elems) /= termType h
437 print_elems <- mapM (y cons_prec) elems
438 return$ if isConsLast
439 then cparen (p >= cons_prec)
441 . punctuate (space<>colon)
443 else brackets (hcat$ punctuate comma print_elems)
445 where Just a /= Just b = not (a `coreEqType` b)
447 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
448 getListTerms Term{subTerms=[]} = []
449 getListTerms t@Suspension{} = [t]
450 getListTerms t = pprPanic "getListTerms" (ppr t)
453 repPrim :: TyCon -> [Word] -> String
454 repPrim t = rep where
456 | t == charPrimTyCon = show (build x :: Char)
457 | t == intPrimTyCon = show (build x :: Int)
458 | t == wordPrimTyCon = show (build x :: Word)
459 | t == floatPrimTyCon = show (build x :: Float)
460 | t == doublePrimTyCon = show (build x :: Double)
461 | t == int32PrimTyCon = show (build x :: Int32)
462 | t == word32PrimTyCon = show (build x :: Word32)
463 | t == int64PrimTyCon = show (build x :: Int64)
464 | t == word64PrimTyCon = show (build x :: Word64)
465 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
466 | t == stablePtrPrimTyCon = "<stablePtr>"
467 | t == stableNamePrimTyCon = "<stableName>"
468 | t == statePrimTyCon = "<statethread>"
469 | t == realWorldTyCon = "<realworld>"
470 | t == threadIdPrimTyCon = "<ThreadId>"
471 | t == weakPrimTyCon = "<Weak>"
472 | t == arrayPrimTyCon = "<array>"
473 | t == byteArrayPrimTyCon = "<bytearray>"
474 | t == mutableArrayPrimTyCon = "<mutableArray>"
475 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
476 | t == mutVarPrimTyCon= "<mutVar>"
477 | t == mVarPrimTyCon = "<mVar>"
478 | t == tVarPrimTyCon = "<tVar>"
479 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
480 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
481 -- This ^^^ relies on the representation of Haskell heap values being
482 -- the same as in a C array.
484 -----------------------------------
485 -- Type Reconstruction
486 -----------------------------------
488 Type Reconstruction is type inference done on heap closures.
489 The algorithm walks the heap generating a set of equations, which
490 are solved with syntactic unification.
491 A type reconstruction equation looks like:
493 <datacon reptype> = <actual heap contents>
495 The full equation set is generated by traversing all the subterms, starting
498 The only difficult part is that newtypes are only found in the lhs of equations.
499 Right hand sides are missing them. We can either (a) drop them from the lhs, or
500 (b) reconstruct them in the rhs when possible.
502 The function congruenceNewtypes takes a shot at (b)
505 -- The Type Reconstruction monad
508 runTR :: HscEnv -> TR a -> IO a
510 mb_term <- runTR_maybe hsc_env c
512 Nothing -> panic "Can't unify"
515 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
516 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
519 trIO = liftTcM . ioToTcRn
521 liftTcM :: TcM a -> TR a
524 newVar :: Kind -> TR TcType
525 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
527 -- | Returns the instantiated type scheme ty', and the substitution sigma
528 -- such that sigma(ty') = ty
529 instScheme :: Type -> TR (TcType, TvSubst)
530 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
531 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
532 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
534 -- Adds a constraint of the form t1 == t2
535 -- t1 is expected to come from walking the heap
536 -- t2 is expected to come from a datacon signature
537 -- Before unification, congruenceNewtypes needs to
539 addConstraint :: TcType -> TcType -> TR ()
540 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
541 >> return () -- TOMDO: what about the coercion?
542 -- we should consider family instances
544 -- Type & Term reconstruction
545 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
546 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
547 tv <- newVar argTypeKind
549 Nothing -> go bound tv tv hval
551 >>= return . expandNewtypes
552 Just ty | isMonomorphic ty -> go bound ty ty hval
554 >>= return . expandNewtypes
556 (ty',rev_subst) <- instScheme (sigmaType ty)
558 term <- go bound tv tv hval >>= zonkTerm
559 --restore original Tyvars
560 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
562 go bound _ _ _ | seq bound False = undefined
564 clos <- trIO $ getClosureData a
565 return (Suspension (tipe clos) (Just tv) a Nothing)
566 go bound tv ty a = do
567 let monomorphic = not(isTyVarTy tv)
568 -- This ^^^ is a convention. The ancestor tests for
569 -- monomorphism and passes a type instead of a tv
570 clos <- trIO $ getClosureData a
572 -- Thunks we may want to force
573 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
574 -- force blackholes, because it would almost certainly result in deadlock,
575 -- and showing the '_' is more useful.
576 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
577 -- We always follow indirections
578 Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
579 -- The interesting case
581 Right dcname <- dataConInfoPtrToName (infoPtr clos)
582 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
584 Nothing -> do -- This can happen for private constructors compiled -O0
585 -- where the .hi descriptor does not export them
586 -- In such case, we return a best approximation:
587 -- ignore the unpointed args, and recover the pointeds
588 -- This preserves laziness, and should be safe.
589 let tag = showSDoc (ppr dcname)
590 vars <- replicateM (length$ elems$ ptrs clos)
591 (newVar (liftedTypeKind))
592 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
593 | (i, tv) <- zip [0..] vars]
594 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
596 let extra_args = length(dataConRepArgTys dc) -
597 length(dataConOrigArgTys dc)
598 subTtypes = matchSubTypes dc ty
599 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
600 subTermTvs <- sequence
601 [ if isMonomorphic t then return t
603 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
604 -- It is vital for newtype reconstruction that the unification step
605 -- is done right here, _before_ the subterms are RTTI reconstructed
606 when (not monomorphic) $ do
607 let myType = mkFunTys (reOrderTerms subTermTvs
611 (signatureType,_) <- instScheme(dataConRepType dc)
612 addConstraint myType signatureType
613 subTermsP <- sequence $ drop extra_args
614 -- ^^^ all extra arguments are pointed
615 [ appArr (go (pred bound) tv t) (ptrs clos) i
616 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
617 let unboxeds = extractUnboxed subTtypesNP clos
618 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
619 subTerms = reOrderTerms subTermsP subTermsNP
620 (drop extra_args subTtypes)
621 return (Term tv (Right dc) a subTerms)
622 -- The otherwise case: can be a Thunk,AP,PAP,etc.
624 return (Suspension tipe_clos (Just tv) a Nothing)
627 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
628 -- assumption: ^^^ looks through newtypes
629 , isVanillaDataCon dc --TODO non-vanilla case
630 = dataConInstArgTys dc ty_args
631 | otherwise = dataConRepArgTys dc
633 -- This is used to put together pointed and nonpointed subterms in the
635 reOrderTerms _ _ [] = []
636 reOrderTerms pointed unpointed (ty:tys)
637 | isPointed ty = ASSERT2(not(null pointed)
638 , ptext SLIT("reOrderTerms") $$
639 (ppr pointed $$ ppr unpointed))
640 head pointed : reOrderTerms (tail pointed) unpointed tys
641 | otherwise = ASSERT2(not(null unpointed)
642 , ptext SLIT("reOrderTerms") $$
643 (ppr pointed $$ ppr unpointed))
644 head unpointed : reOrderTerms pointed (tail unpointed) tys
646 expandNewtypes t@Term{ ty=ty, subTerms=tt }
647 | Just (tc, args) <- splitNewTyConApp_maybe ty
649 , wrapped_type <- newTyConInstRhs tc args
650 , Just dc <- maybeTyConSingleCon tc
651 , t' <- expandNewtypes t{ ty = wrapped_type
652 , subTerms = map expandNewtypes tt }
653 = NewtypeWrap ty (Right dc) t'
655 | otherwise = t{ subTerms = map expandNewtypes tt }
660 -- Fast, breadth-first Type reconstruction
661 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
662 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
663 tv <- newVar argTypeKind
665 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
667 (Seq.singleton (tv, hval))
669 zonkTcType tv -- TODO untested!
670 Just ty | isMonomorphic ty -> return ty
672 (ty',rev_subst) <- instScheme (sigmaType ty)
674 search (isMonomorphic `fmap` zonkTcType tv)
676 (Seq.singleton (tv, hval))
678 substTy rev_subst `fmap` zonkTcType tv
680 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
681 search _ _ _ 0 = fail$ "Failed to reconstruct a type after " ++
682 show max_depth ++ " steps"
683 search stop expand l d =
686 x :< xx -> unlessM stop $ do
688 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
690 -- returns unification tasks,since we are going to want a breadth-first search
691 go :: Type -> HValue -> TR [(Type, HValue)]
693 clos <- trIO $ getClosureData a
695 Indirection _ -> go tv $! (ptrs clos ! 0)
697 Right dcname <- dataConInfoPtrToName (infoPtr clos)
698 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
701 -- TODO: Check this case
702 forM [0..length (elems $ ptrs clos)] $ \i -> do
703 tv <- newVar liftedTypeKind
704 return$ appArr (\e->(tv,e)) (ptrs clos) i
707 let extra_args = length(dataConRepArgTys dc) -
708 length(dataConOrigArgTys dc)
709 subTtypes <- mapMif (not . isMonomorphic)
710 (\t -> newVar (typeKind t))
711 (dataConRepArgTys dc)
713 -- It is vital for newtype reconstruction that the unification step
714 -- is done right here, _before_ the subterms are RTTI reconstructed
715 let myType = mkFunTys subTtypes tv
716 (signatureType,_) <- instScheme(dataConRepType dc)
717 addConstraint myType signatureType
718 return $ [ appArr (\e->(t,e)) (ptrs clos) i
719 | (i,t) <- drop extra_args $
720 zip [0..] (filter isPointed subTtypes)]
723 -- This helper computes the difference between a base type t and the
724 -- improved rtti_t computed by RTTI
725 -- The main difference between RTTI types and their normal counterparts
726 -- is that the former are _not_ polymorphic, thus polymorphism must
727 -- be stripped. Syntactically, forall's must be stripped
728 computeRTTIsubst :: Type -> Type -> Maybe TvSubst
729 computeRTTIsubst ty rtti_ty =
730 -- In addition, we strip newtypes too, since the reconstructed type might
731 -- not have recovered them all
732 tcUnifyTys (const BindMe)
733 [repType' $ dropForAlls$ ty]
735 -- TODO stripping newtypes shouldn't be necessary, test
738 -- Dealing with newtypes
740 A parallel fold over two Type values,
741 compensating for missing newtypes on both sides.
742 This is necessary because newtypes are not present
743 in runtime, but since sometimes there is evidence
744 available we do our best to reconstruct them.
745 Evidence can come from DataCon signatures or
746 from compile-time type inference.
747 I am using the words congruence and rewriting
748 because what we are doing here is an approximation
749 of unification modulo a set of equations, which would
750 come from newtype definitions. These should be the
751 equality coercions seen in System Fc. Rewriting
752 is performed, taking those equations as rules,
753 before launching unification.
755 It doesn't make sense to rewrite everywhere,
756 or we would end up with all newtypes. So we rewrite
757 only in presence of evidence.
758 The lhs comes from the heap structure of ptrs,nptrs.
759 The rhs comes from a DataCon type signature.
760 Rewriting in the rhs is restricted to the result type.
762 Note that it is very tricky to make this 'rewriting'
763 work with the unification implemented by TcM, where
764 substitutions are 'inlined'. The order in which
765 constraints are unified is vital for this (or I am
768 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
769 congruenceNewtypes lhs rhs
770 -- TyVar lhs inductive case
771 | Just tv <- getTyVar_maybe lhs
772 = recoverTc (return (lhs,rhs)) $ do
773 Indirect ty_v <- readMetaTyVar tv
774 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
776 -- FunTy inductive case
777 | Just (l1,l2) <- splitFunTy_maybe lhs
778 , Just (r1,r2) <- splitFunTy_maybe rhs
779 = do (l2',r2') <- congruenceNewtypes l2 r2
780 (l1',r1') <- congruenceNewtypes l1 r1
781 return (mkFunTy l1' l2', mkFunTy r1' r2')
782 -- TyconApp Inductive case; this is the interesting bit.
783 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
784 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
786 = return (lhs, upgrade tycon_l rhs)
788 | otherwise = return (lhs,rhs)
790 where upgrade :: TyCon -> Type -> Type
792 | not (isNewTyCon new_tycon) = ty
793 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
794 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
796 upgrade _ _ = panic "congruenceNewtypes.upgrade"
797 -- assumes that reptype doesn't touch tyconApp args ^^^
800 --------------------------------------------------------------------------------
801 -- Semantically different to recoverM in TcRnMonad
802 -- recoverM retains the errors in the first action,
803 -- whereas recoverTc here does not
804 recoverTc :: TcM a -> TcM a -> TcM a
805 recoverTc recover thing = do
806 (_,mb_res) <- tryTcErrs thing
809 Just res -> return res
811 isMonomorphic :: Type -> Bool
812 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
813 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
815 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
816 mapMif pred f xx = sequence $ mapMif_ pred f xx
819 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
821 unlessM :: Monad m => m Bool -> m () -> m ()
822 unlessM condM acc = condM >>= \c -> unless c acc
824 -- Strict application of f at index i
825 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
826 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
827 = ASSERT (i < length(elems a))
828 case indexArray# ptrs# i# of
831 zonkTerm :: Term -> TcM Term
832 zonkTerm = foldTerm idTermFoldM {
833 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
834 zonkTcType ty >>= \ty' ->
835 return (Term ty' dc v tt)
836 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
837 return (Suspension ct ty v b)
838 ,fNewtypeWrap= \ty dc t ->
839 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
842 -- Is this defined elsewhere?
843 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
844 sigmaType :: Type -> Type
845 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty