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
43 #include "HsVersions.h"
45 import ByteCodeItbls ( StgInfoTable )
46 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
47 import HscTypes ( HscEnv )
74 import GHC.Arr ( Array(..) )
76 import GHC.IOBase ( IO(IO) )
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 ---------------------------------------------
96 data Term = Term { ty :: Type
97 , dc :: Either String DataCon
98 -- Carries a text representation if the datacon is
99 -- not exported by the .hi file, which is the case
100 -- for private constructors in -O0 compiled libraries
102 , subTerms :: [Term] }
107 | Suspension { ctype :: ClosureType
110 , bound_to :: Maybe Name -- Useful for printing
112 | NewtypeWrap{ ty :: Type
113 , dc :: Either String DataCon
114 , wrapped_term :: Term }
115 | RefWrap { ty :: Type
116 , wrapped_term :: Term }
118 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
121 isSuspension Suspension{} = True
122 isSuspension _ = False
125 isNewtypeWrap NewtypeWrap{} = True
126 isNewtypeWrap _ = False
128 termType :: Term -> Type
131 isFullyEvaluatedTerm :: Term -> Bool
132 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
133 isFullyEvaluatedTerm Prim {} = True
134 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
135 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
136 isFullyEvaluatedTerm _ = False
138 instance Outputable (Term) where
139 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
140 | otherwise = panic "Outputable Term instance"
142 -------------------------------------------------------------------------
143 -- Runtime Closure Datatype and functions for retrieving closure related stuff
144 -------------------------------------------------------------------------
145 data ClosureType = Constr
157 data Closure = Closure { tipe :: ClosureType
159 , infoTable :: StgInfoTable
160 , ptrs :: Array Int HValue
164 instance Outputable ClosureType where
167 #include "../includes/ClosureTypes.h"
169 aP_CODE, pAP_CODE :: Int
175 getClosureData :: a -> IO Closure
177 case unpackClosure# a of
178 (# iptr, ptrs, nptrs #) -> do
179 #ifndef GHCI_TABLES_NEXT_TO_CODE
180 -- the info pointer we get back from unpackClosure# is to the
181 -- beginning of the standard info table, but the Storable instance
182 -- for info tables takes into account the extra entry pointer
183 -- when !tablesNextToCode, so we must adjust here:
184 itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
186 itbl <- peek (Ptr iptr)
188 let tipe = readCType (BCI.tipe itbl)
189 elems = fromIntegral (BCI.ptrs itbl)
190 ptrsList = Array 0 (elems - 1) elems ptrs
191 nptrs_data = [W# (indexWordArray# nptrs i)
192 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
193 ASSERT(elems >= 0) return ()
195 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
197 readCType :: Integral a => a -> ClosureType
199 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
200 | i >= FUN && i <= FUN_STATIC = Fun
201 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
202 | i == THUNK_SELECTOR = ThunkSelector
203 | i == BLACKHOLE = Blackhole
204 | i >= IND && i <= IND_STATIC = Indirection i'
207 | i' == pAP_CODE = PAP
208 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
209 | otherwise = Other i'
210 where i' = fromIntegral i
212 isConstr, isIndirection, isThunk :: ClosureType -> Bool
213 isConstr Constr = True
216 isIndirection (Indirection _) = True
217 isIndirection _ = False
219 isThunk (Thunk _) = True
220 isThunk ThunkSelector = True
224 isFullyEvaluated :: a -> IO Bool
225 isFullyEvaluated a = do
226 closure <- getClosureData a
228 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
229 return$ and are_subs_evaluated
231 where amapM f = sequence . amap' f
233 amap' :: (t -> b) -> Array Int t -> [b]
234 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
235 where g (I# i#) = case indexArray# arr# i# of
238 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
240 unsafeDeepSeq :: a -> b -> b
241 unsafeDeepSeq = unsafeDeepSeq1 2
242 where unsafeDeepSeq1 0 a b = seq a $! b
243 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
244 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
245 -- | unsafePerformIO (isFullyEvaluated a) = b
246 | otherwise = case unsafePerformIO (getClosureData a) of
247 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
248 where tipe = unsafePerformIO (getClosureType a)
250 isPointed :: Type -> Bool
251 isPointed t | Just (t, _) <- splitTyConApp_maybe t
252 = not$ isUnliftedTypeKind (tyConKind t)
255 extractUnboxed :: [Type] -> Closure -> [[Word]]
256 extractUnboxed tt clos = go tt (nonPtrs clos)
258 | Just (tycon,_) <- splitTyConApp_maybe t
259 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
260 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
263 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
266 sizeofTyCon :: TyCon -> Int
267 sizeofTyCon = sizeofPrimRep . tyConPrimRep
269 -----------------------------------
270 -- * Traversals for Terms
271 -----------------------------------
272 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
274 data TermFold a = TermFold { fTerm :: TermProcessor a a
275 , fPrim :: Type -> [Word] -> a
276 , fSuspension :: ClosureType -> Type -> HValue
278 , fNewtypeWrap :: Type -> Either String DataCon
280 , fRefWrap :: Type -> a -> a
283 foldTerm :: TermFold a -> Term -> a
284 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
285 foldTerm tf (Prim ty v ) = fPrim tf ty v
286 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
287 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
288 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
290 idTermFold :: TermFold Term
291 idTermFold = TermFold {
294 fSuspension = Suspension,
295 fNewtypeWrap = NewtypeWrap,
298 idTermFoldM :: Monad m => TermFold (m Term)
299 idTermFoldM = TermFold {
300 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
301 fPrim = (return.). Prim,
302 fSuspension = (((return.).).). Suspension,
303 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
304 fRefWrap = \ty t -> RefWrap ty `liftM` t
307 mapTermType :: (Type -> Type) -> Term -> Term
308 mapTermType f = foldTerm idTermFold {
309 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
310 fSuspension = \ct ty hval n ->
311 Suspension ct (f ty) hval n,
312 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
313 fRefWrap = \ty t -> RefWrap (f ty) t}
315 termTyVars :: Term -> TyVarSet
316 termTyVars = foldTerm TermFold {
317 fTerm = \ty _ _ tt ->
318 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
319 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
320 fPrim = \ _ _ -> emptyVarEnv,
321 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
322 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
323 where concatVarEnv = foldr plusVarEnv emptyVarEnv
325 ----------------------------------
326 -- Pretty printing of terms
327 ----------------------------------
329 type Precedence = Int
330 type TermPrinter = Precedence -> Term -> SDoc
331 type TermPrinterM m = Precedence -> Term -> m SDoc
333 app_prec,cons_prec, max_prec ::Int
336 cons_prec = 5 -- TODO Extract this info from GHC itself
338 pprTerm :: TermPrinter -> TermPrinter
339 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
340 pprTerm _ _ _ = panic "pprTerm"
342 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
343 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
345 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
346 tt_docs <- mapM (y app_prec) tt
347 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
349 ppr_termM y p Term{dc=Right dc, subTerms=tt}
350 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
351 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
352 <+> hsep (map (ppr_term1 True) tt)
353 -} -- TODO Printing infix constructors properly
354 | null tt = return$ ppr dc
356 tt_docs <- mapM (y app_prec) tt
357 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
359 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
360 ppr_termM y p RefWrap{wrapped_term=t} = do
361 contents <- y app_prec t
362 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
363 -- The constructor name is wired in here ^^^ for the sake of simplicity.
364 -- I don't think mutvars are going to change in a near future.
365 -- In any case this is solely a presentation matter: MutVar# is
366 -- a datatype with no constructors, implemented by the RTS
367 -- (hence there is no way to obtain a datacon and print it).
368 ppr_termM _ _ t = ppr_termM1 t
371 ppr_termM1 :: Monad m => Term -> m SDoc
372 ppr_termM1 Prim{value=words, ty=ty} =
373 return$ text$ repPrim (tyConAppTyCon ty) words
374 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
375 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
376 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
377 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
378 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
379 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
380 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
382 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
383 | Just (tc,_) <- splitNewTyConApp_maybe ty
384 , ASSERT(isNewTyCon tc) True
385 , Just new_dc <- maybeTyConSingleCon tc = do
386 real_term <- y max_prec t
387 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
388 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
390 -------------------------------------------------------
391 -- Custom Term Pretty Printers
392 -------------------------------------------------------
394 -- We can want to customize the representation of a
395 -- term depending on its type.
396 -- However, note that custom printers have to work with
397 -- type representations, instead of directly with types.
398 -- We cannot use type classes here, unless we employ some
399 -- typerep trickery (e.g. Weirich's RepLib tricks),
400 -- which I didn't. Therefore, this code replicates a lot
401 -- of what type classes provide for free.
403 type CustomTermPrinter m = TermPrinterM m
404 -> [Precedence -> Term -> (m (Maybe SDoc))]
406 -- | Takes a list of custom printers with a explicit recursion knot and a term,
407 -- and returns the output of the first succesful printer, or the default printer
408 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
409 cPprTerm printers_ = go 0 where
410 printers = printers_ go
412 let default_ = Just `liftM` pprTermM go prec t
413 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
414 Just doc <- firstJustM mb_customDocs
415 return$ cparen (prec>app_prec+1) doc
417 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
418 firstJustM [] = return Nothing
420 -- Default set of custom printers. Note that the recursion knot is explicit
421 cPprTermBase :: Monad m => CustomTermPrinter m
423 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
426 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
427 (\ p Term{subTerms=[h,t]} -> doList p h t)
428 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
429 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
430 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
431 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
432 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
434 where ifTerm pred f prec t@Term{}
435 | pred t = Just `liftM` f prec t
436 ifTerm _ _ _ _ = return Nothing
438 isIntegerTy ty = fromMaybe False $ do
439 (tc,_) <- splitTyConApp_maybe ty
440 return (tyConName tc == integerTyConName)
442 isTupleTy ty = fromMaybe False $ do
443 (tc,_) <- splitTyConApp_maybe ty
444 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
446 isTyCon a_tc ty = fromMaybe False $ do
447 (tc,_) <- splitTyConApp_maybe ty
450 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
452 --Note pprinting of list terms is not lazy
454 let elems = h : getListTerms t
455 isConsLast = not(termType(last elems) `coreEqType` termType h)
456 print_elems <- mapM (y cons_prec) elems
457 return$ if isConsLast
458 then cparen (p >= cons_prec)
460 . punctuate (space<>colon)
462 else brackets (pprDeeperList fcat$
463 punctuate comma print_elems)
465 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
466 getListTerms Term{subTerms=[]} = []
467 getListTerms t@Suspension{} = [t]
468 getListTerms t = pprPanic "getListTerms" (ppr t)
471 repPrim :: TyCon -> [Word] -> String
472 repPrim t = rep where
474 | t == charPrimTyCon = show (build x :: Char)
475 | t == intPrimTyCon = show (build x :: Int)
476 | t == wordPrimTyCon = show (build x :: Word)
477 | t == floatPrimTyCon = show (build x :: Float)
478 | t == doublePrimTyCon = show (build x :: Double)
479 | t == int32PrimTyCon = show (build x :: Int32)
480 | t == word32PrimTyCon = show (build x :: Word32)
481 | t == int64PrimTyCon = show (build x :: Int64)
482 | t == word64PrimTyCon = show (build x :: Word64)
483 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
484 | t == stablePtrPrimTyCon = "<stablePtr>"
485 | t == stableNamePrimTyCon = "<stableName>"
486 | t == statePrimTyCon = "<statethread>"
487 | t == realWorldTyCon = "<realworld>"
488 | t == threadIdPrimTyCon = "<ThreadId>"
489 | t == weakPrimTyCon = "<Weak>"
490 | t == arrayPrimTyCon = "<array>"
491 | t == byteArrayPrimTyCon = "<bytearray>"
492 | t == mutableArrayPrimTyCon = "<mutableArray>"
493 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
494 | t == mutVarPrimTyCon= "<mutVar>"
495 | t == mVarPrimTyCon = "<mVar>"
496 | t == tVarPrimTyCon = "<tVar>"
497 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
498 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
499 -- This ^^^ relies on the representation of Haskell heap values being
500 -- the same as in a C array.
502 -----------------------------------
503 -- Type Reconstruction
504 -----------------------------------
506 Type Reconstruction is type inference done on heap closures.
507 The algorithm walks the heap generating a set of equations, which
508 are solved with syntactic unification.
509 A type reconstruction equation looks like:
511 <datacon reptype> = <actual heap contents>
513 The full equation set is generated by traversing all the subterms, starting
516 The only difficult part is that newtypes are only found in the lhs of equations.
517 Right hand sides are missing them. We can either (a) drop them from the lhs, or
518 (b) reconstruct them in the rhs when possible.
520 The function congruenceNewtypes takes a shot at (b)
523 -- The Type Reconstruction monad
526 runTR :: HscEnv -> TR a -> IO a
528 mb_term <- runTR_maybe hsc_env c
530 Nothing -> panic "Can't unify"
533 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
534 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
536 traceTR :: SDoc -> TR ()
537 traceTR = liftTcM . traceTc
540 trIO = liftTcM . liftIO
542 liftTcM :: TcM a -> TR a
545 newVar :: Kind -> TR TcType
546 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
548 -- | Returns the instantiated type scheme ty', and the substitution sigma
549 -- such that sigma(ty') = ty
550 instScheme :: Type -> TR (TcType, TvSubst)
551 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
552 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
553 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
555 -- Adds a constraint of the form t1 == t2
556 -- t1 is expected to come from walking the heap
557 -- t2 is expected to come from a datacon signature
558 -- Before unification, congruenceNewtypes needs to
560 addConstraint :: TcType -> TcType -> TR ()
561 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
562 >> return () -- TOMDO: what about the coercion?
563 -- we should consider family instances
565 -- Type & Term reconstruction
566 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
567 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
568 tv <- newVar argTypeKind
570 Nothing -> go bound tv tv hval
572 >>= return . expandNewtypes
573 Just ty | isMonomorphic ty -> go bound ty ty hval
575 >>= return . expandNewtypes
577 (ty',rev_subst) <- instScheme (sigmaType ty)
579 term <- go bound tv tv hval >>= zonkTerm
580 --restore original Tyvars
581 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
583 go bound _ _ _ | seq bound False = undefined
585 clos <- trIO $ getClosureData a
586 return (Suspension (tipe clos) tv a Nothing)
587 go bound tv ty a = do
588 let monomorphic = not(isTyVarTy tv)
589 -- This ^^^ is a convention. The ancestor tests for
590 -- monomorphism and passes a type instead of a tv
591 clos <- trIO $ getClosureData a
593 -- Thunks we may want to force
594 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
595 -- force blackholes, because it would almost certainly result in deadlock,
596 -- and showing the '_' is more useful.
597 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
598 -- We always follow indirections
599 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
600 -- We also follow references
601 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
602 -- , tycon == mutVarPrimTyCon
604 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
605 tv' <- newVar liftedTypeKind
606 addConstraint tv (mkTyConApp tycon [world,tv'])
607 x <- go bound tv' ty_contents contents
608 return (RefWrap ty x)
610 -- The interesting case
612 Right dcname <- dataConInfoPtrToName (infoPtr clos)
613 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
615 Nothing -> do -- This can happen for private constructors compiled -O0
616 -- where the .hi descriptor does not export them
617 -- In such case, we return a best approximation:
618 -- ignore the unpointed args, and recover the pointeds
619 -- This preserves laziness, and should be safe.
620 let tag = showSDoc (ppr dcname)
621 vars <- replicateM (length$ elems$ ptrs clos)
622 (newVar (liftedTypeKind))
623 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
624 | (i, tv) <- zip [0..] vars]
625 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
627 let extra_args = length(dataConRepArgTys dc) -
628 length(dataConOrigArgTys dc)
629 subTtypes = matchSubTypes dc ty
630 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
631 subTermTvs <- sequence
632 [ if isMonomorphic t then return t
634 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
635 -- It is vital for newtype reconstruction that the unification step
636 -- is done right here, _before_ the subterms are RTTI reconstructed
637 when (not monomorphic) $ do
638 let myType = mkFunTys (reOrderTerms subTermTvs
642 (signatureType,_) <- instScheme(dataConRepType dc)
643 addConstraint myType signatureType
644 subTermsP <- sequence $ drop extra_args
645 -- ^^^ all extra arguments are pointed
646 [ appArr (go (pred bound) tv t) (ptrs clos) i
647 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
648 let unboxeds = extractUnboxed subTtypesNP clos
649 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
650 subTerms = reOrderTerms subTermsP subTermsNP
651 (drop extra_args subTtypes)
652 return (Term tv (Right dc) a subTerms)
653 -- The otherwise case: can be a Thunk,AP,PAP,etc.
655 return (Suspension tipe_clos tv a Nothing)
658 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
659 -- assumption: ^^^ looks through newtypes
660 , isVanillaDataCon dc --TODO non-vanilla case
661 = dataConInstArgTys dc ty_args
662 | otherwise = dataConRepArgTys dc
664 -- This is used to put together pointed and nonpointed subterms in the
666 reOrderTerms _ _ [] = []
667 reOrderTerms pointed unpointed (ty:tys)
668 | isPointed ty = ASSERT2(not(null pointed)
669 , ptext SLIT("reOrderTerms") $$
670 (ppr pointed $$ ppr unpointed))
671 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
672 | otherwise = ASSERT2(not(null unpointed)
673 , ptext SLIT("reOrderTerms") $$
674 (ppr pointed $$ ppr unpointed))
675 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
677 expandNewtypes t@Term{ ty=ty, subTerms=tt }
678 | Just (tc, args) <- splitNewTyConApp_maybe ty
680 , wrapped_type <- newTyConInstRhs tc args
681 , Just dc <- maybeTyConSingleCon tc
682 , t' <- expandNewtypes t{ ty = wrapped_type
683 , subTerms = map expandNewtypes tt }
684 = NewtypeWrap ty (Right dc) t'
686 | otherwise = t{ subTerms = map expandNewtypes tt }
691 -- Fast, breadth-first Type reconstruction
692 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
693 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
694 tv <- newVar argTypeKind
696 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
698 (Seq.singleton (tv, hval))
700 zonkTcType tv -- TODO untested!
701 Just ty | isMonomorphic ty -> return ty
703 (ty',rev_subst) <- instScheme (sigmaType ty)
705 search (isMonomorphic `fmap` zonkTcType tv)
707 (Seq.singleton (tv, hval))
709 substTy rev_subst `fmap` zonkTcType tv
711 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
712 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
713 int max_depth <> text " steps")
714 search stop expand l d =
717 x :< xx -> unlessM stop $ do
719 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
721 -- returns unification tasks,since we are going to want a breadth-first search
722 go :: Type -> HValue -> TR [(Type, HValue)]
724 clos <- trIO $ getClosureData a
726 Indirection _ -> go tv $! (ptrs clos ! 0)
728 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
729 tv' <- newVar liftedTypeKind
730 world <- newVar liftedTypeKind
731 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
732 -- x <- go tv' ty_contents contents
733 return [(tv', contents)]
735 Right dcname <- dataConInfoPtrToName (infoPtr clos)
736 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
739 -- TODO: Check this case
740 forM [0..length (elems $ ptrs clos)] $ \i -> do
741 tv <- newVar liftedTypeKind
742 return$ appArr (\e->(tv,e)) (ptrs clos) i
745 let extra_args = length(dataConRepArgTys dc) -
746 length(dataConOrigArgTys dc)
747 subTtypes <- mapMif (not . isMonomorphic)
748 (\t -> newVar (typeKind t))
749 (dataConRepArgTys dc)
751 -- It is vital for newtype reconstruction that the unification step
752 -- is done right here, _before_ the subterms are RTTI reconstructed
753 let myType = mkFunTys subTtypes tv
754 (signatureType,_) <- instScheme(dataConRepType dc)
755 addConstraint myType signatureType
756 return $ [ appArr (\e->(t,e)) (ptrs clos) i
757 | (i,t) <- drop extra_args $
758 zip [0..] (filter isPointed subTtypes)]
762 This helper computes the difference between a base type t and the
763 improved rtti_t computed by RTTI
764 The main difference between RTTI types and their normal counterparts
765 is that the former are _not_ polymorphic, thus polymorphism must
766 be stripped. Syntactically, forall's must be stripped.
767 We also remove predicates.
769 unifyRTTI :: Type -> Type -> TvSubst
770 unifyRTTI ty rtti_ty =
773 Nothing -> pprPanic "Failed to compute a RTTI substitution"
775 -- In addition, we strip newtypes too, since the reconstructed type might
776 -- not have recovered them all
777 -- TODO stripping newtypes shouldn't be necessary, test
778 where mb_subst = tcUnifyTys (const BindMe)
782 -- Dealing with newtypes
784 congruenceNewtypes does a parallel fold over two Type values,
785 compensating for missing newtypes on both sides.
786 This is necessary because newtypes are not present
787 in runtime, but sometimes there is evidence available.
788 Evidence can come from DataCon signatures or
789 from compile-time type inference.
790 What we are doing here is an approximation
791 of unification modulo a set of equations derived
792 from newtype definitions. These equations should be the
793 same as the equality coercions generated for newtypes
794 in System Fc. The idea is to perform a sort of rewriting,
795 taking those equations as rules, before launching unification.
797 The caller must ensure the following.
798 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
799 The 2nd type (rhs) comes from a DataCon type signature.
800 Rewriting (i.e. adding/removing a newtype wrapper) can happen
801 in both types, but in the rhs it is restricted to the result type.
803 Note that it is very tricky to make this 'rewriting'
804 work with the unification implemented by TcM, where
805 substitutions are operationally inlined. The order in which
806 constraints are unified is vital as we cannot modify
807 anything that has been touched by a previous unification step.
808 Therefore, congruenceNewtypes is sound only if the types
809 recovered by the RTTI mechanism are unified Top-Down.
811 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
812 congruenceNewtypes lhs rhs
813 -- TyVar lhs inductive case
814 | Just tv <- getTyVar_maybe lhs
815 = recoverTc (return (lhs,rhs)) $ do
816 Indirect ty_v <- readMetaTyVar tv
817 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
819 -- FunTy inductive case
820 | Just (l1,l2) <- splitFunTy_maybe lhs
821 , Just (r1,r2) <- splitFunTy_maybe rhs
822 = do (l2',r2') <- congruenceNewtypes l2 r2
823 (l1',r1') <- congruenceNewtypes l1 r1
824 return (mkFunTy l1' l2', mkFunTy r1' r2')
825 -- TyconApp Inductive case; this is the interesting bit.
826 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
827 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
829 = do rhs' <- upgrade tycon_l rhs
832 | otherwise = return (lhs,rhs)
834 where upgrade :: TyCon -> Type -> TR Type
836 | not (isNewTyCon new_tycon) = return ty
838 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
839 let ty' = mkTyConApp new_tycon vars
840 liftTcM (unifyType ty (repType ty'))
841 -- assumes that reptype doesn't ^^^^ touch tyconApp args
845 --------------------------------------------------------------------------------
846 -- Semantically different to recoverM in TcRnMonad
847 -- recoverM retains the errors in the first action,
848 -- whereas recoverTc here does not
849 recoverTc :: TcM a -> TcM a -> TcM a
850 recoverTc recover thing = do
851 (_,mb_res) <- tryTcErrs thing
854 Just res -> return res
856 isMonomorphic :: Type -> Bool
857 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
858 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
860 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
861 mapMif pred f xx = sequence $ mapMif_ pred f xx
864 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
866 unlessM :: Monad m => m Bool -> m () -> m ()
867 unlessM condM acc = condM >>= \c -> unless c acc
869 -- Strict application of f at index i
870 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
871 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
872 = ASSERT (i < length(elems a))
873 case indexArray# ptrs# i# of
876 zonkTerm :: Term -> TcM Term
877 zonkTerm = foldTerm idTermFoldM {
878 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
879 zonkTcType ty >>= \ty' ->
880 return (Term ty' dc v tt)
881 ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
882 return (Suspension ct ty v b)
883 ,fNewtypeWrap= \ty dc t ->
884 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
887 -- Is this defined elsewhere?
888 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
889 sigmaType :: Type -> Type
890 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty