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 )
53 import TcRnMonad ( TcM, initTc, ioToTcRn,
75 import GHC.Arr ( Array(..) )
81 import Data.Array.Base
83 import Data.List ( partition )
84 import qualified Data.Sequence as Seq
86 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
88 import System.IO.Unsafe
90 ---------------------------------------------
91 -- * A representation of semi evaluated Terms
92 ---------------------------------------------
97 data Term = Term { ty :: Type
98 , dc :: Either String DataCon
99 -- Carries a text representation if the datacon is
100 -- not exported by the .hi file, which is the case
101 -- for private constructors in -O0 compiled libraries
103 , subTerms :: [Term] }
108 | Suspension { ctype :: ClosureType
111 , bound_to :: Maybe Name -- Useful for printing
113 | NewtypeWrap{ ty :: Type
114 , dc :: Either String DataCon
115 , wrapped_term :: Term }
116 | RefWrap { ty :: Type
117 , wrapped_term :: Term }
119 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
122 isSuspension Suspension{} = True
123 isSuspension _ = False
126 isNewtypeWrap NewtypeWrap{} = True
127 isNewtypeWrap _ = False
129 termType :: Term -> Type
132 isFullyEvaluatedTerm :: Term -> Bool
133 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
134 isFullyEvaluatedTerm Prim {} = True
135 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
136 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
137 isFullyEvaluatedTerm _ = False
139 instance Outputable (Term) where
140 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
141 | otherwise = panic "Outputable Term instance"
143 -------------------------------------------------------------------------
144 -- Runtime Closure Datatype and functions for retrieving closure related stuff
145 -------------------------------------------------------------------------
146 data ClosureType = Constr
158 data Closure = Closure { tipe :: ClosureType
160 , infoTable :: StgInfoTable
161 , ptrs :: Array Int HValue
165 instance Outputable ClosureType where
168 #include "../includes/ClosureTypes.h"
170 aP_CODE, pAP_CODE :: Int
176 getClosureData :: a -> IO Closure
178 case unpackClosure# a of
179 (# iptr, ptrs, nptrs #) -> do
180 #ifndef GHCI_TABLES_NEXT_TO_CODE
181 -- the info pointer we get back from unpackClosure# is to the
182 -- beginning of the standard info table, but the Storable instance
183 -- for info tables takes into account the extra entry pointer
184 -- when !tablesNextToCode, so we must adjust here:
185 itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
187 itbl <- peek (Ptr iptr)
189 let tipe = readCType (BCI.tipe itbl)
190 elems = fromIntegral (BCI.ptrs itbl)
191 ptrsList = Array 0 (elems - 1) elems ptrs
192 nptrs_data = [W# (indexWordArray# nptrs i)
193 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
194 ASSERT(elems >= 0) return ()
196 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
198 readCType :: Integral a => a -> ClosureType
200 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
201 | i >= FUN && i <= FUN_STATIC = Fun
202 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
203 | i == THUNK_SELECTOR = ThunkSelector
204 | i == BLACKHOLE = Blackhole
205 | i >= IND && i <= IND_STATIC = Indirection i'
208 | i' == pAP_CODE = PAP
209 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
210 | otherwise = Other i'
211 where i' = fromIntegral i
213 isConstr, isIndirection, isThunk :: ClosureType -> Bool
214 isConstr Constr = True
217 isIndirection (Indirection _) = True
218 isIndirection _ = False
220 isThunk (Thunk _) = True
221 isThunk ThunkSelector = True
225 isFullyEvaluated :: a -> IO Bool
226 isFullyEvaluated a = do
227 closure <- getClosureData a
229 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
230 return$ and are_subs_evaluated
232 where amapM f = sequence . amap' f
234 amap' :: (t -> b) -> Array Int t -> [b]
235 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
236 where g (I# i#) = case indexArray# arr# i# of
239 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
241 unsafeDeepSeq :: a -> b -> b
242 unsafeDeepSeq = unsafeDeepSeq1 2
243 where unsafeDeepSeq1 0 a b = seq a $! b
244 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
245 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
246 -- | unsafePerformIO (isFullyEvaluated a) = b
247 | otherwise = case unsafePerformIO (getClosureData a) of
248 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
249 where tipe = unsafePerformIO (getClosureType a)
251 isPointed :: Type -> Bool
252 isPointed t | Just (t, _) <- splitTyConApp_maybe t
253 = not$ isUnliftedTypeKind (tyConKind t)
256 extractUnboxed :: [Type] -> Closure -> [[Word]]
257 extractUnboxed tt clos = go tt (nonPtrs clos)
259 | Just (tycon,_) <- splitTyConApp_maybe t
260 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
261 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
264 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
267 sizeofTyCon :: TyCon -> Int
268 sizeofTyCon = sizeofPrimRep . tyConPrimRep
270 -----------------------------------
271 -- * Traversals for Terms
272 -----------------------------------
273 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
275 data TermFold a = TermFold { fTerm :: TermProcessor a a
276 , fPrim :: Type -> [Word] -> a
277 , fSuspension :: ClosureType -> Type -> HValue
279 , fNewtypeWrap :: Type -> Either String DataCon
281 , fRefWrap :: Type -> a -> a
284 foldTerm :: TermFold a -> Term -> a
285 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
286 foldTerm tf (Prim ty v ) = fPrim tf ty v
287 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
288 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
289 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
291 idTermFold :: TermFold Term
292 idTermFold = TermFold {
295 fSuspension = Suspension,
296 fNewtypeWrap = NewtypeWrap,
299 idTermFoldM :: Monad m => TermFold (m Term)
300 idTermFoldM = TermFold {
301 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
302 fPrim = (return.). Prim,
303 fSuspension = (((return.).).). Suspension,
304 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
305 fRefWrap = \ty t -> RefWrap ty `liftM` t
308 mapTermType :: (Type -> Type) -> Term -> Term
309 mapTermType f = foldTerm idTermFold {
310 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
311 fSuspension = \ct ty hval n ->
312 Suspension ct (f ty) hval n,
313 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
314 fRefWrap = \ty t -> RefWrap (f ty) t}
316 termTyVars :: Term -> TyVarSet
317 termTyVars = foldTerm TermFold {
318 fTerm = \ty _ _ tt ->
319 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
320 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
321 fPrim = \ _ _ -> emptyVarEnv,
322 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
323 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
324 where concatVarEnv = foldr plusVarEnv emptyVarEnv
326 ----------------------------------
327 -- Pretty printing of terms
328 ----------------------------------
330 type Precedence = Int
331 type TermPrinter = Precedence -> Term -> SDoc
332 type TermPrinterM m = Precedence -> Term -> m SDoc
334 app_prec,cons_prec, max_prec ::Int
337 cons_prec = 5 -- TODO Extract this info from GHC itself
339 pprTerm :: TermPrinter -> TermPrinter
340 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
341 pprTerm _ _ _ = panic "pprTerm"
343 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
344 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
346 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
347 tt_docs <- mapM (y app_prec) tt
348 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
350 ppr_termM y p Term{dc=Right dc, subTerms=tt}
351 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
352 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
353 <+> hsep (map (ppr_term1 True) tt)
354 -} -- TODO Printing infix constructors properly
355 | null tt = return$ ppr dc
357 tt_docs <- mapM (y app_prec) tt
358 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
360 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
361 ppr_termM y p RefWrap{wrapped_term=t} = do
362 contents <- y app_prec t
363 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
364 -- The constructor name is wired in here ^^^ for the sake of simplicity.
365 -- I don't think mutvars are going to change in a near future.
366 -- In any case this is solely a presentation matter: MutVar# is
367 -- a datatype with no constructors, implemented by the RTS
368 -- (hence there is no way to obtain a datacon and print it).
369 ppr_termM _ _ t = ppr_termM1 t
372 ppr_termM1 :: Monad m => Term -> m SDoc
373 ppr_termM1 Prim{value=words, ty=ty} =
374 return$ text$ repPrim (tyConAppTyCon ty) words
375 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
376 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
377 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
378 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
379 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
380 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
381 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
383 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
384 | Just (tc,_) <- splitNewTyConApp_maybe ty
385 , ASSERT(isNewTyCon tc) True
386 , Just new_dc <- maybeTyConSingleCon tc = do
387 real_term <- y max_prec t
388 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
389 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
391 -------------------------------------------------------
392 -- Custom Term Pretty Printers
393 -------------------------------------------------------
395 -- We can want to customize the representation of a
396 -- term depending on its type.
397 -- However, note that custom printers have to work with
398 -- type representations, instead of directly with types.
399 -- We cannot use type classes here, unless we employ some
400 -- typerep trickery (e.g. Weirich's RepLib tricks),
401 -- which I didn't. Therefore, this code replicates a lot
402 -- of what type classes provide for free.
404 type CustomTermPrinter m = TermPrinterM m
405 -> [Precedence -> Term -> (m (Maybe SDoc))]
407 -- | Takes a list of custom printers with a explicit recursion knot and a term,
408 -- and returns the output of the first succesful printer, or the default printer
409 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
410 cPprTerm printers_ = go 0 where
411 printers = printers_ go
413 let default_ = Just `liftM` pprTermM go prec t
414 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
415 Just doc <- firstJustM mb_customDocs
416 return$ cparen (prec>app_prec+1) doc
418 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
419 firstJustM [] = return Nothing
421 -- Default set of custom printers. Note that the recursion knot is explicit
422 cPprTermBase :: Monad m => CustomTermPrinter m
424 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
427 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
428 (\ p Term{subTerms=[h,t]} -> doList p h t)
429 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
430 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
431 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
432 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
433 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
435 where ifTerm pred f prec t@Term{}
436 | pred t = Just `liftM` f prec t
437 ifTerm _ _ _ _ = return Nothing
439 isIntegerTy ty = fromMaybe False $ do
440 (tc,_) <- splitTyConApp_maybe ty
441 return (tyConName tc == integerTyConName)
443 isTupleTy ty = fromMaybe False $ do
444 (tc,_) <- splitTyConApp_maybe ty
445 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
447 isTyCon a_tc ty = fromMaybe False $ do
448 (tc,_) <- splitTyConApp_maybe ty
451 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
453 --Note pprinting of list terms is not lazy
455 let elems = h : getListTerms t
456 isConsLast = not(termType(last elems) `coreEqType` termType h)
457 print_elems <- mapM (y cons_prec) elems
458 return$ if isConsLast
459 then cparen (p >= cons_prec)
461 . punctuate (space<>colon)
463 else brackets (pprDeeperList fcat$
464 punctuate comma print_elems)
466 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
467 getListTerms Term{subTerms=[]} = []
468 getListTerms t@Suspension{} = [t]
469 getListTerms t = pprPanic "getListTerms" (ppr t)
472 repPrim :: TyCon -> [Word] -> String
473 repPrim t = rep where
475 | t == charPrimTyCon = show (build x :: Char)
476 | t == intPrimTyCon = show (build x :: Int)
477 | t == wordPrimTyCon = show (build x :: Word)
478 | t == floatPrimTyCon = show (build x :: Float)
479 | t == doublePrimTyCon = show (build x :: Double)
480 | t == int32PrimTyCon = show (build x :: Int32)
481 | t == word32PrimTyCon = show (build x :: Word32)
482 | t == int64PrimTyCon = show (build x :: Int64)
483 | t == word64PrimTyCon = show (build x :: Word64)
484 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
485 | t == stablePtrPrimTyCon = "<stablePtr>"
486 | t == stableNamePrimTyCon = "<stableName>"
487 | t == statePrimTyCon = "<statethread>"
488 | t == realWorldTyCon = "<realworld>"
489 | t == threadIdPrimTyCon = "<ThreadId>"
490 | t == weakPrimTyCon = "<Weak>"
491 | t == arrayPrimTyCon = "<array>"
492 | t == byteArrayPrimTyCon = "<bytearray>"
493 | t == mutableArrayPrimTyCon = "<mutableArray>"
494 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
495 | t == mutVarPrimTyCon= "<mutVar>"
496 | t == mVarPrimTyCon = "<mVar>"
497 | t == tVarPrimTyCon = "<tVar>"
498 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
499 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
500 -- This ^^^ relies on the representation of Haskell heap values being
501 -- the same as in a C array.
503 -----------------------------------
504 -- Type Reconstruction
505 -----------------------------------
507 Type Reconstruction is type inference done on heap closures.
508 The algorithm walks the heap generating a set of equations, which
509 are solved with syntactic unification.
510 A type reconstruction equation looks like:
512 <datacon reptype> = <actual heap contents>
514 The full equation set is generated by traversing all the subterms, starting
517 The only difficult part is that newtypes are only found in the lhs of equations.
518 Right hand sides are missing them. We can either (a) drop them from the lhs, or
519 (b) reconstruct them in the rhs when possible.
521 The function congruenceNewtypes takes a shot at (b)
524 -- The Type Reconstruction monad
527 runTR :: HscEnv -> TR a -> IO a
529 mb_term <- runTR_maybe hsc_env c
531 Nothing -> panic "Can't unify"
534 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
535 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
537 traceTR :: SDoc -> TR ()
538 traceTR = liftTcM . traceTc
541 trIO = liftTcM . ioToTcRn
543 liftTcM :: TcM a -> TR a
546 newVar :: Kind -> TR TcType
547 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
549 -- | Returns the instantiated type scheme ty', and the substitution sigma
550 -- such that sigma(ty') = ty
551 instScheme :: Type -> TR (TcType, TvSubst)
552 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
553 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
554 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
556 -- Adds a constraint of the form t1 == t2
557 -- t1 is expected to come from walking the heap
558 -- t2 is expected to come from a datacon signature
559 -- Before unification, congruenceNewtypes needs to
561 addConstraint :: TcType -> TcType -> TR ()
562 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
563 >> return () -- TOMDO: what about the coercion?
564 -- we should consider family instances
566 -- Type & Term reconstruction
567 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
568 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
569 tv <- newVar argTypeKind
571 Nothing -> go bound tv tv hval
573 >>= return . expandNewtypes
574 Just ty | isMonomorphic ty -> go bound ty ty hval
576 >>= return . expandNewtypes
578 (ty',rev_subst) <- instScheme (sigmaType ty)
580 term <- go bound tv tv hval >>= zonkTerm
581 --restore original Tyvars
582 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
584 go bound _ _ _ | seq bound False = undefined
586 clos <- trIO $ getClosureData a
587 return (Suspension (tipe clos) tv a Nothing)
588 go bound tv ty a = do
589 let monomorphic = not(isTyVarTy tv)
590 -- This ^^^ is a convention. The ancestor tests for
591 -- monomorphism and passes a type instead of a tv
592 clos <- trIO $ getClosureData a
594 -- Thunks we may want to force
595 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
596 -- force blackholes, because it would almost certainly result in deadlock,
597 -- and showing the '_' is more useful.
598 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
599 -- We always follow indirections
600 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
601 -- We also follow references
602 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
603 -- , tycon == mutVarPrimTyCon
605 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
606 tv' <- newVar liftedTypeKind
607 addConstraint tv (mkTyConApp tycon [world,tv'])
608 x <- go bound tv' ty_contents contents
609 return (RefWrap ty x)
611 -- The interesting case
613 Right dcname <- dataConInfoPtrToName (infoPtr clos)
614 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
616 Nothing -> do -- This can happen for private constructors compiled -O0
617 -- where the .hi descriptor does not export them
618 -- In such case, we return a best approximation:
619 -- ignore the unpointed args, and recover the pointeds
620 -- This preserves laziness, and should be safe.
621 let tag = showSDoc (ppr dcname)
622 vars <- replicateM (length$ elems$ ptrs clos)
623 (newVar (liftedTypeKind))
624 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
625 | (i, tv) <- zip [0..] vars]
626 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
628 let extra_args = length(dataConRepArgTys dc) -
629 length(dataConOrigArgTys dc)
630 subTtypes = matchSubTypes dc ty
631 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
632 subTermTvs <- sequence
633 [ if isMonomorphic t then return t
635 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
636 -- It is vital for newtype reconstruction that the unification step
637 -- is done right here, _before_ the subterms are RTTI reconstructed
638 when (not monomorphic) $ do
639 let myType = mkFunTys (reOrderTerms subTermTvs
643 (signatureType,_) <- instScheme(dataConRepType dc)
644 addConstraint myType signatureType
645 subTermsP <- sequence $ drop extra_args
646 -- ^^^ all extra arguments are pointed
647 [ appArr (go (pred bound) tv t) (ptrs clos) i
648 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
649 let unboxeds = extractUnboxed subTtypesNP clos
650 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
651 subTerms = reOrderTerms subTermsP subTermsNP
652 (drop extra_args subTtypes)
653 return (Term tv (Right dc) a subTerms)
654 -- The otherwise case: can be a Thunk,AP,PAP,etc.
656 return (Suspension tipe_clos tv a Nothing)
659 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
660 -- assumption: ^^^ looks through newtypes
661 , isVanillaDataCon dc --TODO non-vanilla case
662 = dataConInstArgTys dc ty_args
663 | otherwise = dataConRepArgTys dc
665 -- This is used to put together pointed and nonpointed subterms in the
667 reOrderTerms _ _ [] = []
668 reOrderTerms pointed unpointed (ty:tys)
669 | isPointed ty = ASSERT2(not(null pointed)
670 , ptext SLIT("reOrderTerms") $$
671 (ppr pointed $$ ppr unpointed))
672 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
673 | otherwise = ASSERT2(not(null unpointed)
674 , ptext SLIT("reOrderTerms") $$
675 (ppr pointed $$ ppr unpointed))
676 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
678 expandNewtypes t@Term{ ty=ty, subTerms=tt }
679 | Just (tc, args) <- splitNewTyConApp_maybe ty
681 , wrapped_type <- newTyConInstRhs tc args
682 , Just dc <- maybeTyConSingleCon tc
683 , t' <- expandNewtypes t{ ty = wrapped_type
684 , subTerms = map expandNewtypes tt }
685 = NewtypeWrap ty (Right dc) t'
687 | otherwise = t{ subTerms = map expandNewtypes tt }
692 -- Fast, breadth-first Type reconstruction
693 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
694 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
695 tv <- newVar argTypeKind
697 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
699 (Seq.singleton (tv, hval))
701 zonkTcType tv -- TODO untested!
702 Just ty | isMonomorphic ty -> return ty
704 (ty',rev_subst) <- instScheme (sigmaType ty)
706 search (isMonomorphic `fmap` zonkTcType tv)
708 (Seq.singleton (tv, hval))
710 substTy rev_subst `fmap` zonkTcType tv
712 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
713 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
714 int max_depth <> text " steps")
715 search stop expand l d =
718 x :< xx -> unlessM stop $ do
720 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
722 -- returns unification tasks,since we are going to want a breadth-first search
723 go :: Type -> HValue -> TR [(Type, HValue)]
725 clos <- trIO $ getClosureData a
727 Indirection _ -> go tv $! (ptrs clos ! 0)
729 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
730 tv' <- newVar liftedTypeKind
731 world <- newVar liftedTypeKind
732 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
733 -- x <- go tv' ty_contents contents
734 return [(tv', contents)]
736 Right dcname <- dataConInfoPtrToName (infoPtr clos)
737 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
740 -- TODO: Check this case
741 forM [0..length (elems $ ptrs clos)] $ \i -> do
742 tv <- newVar liftedTypeKind
743 return$ appArr (\e->(tv,e)) (ptrs clos) i
746 let extra_args = length(dataConRepArgTys dc) -
747 length(dataConOrigArgTys dc)
748 subTtypes <- mapMif (not . isMonomorphic)
749 (\t -> newVar (typeKind t))
750 (dataConRepArgTys dc)
752 -- It is vital for newtype reconstruction that the unification step
753 -- is done right here, _before_ the subterms are RTTI reconstructed
754 let myType = mkFunTys subTtypes tv
755 (signatureType,_) <- instScheme(dataConRepType dc)
756 addConstraint myType signatureType
757 return $ [ appArr (\e->(t,e)) (ptrs clos) i
758 | (i,t) <- drop extra_args $
759 zip [0..] (filter isPointed subTtypes)]
763 This helper computes the difference between a base type t and the
764 improved rtti_t computed by RTTI
765 The main difference between RTTI types and their normal counterparts
766 is that the former are _not_ polymorphic, thus polymorphism must
767 be stripped. Syntactically, forall's must be stripped.
768 We also remove predicates.
770 unifyRTTI :: Type -> Type -> TvSubst
771 unifyRTTI ty rtti_ty =
774 Nothing -> pprPanic "Failed to compute a RTTI substitution"
776 -- In addition, we strip newtypes too, since the reconstructed type might
777 -- not have recovered them all
778 -- TODO stripping newtypes shouldn't be necessary, test
779 where mb_subst = tcUnifyTys (const BindMe)
783 -- Dealing with newtypes
785 congruenceNewtypes does a parallel fold over two Type values,
786 compensating for missing newtypes on both sides.
787 This is necessary because newtypes are not present
788 in runtime, but sometimes there is evidence available.
789 Evidence can come from DataCon signatures or
790 from compile-time type inference.
791 What we are doing here is an approximation
792 of unification modulo a set of equations derived
793 from newtype definitions. These equations should be the
794 same as the equality coercions generated for newtypes
795 in System Fc. The idea is to perform a sort of rewriting,
796 taking those equations as rules, before launching unification.
798 The caller must ensure the following.
799 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
800 The 2nd type (rhs) comes from a DataCon type signature.
801 Rewriting (i.e. adding/removing a newtype wrapper) can happen
802 in both types, but in the rhs it is restricted to the result type.
804 Note that it is very tricky to make this 'rewriting'
805 work with the unification implemented by TcM, where
806 substitutions are operationally inlined. The order in which
807 constraints are unified is vital as we cannot modify
808 anything that has been touched by a previous unification step.
809 Therefore, congruenceNewtypes is sound only if the types
810 recovered by the RTTI mechanism are unified Top-Down.
812 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
813 congruenceNewtypes lhs rhs
814 -- TyVar lhs inductive case
815 | Just tv <- getTyVar_maybe lhs
816 = recoverTc (return (lhs,rhs)) $ do
817 Indirect ty_v <- readMetaTyVar tv
818 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
820 -- FunTy inductive case
821 | Just (l1,l2) <- splitFunTy_maybe lhs
822 , Just (r1,r2) <- splitFunTy_maybe rhs
823 = do (l2',r2') <- congruenceNewtypes l2 r2
824 (l1',r1') <- congruenceNewtypes l1 r1
825 return (mkFunTy l1' l2', mkFunTy r1' r2')
826 -- TyconApp Inductive case; this is the interesting bit.
827 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
828 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
830 = do rhs' <- upgrade tycon_l rhs
833 | otherwise = return (lhs,rhs)
835 where upgrade :: TyCon -> Type -> TR Type
837 | not (isNewTyCon new_tycon) = return ty
839 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
840 let ty' = mkTyConApp new_tycon vars
841 liftTcM (unifyType ty (repType ty'))
842 -- assumes that reptype doesn't ^^^^ touch tyconApp args
846 --------------------------------------------------------------------------------
847 -- Semantically different to recoverM in TcRnMonad
848 -- recoverM retains the errors in the first action,
849 -- whereas recoverTc here does not
850 recoverTc :: TcM a -> TcM a -> TcM a
851 recoverTc recover thing = do
852 (_,mb_res) <- tryTcErrs thing
855 Just res -> return res
857 isMonomorphic :: Type -> Bool
858 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
859 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
861 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
862 mapMif pred f xx = sequence $ mapMif_ pred f xx
865 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
867 unlessM :: Monad m => m Bool -> m () -> m ()
868 unlessM condM acc = condM >>= \c -> unless c acc
870 -- Strict application of f at index i
871 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
872 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
873 = ASSERT (i < length(elems a))
874 case indexArray# ptrs# i# of
877 zonkTerm :: Term -> TcM Term
878 zonkTerm = foldTerm idTermFoldM {
879 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
880 zonkTcType ty >>= \ty' ->
881 return (Term ty' dc v tt)
882 ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
883 return (Suspension ct ty v b)
884 ,fNewtypeWrap= \ty dc t ->
885 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
888 -- Is this defined elsewhere?
889 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
890 sigmaType :: Type -> Type
891 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty