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 )
52 import TcRnMonad ( TcM, initTc, ioToTcRn,
75 import GHC.Arr ( Array(..) )
80 import Data.Array.Base
82 import Data.List ( partition )
83 import qualified Data.Sequence as Seq
85 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
87 import System.IO.Unsafe
89 ---------------------------------------------
90 -- * A representation of semi evaluated Terms
91 ---------------------------------------------
93 A few examples in this representation:
95 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
97 > (('a',_,_),_,('b',_,_)) =
98 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
99 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
101 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
104 data Term = Term { ty :: Type
105 , dc :: Either String DataCon
106 -- Empty if the datacon aint exported by the .hi
107 -- (private constructors in -O0 libraries)
109 , subTerms :: [Term] }
114 | Suspension { ctype :: ClosureType
115 , mb_ty :: Maybe Type
117 , bound_to :: Maybe Name -- Useful for printing
119 | NewtypeWrap{ ty :: Type
120 , dc :: Either String DataCon
121 , wrapped_term :: Term }
123 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
126 isSuspension Suspension{} = True
127 isSuspension _ = False
130 isNewtypeWrap NewtypeWrap{} = True
131 isNewtypeWrap _ = False
133 termType :: Term -> Maybe Type
134 termType t@(Suspension {}) = mb_ty t
135 termType t = Just$ ty t
137 isFullyEvaluatedTerm :: Term -> Bool
138 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
139 isFullyEvaluatedTerm Prim {} = True
140 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
141 isFullyEvaluatedTerm _ = False
143 instance Outputable (Term) where
144 ppr = head . cPprTerm cPprTermBase
146 -------------------------------------------------------------------------
147 -- Runtime Closure Datatype and functions for retrieving closure related stuff
148 -------------------------------------------------------------------------
149 data ClosureType = Constr
160 data Closure = Closure { tipe :: ClosureType
162 , infoTable :: StgInfoTable
163 , ptrs :: Array Int HValue
167 instance Outputable ClosureType where
170 #include "../includes/ClosureTypes.h"
172 aP_CODE, pAP_CODE :: Int
178 getClosureData :: a -> IO Closure
180 case unpackClosure# a of
181 (# iptr, ptrs, nptrs #) -> do
182 itbl <- peek (Ptr iptr)
183 let tipe = readCType (BCI.tipe itbl)
184 elems = fromIntegral (BCI.ptrs itbl)
185 ptrsList = Array 0 (elems - 1) elems ptrs
186 nptrs_data = [W# (indexWordArray# nptrs i)
187 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
188 ASSERT(elems >= 0) return ()
190 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
192 readCType :: Integral a => a -> ClosureType
194 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
195 | i >= FUN && i <= FUN_STATIC = Fun
196 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
197 | i == THUNK_SELECTOR = ThunkSelector
198 | i == BLACKHOLE = Blackhole
199 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
200 | fromIntegral i == aP_CODE = AP
202 | fromIntegral i == pAP_CODE = PAP
203 | otherwise = Other (fromIntegral i)
205 isConstr, isIndirection, isThunk :: ClosureType -> Bool
206 isConstr Constr = True
209 isIndirection (Indirection _) = True
210 --isIndirection ThunkSelector = True
211 isIndirection _ = False
213 isThunk (Thunk _) = True
214 isThunk ThunkSelector = True
218 isFullyEvaluated :: a -> IO Bool
219 isFullyEvaluated a = do
220 closure <- getClosureData a
222 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
223 return$ and are_subs_evaluated
225 where amapM f = sequence . amap' f
227 amap' :: (t -> b) -> Array Int t -> [b]
228 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
229 where g (I# i#) = case indexArray# arr# i# of
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)
244 isPointed :: Type -> Bool
245 isPointed t | Just (t, _) <- splitTyConApp_maybe t
246 = not$ isUnliftedTypeKind (tyConKind t)
249 extractUnboxed :: [Type] -> Closure -> [[Word]]
250 extractUnboxed tt clos = go tt (nonPtrs clos)
252 | Just (tycon,_) <- splitTyConApp_maybe t
253 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
254 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
257 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
260 sizeofTyCon :: TyCon -> Int
261 sizeofTyCon = sizeofPrimRep . tyConPrimRep
263 -----------------------------------
264 -- * Traversals for Terms
265 -----------------------------------
266 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
268 data TermFold a = TermFold { fTerm :: TermProcessor a a
269 , fPrim :: Type -> [Word] -> a
270 , fSuspension :: ClosureType -> Maybe Type -> HValue
272 , fNewtypeWrap :: Type -> Either String DataCon
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)
282 idTermFold :: TermFold Term
283 idTermFold = TermFold {
286 fSuspension = Suspension,
287 fNewtypeWrap = NewtypeWrap
289 idTermFoldM :: Monad m => TermFold (m Term)
290 idTermFoldM = TermFold {
291 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
292 fPrim = (return.). Prim,
293 fSuspension = (((return.).).). Suspension,
294 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t
297 mapTermType :: (Type -> Type) -> Term -> Term
298 mapTermType f = foldTerm idTermFold {
299 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
300 fSuspension = \ct mb_ty hval n ->
301 Suspension ct (fmap f mb_ty) hval n,
302 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t}
304 termTyVars :: Term -> TyVarSet
305 termTyVars = foldTerm TermFold {
306 fTerm = \ty _ _ tt ->
307 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
308 fSuspension = \_ mb_ty _ _ ->
309 maybe emptyVarEnv tyVarsOfType mb_ty,
310 fPrim = \ _ _ -> emptyVarEnv,
311 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t}
312 where concatVarEnv = foldr plusVarEnv emptyVarEnv
314 ----------------------------------
315 -- Pretty printing of terms
316 ----------------------------------
318 app_prec,cons_prec ::Int
320 cons_prec = 5 -- TODO Extract this info from GHC itself
322 pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
323 pprTerm y p t | Just doc <- pprTermM y p t = doc
324 pprTerm _ _ _ = panic "pprTerm"
326 pprTermM, pprNewtypeWrap :: Monad m =>
327 (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
328 pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
329 tt_docs <- mapM (y app_prec) tt
330 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
332 pprTermM y p Term{dc=Right dc, subTerms=tt}
333 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
334 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
335 <+> hsep (map (pprTerm1 True) tt)
336 -} -- TODO Printing infix constructors properly
337 | null tt = return$ ppr dc
339 tt_docs <- mapM (y app_prec) tt
340 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
342 pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
344 pprTermM _ _ t = pprTermM1 t
346 pprTermM1 :: Monad m => Term -> m SDoc
347 pprTermM1 Prim{value=words, ty=ty} =
348 return$ text$ repPrim (tyConAppTyCon ty) words
349 pprTermM1 Term{} = panic "pprTermM1 - unreachable"
350 pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
351 pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
352 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
353 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
354 pprTermM1 _ = panic "pprTermM1"
356 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
357 | Just (tc,_) <- splitNewTyConApp_maybe ty
358 , ASSERT(isNewTyCon tc) True
359 , Just new_dc <- maybeTyConSingleCon tc = do
361 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
362 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
364 -------------------------------------------------------
365 -- Custom Term Pretty Printers
366 -------------------------------------------------------
368 -- We can want to customize the representation of a
369 -- term depending on its type.
370 -- However, note that custom printers have to work with
371 -- type representations, instead of directly with types.
372 -- We cannot use type classes here, unless we employ some
373 -- typerep trickery (e.g. Weirich's RepLib tricks),
374 -- which I didn't. Therefore, this code replicates a lot
375 -- of what type classes provide for free.
377 -- Concretely a custom term printer takes an explicit
378 -- recursion knot, and produces a list of Term Processors,
379 -- which additionally need a precedence value to
380 -- either produce a SDoc or fail (and they do this in some monad m).
382 type Precedence = Int
383 type RecursionKnot m = Precedence -> Term -> m SDoc
384 type CustomTermPrinter m = RecursionKnot m
385 -> [Precedence -> Term -> (m (Maybe SDoc))]
387 -- Takes a list of custom printers with a explicit recursion knot and a term,
388 -- and returns the output of the first succesful printer, or the default printer
389 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
390 cPprTerm printers_ = go 0 where
391 printers = printers_ go
392 go prec t | isTerm t || isNewtypeWrap t = do
393 let default_ = Just `liftM` pprTermM go prec t
394 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
395 Just doc <- firstJustM mb_customDocs
396 return$ cparen (prec>app_prec+1) doc
399 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
400 firstJustM [] = return Nothing
402 -- Default set of custom printers. Note that the recursion knot is explicit
403 cPprTermBase :: Monad m => CustomTermPrinter m
405 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
408 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
409 (\ p Term{subTerms=[h,t]} -> doList p h t)
410 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
411 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
412 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
413 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
414 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
416 where ifTerm pred f prec t@Term{}
417 | pred t = Just `liftM` f prec t
418 ifTerm _ _ _ _ = return Nothing
420 isIntegerTy ty = fromMaybe False $ do
421 (tc,_) <- splitTyConApp_maybe ty
422 return (tyConName tc == integerTyConName)
424 isTupleTy ty = fromMaybe False $ do
425 (tc,_) <- splitTyConApp_maybe ty
426 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
428 isTyCon a_tc ty = fromMaybe False $ do
429 (tc,_) <- splitTyConApp_maybe ty
432 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
434 --TODO pprinting of list terms is not lazy
436 let elems = h : getListTerms t
437 isConsLast = termType(last elems) /= termType h
438 print_elems <- mapM (y cons_prec) elems
439 return$ if isConsLast
440 then cparen (p >= cons_prec)
442 . punctuate (space<>colon)
444 else brackets (hcat$ punctuate comma print_elems)
446 where Just a /= Just b = not (a `coreEqType` b)
448 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
449 getListTerms Term{subTerms=[]} = []
450 getListTerms t@Suspension{} = [t]
451 getListTerms t = pprPanic "getListTerms" (ppr t)
454 repPrim :: TyCon -> [Word] -> String
455 repPrim t = rep where
457 | t == charPrimTyCon = show (build x :: Char)
458 | t == intPrimTyCon = show (build x :: Int)
459 | t == wordPrimTyCon = show (build x :: Word)
460 | t == floatPrimTyCon = show (build x :: Float)
461 | t == doublePrimTyCon = show (build x :: Double)
462 | t == int32PrimTyCon = show (build x :: Int32)
463 | t == word32PrimTyCon = show (build x :: Word32)
464 | t == int64PrimTyCon = show (build x :: Int64)
465 | t == word64PrimTyCon = show (build x :: Word64)
466 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
467 | t == stablePtrPrimTyCon = "<stablePtr>"
468 | t == stableNamePrimTyCon = "<stableName>"
469 | t == statePrimTyCon = "<statethread>"
470 | t == realWorldTyCon = "<realworld>"
471 | t == threadIdPrimTyCon = "<ThreadId>"
472 | t == weakPrimTyCon = "<Weak>"
473 | t == arrayPrimTyCon = "<array>"
474 | t == byteArrayPrimTyCon = "<bytearray>"
475 | t == mutableArrayPrimTyCon = "<mutableArray>"
476 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
477 | t == mutVarPrimTyCon= "<mutVar>"
478 | t == mVarPrimTyCon = "<mVar>"
479 | t == tVarPrimTyCon = "<tVar>"
480 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
481 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
482 -- This ^^^ relies on the representation of Haskell heap values being
483 -- the same as in a C array.
485 -----------------------------------
486 -- Type Reconstruction
487 -----------------------------------
489 Type Reconstruction is type inference done on heap closures.
490 The algorithm walks the heap generating a set of equations, which
491 are solved with syntactic unification.
492 A type reconstruction equation looks like:
494 <datacon reptype> = <actual heap contents>
496 The full equation set is generated by traversing all the subterms, starting
499 The only difficult part is that newtypes are only found in the lhs of equations.
500 Right hand sides are missing them. We can either (a) drop them from the lhs, or
501 (b) reconstruct them in the rhs when possible.
503 The function congruenceNewtypes takes a shot at (b)
506 -- The Type Reconstruction monad
509 runTR :: HscEnv -> TR a -> IO a
511 mb_term <- runTR_maybe hsc_env c
513 Nothing -> panic "Can't unify"
516 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
517 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
519 traceTR :: SDoc -> TR ()
520 traceTR = liftTcM . traceTc
523 trIO = liftTcM . ioToTcRn
525 liftTcM :: TcM a -> TR a
528 newVar :: Kind -> TR TcType
529 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
531 -- | Returns the instantiated type scheme ty', and the substitution sigma
532 -- such that sigma(ty') = ty
533 instScheme :: Type -> TR (TcType, TvSubst)
534 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
535 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
536 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
538 -- Adds a constraint of the form t1 == t2
539 -- t1 is expected to come from walking the heap
540 -- t2 is expected to come from a datacon signature
541 -- Before unification, congruenceNewtypes needs to
543 addConstraint :: TcType -> TcType -> TR ()
544 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
545 >> return () -- TOMDO: what about the coercion?
546 -- we should consider family instances
548 -- Type & Term reconstruction
549 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
550 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
551 tv <- newVar argTypeKind
553 Nothing -> go bound tv tv hval
555 >>= return . expandNewtypes
556 Just ty | isMonomorphic ty -> go bound ty ty hval
558 >>= return . expandNewtypes
560 (ty',rev_subst) <- instScheme (sigmaType ty)
562 term <- go bound tv tv hval >>= zonkTerm
563 --restore original Tyvars
564 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
566 go bound _ _ _ | seq bound False = undefined
568 clos <- trIO $ getClosureData a
569 return (Suspension (tipe clos) (Just tv) a Nothing)
570 go bound tv ty a = do
571 let monomorphic = not(isTyVarTy tv)
572 -- This ^^^ is a convention. The ancestor tests for
573 -- monomorphism and passes a type instead of a tv
574 clos <- trIO $ getClosureData a
576 -- Thunks we may want to force
577 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
578 -- force blackholes, because it would almost certainly result in deadlock,
579 -- and showing the '_' is more useful.
580 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
581 -- We always follow indirections
582 Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
583 -- The interesting case
585 Right dcname <- dataConInfoPtrToName (infoPtr clos)
586 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
588 Nothing -> do -- This can happen for private constructors compiled -O0
589 -- where the .hi descriptor does not export them
590 -- In such case, we return a best approximation:
591 -- ignore the unpointed args, and recover the pointeds
592 -- This preserves laziness, and should be safe.
593 let tag = showSDoc (ppr dcname)
594 vars <- replicateM (length$ elems$ ptrs clos)
595 (newVar (liftedTypeKind))
596 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
597 | (i, tv) <- zip [0..] vars]
598 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
600 let extra_args = length(dataConRepArgTys dc) -
601 length(dataConOrigArgTys dc)
602 subTtypes = matchSubTypes dc ty
603 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
604 subTermTvs <- sequence
605 [ if isMonomorphic t then return t
607 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
608 -- It is vital for newtype reconstruction that the unification step
609 -- is done right here, _before_ the subterms are RTTI reconstructed
610 when (not monomorphic) $ do
611 let myType = mkFunTys (reOrderTerms subTermTvs
615 (signatureType,_) <- instScheme(dataConRepType dc)
616 addConstraint myType signatureType
617 subTermsP <- sequence $ drop extra_args
618 -- ^^^ all extra arguments are pointed
619 [ appArr (go (pred bound) tv t) (ptrs clos) i
620 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
621 let unboxeds = extractUnboxed subTtypesNP clos
622 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
623 subTerms = reOrderTerms subTermsP subTermsNP
624 (drop extra_args subTtypes)
625 return (Term tv (Right dc) a subTerms)
626 -- The otherwise case: can be a Thunk,AP,PAP,etc.
628 return (Suspension tipe_clos (Just tv) a Nothing)
631 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
632 -- assumption: ^^^ looks through newtypes
633 , isVanillaDataCon dc --TODO non-vanilla case
634 = dataConInstArgTys dc ty_args
635 | otherwise = dataConRepArgTys dc
637 -- This is used to put together pointed and nonpointed subterms in the
639 reOrderTerms _ _ [] = []
640 reOrderTerms pointed unpointed (ty:tys)
641 | isPointed ty = ASSERT2(not(null pointed)
642 , ptext SLIT("reOrderTerms") $$
643 (ppr pointed $$ ppr unpointed))
644 head pointed : reOrderTerms (tail pointed) unpointed tys
645 | otherwise = ASSERT2(not(null unpointed)
646 , ptext SLIT("reOrderTerms") $$
647 (ppr pointed $$ ppr unpointed))
648 head unpointed : reOrderTerms pointed (tail unpointed) tys
650 expandNewtypes t@Term{ ty=ty, subTerms=tt }
651 | Just (tc, args) <- splitNewTyConApp_maybe ty
653 , wrapped_type <- newTyConInstRhs tc args
654 , Just dc <- maybeTyConSingleCon tc
655 , t' <- expandNewtypes t{ ty = wrapped_type
656 , subTerms = map expandNewtypes tt }
657 = NewtypeWrap ty (Right dc) t'
659 | otherwise = t{ subTerms = map expandNewtypes tt }
664 -- Fast, breadth-first Type reconstruction
665 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
666 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
667 tv <- newVar argTypeKind
669 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
671 (Seq.singleton (tv, hval))
673 zonkTcType tv -- TODO untested!
674 Just ty | isMonomorphic ty -> return ty
676 (ty',rev_subst) <- instScheme (sigmaType ty)
678 search (isMonomorphic `fmap` zonkTcType tv)
680 (Seq.singleton (tv, hval))
682 substTy rev_subst `fmap` zonkTcType tv
684 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
685 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
686 int max_depth <> text " steps")
687 search stop expand l d =
690 x :< xx -> unlessM stop $ do
692 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
694 -- returns unification tasks,since we are going to want a breadth-first search
695 go :: Type -> HValue -> TR [(Type, HValue)]
697 clos <- trIO $ getClosureData a
699 Indirection _ -> go tv $! (ptrs clos ! 0)
701 Right dcname <- dataConInfoPtrToName (infoPtr clos)
702 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
705 -- TODO: Check this case
706 forM [0..length (elems $ ptrs clos)] $ \i -> do
707 tv <- newVar liftedTypeKind
708 return$ appArr (\e->(tv,e)) (ptrs clos) i
711 let extra_args = length(dataConRepArgTys dc) -
712 length(dataConOrigArgTys dc)
713 subTtypes <- mapMif (not . isMonomorphic)
714 (\t -> newVar (typeKind t))
715 (dataConRepArgTys dc)
717 -- It is vital for newtype reconstruction that the unification step
718 -- is done right here, _before_ the subterms are RTTI reconstructed
719 let myType = mkFunTys subTtypes tv
720 (signatureType,_) <- instScheme(dataConRepType dc)
721 addConstraint myType signatureType
722 return $ [ appArr (\e->(t,e)) (ptrs clos) i
723 | (i,t) <- drop extra_args $
724 zip [0..] (filter isPointed subTtypes)]
727 -- This helper computes the difference between a base type t and the
728 -- improved rtti_t computed by RTTI
729 -- The main difference between RTTI types and their normal counterparts
730 -- is that the former are _not_ polymorphic, thus polymorphism must
731 -- be stripped. Syntactically, forall's must be stripped
732 computeRTTIsubst :: Type -> Type -> Maybe TvSubst
733 computeRTTIsubst ty rtti_ty =
734 -- In addition, we strip newtypes too, since the reconstructed type might
735 -- not have recovered them all
736 tcUnifyTys (const BindMe)
737 [repType' $ dropForAlls$ ty]
739 -- TODO stripping newtypes shouldn't be necessary, test
742 -- Dealing with newtypes
744 A parallel fold over two Type values,
745 compensating for missing newtypes on both sides.
746 This is necessary because newtypes are not present
747 in runtime, but since sometimes there is evidence
748 available we do our best to reconstruct them.
749 Evidence can come from DataCon signatures or
750 from compile-time type inference.
751 I am using the words congruence and rewriting
752 because what we are doing here is an approximation
753 of unification modulo a set of equations, which would
754 come from newtype definitions. These should be the
755 equality coercions seen in System Fc. Rewriting
756 is performed, taking those equations as rules,
757 before launching unification.
759 It doesn't make sense to rewrite everywhere,
760 or we would end up with all newtypes. So we rewrite
761 only in presence of evidence.
762 The lhs comes from the heap structure of ptrs,nptrs.
763 The rhs comes from a DataCon type signature.
764 Rewriting in the rhs is restricted to the result type.
766 Note that it is very tricky to make this 'rewriting'
767 work with the unification implemented by TcM, where
768 substitutions are 'inlined'. The order in which
769 constraints are unified is vital for this.
770 This is a simple form of residuation, the technique of
771 delaying unification steps until enough information
774 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
775 congruenceNewtypes lhs rhs
776 -- TyVar lhs inductive case
777 | Just tv <- getTyVar_maybe lhs
778 = recoverTc (return (lhs,rhs)) $ do
779 Indirect ty_v <- readMetaTyVar tv
780 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
782 -- FunTy inductive case
783 | Just (l1,l2) <- splitFunTy_maybe lhs
784 , Just (r1,r2) <- splitFunTy_maybe rhs
785 = do (l2',r2') <- congruenceNewtypes l2 r2
786 (l1',r1') <- congruenceNewtypes l1 r1
787 return (mkFunTy l1' l2', mkFunTy r1' r2')
788 -- TyconApp Inductive case; this is the interesting bit.
789 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
790 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
792 = do rhs' <- upgrade tycon_l rhs
795 | otherwise = return (lhs,rhs)
797 where upgrade :: TyCon -> Type -> TR Type
799 | not (isNewTyCon new_tycon) = return ty
801 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
802 let ty' = mkTyConApp new_tycon vars
803 liftTcM (unifyType ty (repType ty'))
804 -- assumes that reptype doesn't ^^^^ touch tyconApp args
808 --------------------------------------------------------------------------------
809 -- Semantically different to recoverM in TcRnMonad
810 -- recoverM retains the errors in the first action,
811 -- whereas recoverTc here does not
812 recoverTc :: TcM a -> TcM a -> TcM a
813 recoverTc recover thing = do
814 (_,mb_res) <- tryTcErrs thing
817 Just res -> return res
819 isMonomorphic :: Type -> Bool
820 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
821 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
823 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
824 mapMif pred f xx = sequence $ mapMif_ pred f xx
827 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
829 unlessM :: Monad m => m Bool -> m () -> m ()
830 unlessM condM acc = condM >>= \c -> unless c acc
832 -- Strict application of f at index i
833 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
834 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
835 = ASSERT (i < length(elems a))
836 case indexArray# ptrs# i# of
839 zonkTerm :: Term -> TcM Term
840 zonkTerm = foldTerm idTermFoldM {
841 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
842 zonkTcType ty >>= \ty' ->
843 return (Term ty' dc v tt)
844 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
845 return (Suspension ct ty v b)
846 ,fNewtypeWrap= \ty dc t ->
847 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
850 -- Is this defined elsewhere?
851 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
852 sigmaType :: Type -> Type
853 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty