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 ---------------------------------------------
94 A few examples in this representation:
96 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
98 > (('a',_,_),_,('b',_,_)) =
99 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
100 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
102 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
105 data Term = Term { ty :: Type
106 , dc :: Either String DataCon
107 -- Empty if the datacon aint exported by the .hi
108 -- (private constructors in -O0 libraries)
110 , subTerms :: [Term] }
115 | Suspension { ctype :: ClosureType
118 , bound_to :: Maybe Name -- Useful for printing
120 | NewtypeWrap{ ty :: Type
121 , dc :: Either String DataCon
122 , wrapped_term :: Term }
123 | RefWrap { ty :: Type
124 , wrapped_term :: Term }
126 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
129 isSuspension Suspension{} = True
130 isSuspension _ = False
133 isNewtypeWrap NewtypeWrap{} = True
134 isNewtypeWrap _ = False
136 termType :: Term -> Type
139 isFullyEvaluatedTerm :: Term -> Bool
140 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
141 isFullyEvaluatedTerm Prim {} = True
142 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
143 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
144 isFullyEvaluatedTerm _ = False
146 instance Outputable (Term) where
147 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
148 | otherwise = panic "Outputable Term instance"
150 -------------------------------------------------------------------------
151 -- Runtime Closure Datatype and functions for retrieving closure related stuff
152 -------------------------------------------------------------------------
153 data ClosureType = Constr
165 data Closure = Closure { tipe :: ClosureType
167 , infoTable :: StgInfoTable
168 , ptrs :: Array Int HValue
172 instance Outputable ClosureType where
175 #include "../includes/ClosureTypes.h"
177 aP_CODE, pAP_CODE :: Int
183 getClosureData :: a -> IO Closure
185 case unpackClosure# a of
186 (# iptr, ptrs, nptrs #) -> do
187 #ifndef GHCI_TABLES_NEXT_TO_CODE
188 -- the info pointer we get back from unpackClosure# is to the
189 -- beginning of the standard info table, but the Storable instance
190 -- for info tables takes into account the extra entry pointer
191 -- when !tablesNextToCode, so we must adjust here:
192 itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
194 itbl <- peek (Ptr iptr)
196 let tipe = readCType (BCI.tipe itbl)
197 elems = fromIntegral (BCI.ptrs itbl)
198 ptrsList = Array 0 (elems - 1) elems ptrs
199 nptrs_data = [W# (indexWordArray# nptrs i)
200 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
201 ASSERT(elems >= 0) return ()
203 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
205 readCType :: Integral a => a -> ClosureType
207 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
208 | i >= FUN && i <= FUN_STATIC = Fun
209 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
210 | i == THUNK_SELECTOR = ThunkSelector
211 | i == BLACKHOLE = Blackhole
212 | i >= IND && i <= IND_STATIC = Indirection i'
215 | i' == pAP_CODE = PAP
216 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
217 | otherwise = Other i'
218 where i' = fromIntegral i
220 isConstr, isIndirection, isThunk :: ClosureType -> Bool
221 isConstr Constr = True
224 isIndirection (Indirection _) = True
225 --isIndirection ThunkSelector = True
226 isIndirection _ = False
228 isThunk (Thunk _) = True
229 isThunk ThunkSelector = True
233 isFullyEvaluated :: a -> IO Bool
234 isFullyEvaluated a = do
235 closure <- getClosureData a
237 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
238 return$ and are_subs_evaluated
240 where amapM f = sequence . amap' f
242 amap' :: (t -> b) -> Array Int t -> [b]
243 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
244 where g (I# i#) = case indexArray# arr# i# of
247 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
249 unsafeDeepSeq :: a -> b -> b
250 unsafeDeepSeq = unsafeDeepSeq1 2
251 where unsafeDeepSeq1 0 a b = seq a $! b
252 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
253 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
254 -- | unsafePerformIO (isFullyEvaluated a) = b
255 | otherwise = case unsafePerformIO (getClosureData a) of
256 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
257 where tipe = unsafePerformIO (getClosureType a)
259 isPointed :: Type -> Bool
260 isPointed t | Just (t, _) <- splitTyConApp_maybe t
261 = not$ isUnliftedTypeKind (tyConKind t)
264 extractUnboxed :: [Type] -> Closure -> [[Word]]
265 extractUnboxed tt clos = go tt (nonPtrs clos)
267 | Just (tycon,_) <- splitTyConApp_maybe t
268 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
269 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
272 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
275 sizeofTyCon :: TyCon -> Int
276 sizeofTyCon = sizeofPrimRep . tyConPrimRep
278 -----------------------------------
279 -- * Traversals for Terms
280 -----------------------------------
281 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
283 data TermFold a = TermFold { fTerm :: TermProcessor a a
284 , fPrim :: Type -> [Word] -> a
285 , fSuspension :: ClosureType -> Type -> HValue
287 , fNewtypeWrap :: Type -> Either String DataCon
289 , fRefWrap :: Type -> a -> a
292 foldTerm :: TermFold a -> Term -> a
293 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
294 foldTerm tf (Prim ty v ) = fPrim tf ty v
295 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
296 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
297 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
299 idTermFold :: TermFold Term
300 idTermFold = TermFold {
303 fSuspension = Suspension,
304 fNewtypeWrap = NewtypeWrap,
307 idTermFoldM :: Monad m => TermFold (m Term)
308 idTermFoldM = TermFold {
309 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
310 fPrim = (return.). Prim,
311 fSuspension = (((return.).).). Suspension,
312 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
313 fRefWrap = \ty t -> RefWrap ty `liftM` t
316 mapTermType :: (Type -> Type) -> Term -> Term
317 mapTermType f = foldTerm idTermFold {
318 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
319 fSuspension = \ct ty hval n ->
320 Suspension ct (f ty) hval n,
321 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
322 fRefWrap = \ty t -> RefWrap (f ty) t}
324 termTyVars :: Term -> TyVarSet
325 termTyVars = foldTerm TermFold {
326 fTerm = \ty _ _ tt ->
327 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
328 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
329 fPrim = \ _ _ -> emptyVarEnv,
330 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
331 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
332 where concatVarEnv = foldr plusVarEnv emptyVarEnv
334 ----------------------------------
335 -- Pretty printing of terms
336 ----------------------------------
338 type Precedence = Int
339 type TermPrinter = Precedence -> Term -> SDoc
340 type TermPrinterM m = Precedence -> Term -> m SDoc
342 app_prec,cons_prec, max_prec ::Int
345 cons_prec = 5 -- TODO Extract this info from GHC itself
347 pprTerm :: TermPrinter -> TermPrinter
348 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
349 pprTerm _ _ _ = panic "pprTerm"
351 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
352 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
354 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
355 tt_docs <- mapM (y app_prec) tt
356 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
358 ppr_termM y p Term{dc=Right dc, subTerms=tt}
359 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
360 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
361 <+> hsep (map (ppr_term1 True) tt)
362 -} -- TODO Printing infix constructors properly
363 | null tt = return$ ppr dc
365 tt_docs <- mapM (y app_prec) tt
366 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
368 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
369 ppr_termM y p RefWrap{wrapped_term=t} = do
370 contents <- y app_prec t
371 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
372 -- The constructor name is wired in here ^^^ for the sake of simplicity.
373 -- I don't think mutvars are going to change in a near future.
374 -- In any case this is solely a presentation matter: MutVar# is
375 -- a datatype with no constructors, implemented by the RTS
376 -- (hence there is no way to obtain a datacon and print it).
377 ppr_termM _ _ t = ppr_termM1 t
380 ppr_termM1 :: Monad m => Term -> m SDoc
381 ppr_termM1 Prim{value=words, ty=ty} =
382 return$ text$ repPrim (tyConAppTyCon ty) words
383 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
384 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
385 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
386 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
387 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
388 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
389 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
391 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
392 | Just (tc,_) <- splitNewTyConApp_maybe ty
393 , ASSERT(isNewTyCon tc) True
394 , Just new_dc <- maybeTyConSingleCon tc = do
395 real_term <- y max_prec t
396 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
397 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
399 -------------------------------------------------------
400 -- Custom Term Pretty Printers
401 -------------------------------------------------------
403 -- We can want to customize the representation of a
404 -- term depending on its type.
405 -- However, note that custom printers have to work with
406 -- type representations, instead of directly with types.
407 -- We cannot use type classes here, unless we employ some
408 -- typerep trickery (e.g. Weirich's RepLib tricks),
409 -- which I didn't. Therefore, this code replicates a lot
410 -- of what type classes provide for free.
412 type CustomTermPrinter m = TermPrinterM m
413 -> [Precedence -> Term -> (m (Maybe SDoc))]
415 -- | Takes a list of custom printers with a explicit recursion knot and a term,
416 -- and returns the output of the first succesful printer, or the default printer
417 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
418 cPprTerm printers_ = go 0 where
419 printers = printers_ go
421 let default_ = Just `liftM` pprTermM go prec t
422 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
423 Just doc <- firstJustM mb_customDocs
424 return$ cparen (prec>app_prec+1) doc
426 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
427 firstJustM [] = return Nothing
429 -- Default set of custom printers. Note that the recursion knot is explicit
430 cPprTermBase :: Monad m => CustomTermPrinter m
432 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
435 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
436 (\ p Term{subTerms=[h,t]} -> doList p h t)
437 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
438 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
439 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
440 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
441 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
443 where ifTerm pred f prec t@Term{}
444 | pred t = Just `liftM` f prec t
445 ifTerm _ _ _ _ = return Nothing
447 isIntegerTy ty = fromMaybe False $ do
448 (tc,_) <- splitTyConApp_maybe ty
449 return (tyConName tc == integerTyConName)
451 isTupleTy ty = fromMaybe False $ do
452 (tc,_) <- splitTyConApp_maybe ty
453 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
455 isTyCon a_tc ty = fromMaybe False $ do
456 (tc,_) <- splitTyConApp_maybe ty
459 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
461 --Note pprinting of list terms is not lazy
463 let elems = h : getListTerms t
464 isConsLast = not(termType(last elems) `coreEqType` termType h)
465 print_elems <- mapM (y cons_prec) elems
466 return$ if isConsLast
467 then cparen (p >= cons_prec)
469 . punctuate (space<>colon)
471 else brackets (pprDeeperList fcat$
472 punctuate comma print_elems)
474 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
475 getListTerms Term{subTerms=[]} = []
476 getListTerms t@Suspension{} = [t]
477 getListTerms t = pprPanic "getListTerms" (ppr t)
480 repPrim :: TyCon -> [Word] -> String
481 repPrim t = rep where
483 | t == charPrimTyCon = show (build x :: Char)
484 | t == intPrimTyCon = show (build x :: Int)
485 | t == wordPrimTyCon = show (build x :: Word)
486 | t == floatPrimTyCon = show (build x :: Float)
487 | t == doublePrimTyCon = show (build x :: Double)
488 | t == int32PrimTyCon = show (build x :: Int32)
489 | t == word32PrimTyCon = show (build x :: Word32)
490 | t == int64PrimTyCon = show (build x :: Int64)
491 | t == word64PrimTyCon = show (build x :: Word64)
492 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
493 | t == stablePtrPrimTyCon = "<stablePtr>"
494 | t == stableNamePrimTyCon = "<stableName>"
495 | t == statePrimTyCon = "<statethread>"
496 | t == realWorldTyCon = "<realworld>"
497 | t == threadIdPrimTyCon = "<ThreadId>"
498 | t == weakPrimTyCon = "<Weak>"
499 | t == arrayPrimTyCon = "<array>"
500 | t == byteArrayPrimTyCon = "<bytearray>"
501 | t == mutableArrayPrimTyCon = "<mutableArray>"
502 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
503 | t == mutVarPrimTyCon= "<mutVar>"
504 | t == mVarPrimTyCon = "<mVar>"
505 | t == tVarPrimTyCon = "<tVar>"
506 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
507 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
508 -- This ^^^ relies on the representation of Haskell heap values being
509 -- the same as in a C array.
511 -----------------------------------
512 -- Type Reconstruction
513 -----------------------------------
515 Type Reconstruction is type inference done on heap closures.
516 The algorithm walks the heap generating a set of equations, which
517 are solved with syntactic unification.
518 A type reconstruction equation looks like:
520 <datacon reptype> = <actual heap contents>
522 The full equation set is generated by traversing all the subterms, starting
525 The only difficult part is that newtypes are only found in the lhs of equations.
526 Right hand sides are missing them. We can either (a) drop them from the lhs, or
527 (b) reconstruct them in the rhs when possible.
529 The function congruenceNewtypes takes a shot at (b)
532 -- The Type Reconstruction monad
535 runTR :: HscEnv -> TR a -> IO a
537 mb_term <- runTR_maybe hsc_env c
539 Nothing -> panic "Can't unify"
542 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
543 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
545 traceTR :: SDoc -> TR ()
546 traceTR = liftTcM . traceTc
549 trIO = liftTcM . ioToTcRn
551 liftTcM :: TcM a -> TR a
554 newVar :: Kind -> TR TcType
555 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
557 -- | Returns the instantiated type scheme ty', and the substitution sigma
558 -- such that sigma(ty') = ty
559 instScheme :: Type -> TR (TcType, TvSubst)
560 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
561 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
562 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
564 -- Adds a constraint of the form t1 == t2
565 -- t1 is expected to come from walking the heap
566 -- t2 is expected to come from a datacon signature
567 -- Before unification, congruenceNewtypes needs to
569 addConstraint :: TcType -> TcType -> TR ()
570 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
571 >> return () -- TOMDO: what about the coercion?
572 -- we should consider family instances
574 -- Type & Term reconstruction
575 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
576 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
577 tv <- newVar argTypeKind
579 Nothing -> go bound tv tv hval
581 >>= return . expandNewtypes
582 Just ty | isMonomorphic ty -> go bound ty ty hval
584 >>= return . expandNewtypes
586 (ty',rev_subst) <- instScheme (sigmaType ty)
588 term <- go bound tv tv hval >>= zonkTerm
589 --restore original Tyvars
590 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
592 go bound _ _ _ | seq bound False = undefined
594 clos <- trIO $ getClosureData a
595 return (Suspension (tipe clos) tv a Nothing)
596 go bound tv ty a = do
597 let monomorphic = not(isTyVarTy tv)
598 -- This ^^^ is a convention. The ancestor tests for
599 -- monomorphism and passes a type instead of a tv
600 clos <- trIO $ getClosureData a
602 -- Thunks we may want to force
603 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
604 -- force blackholes, because it would almost certainly result in deadlock,
605 -- and showing the '_' is more useful.
606 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
607 -- We always follow indirections
608 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
609 -- We also follow references
610 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
611 -- , tycon == mutVarPrimTyCon
613 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
614 tv' <- newVar liftedTypeKind
615 addConstraint tv (mkTyConApp tycon [world,tv'])
616 x <- go bound tv' ty_contents contents
617 return (RefWrap ty x)
619 -- The interesting case
621 Right dcname <- dataConInfoPtrToName (infoPtr clos)
622 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
624 Nothing -> do -- This can happen for private constructors compiled -O0
625 -- where the .hi descriptor does not export them
626 -- In such case, we return a best approximation:
627 -- ignore the unpointed args, and recover the pointeds
628 -- This preserves laziness, and should be safe.
629 let tag = showSDoc (ppr dcname)
630 vars <- replicateM (length$ elems$ ptrs clos)
631 (newVar (liftedTypeKind))
632 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
633 | (i, tv) <- zip [0..] vars]
634 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
636 let extra_args = length(dataConRepArgTys dc) -
637 length(dataConOrigArgTys dc)
638 subTtypes = matchSubTypes dc ty
639 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
640 subTermTvs <- sequence
641 [ if isMonomorphic t then return t
643 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
644 -- It is vital for newtype reconstruction that the unification step
645 -- is done right here, _before_ the subterms are RTTI reconstructed
646 when (not monomorphic) $ do
647 let myType = mkFunTys (reOrderTerms subTermTvs
651 (signatureType,_) <- instScheme(dataConRepType dc)
652 addConstraint myType signatureType
653 subTermsP <- sequence $ drop extra_args
654 -- ^^^ all extra arguments are pointed
655 [ appArr (go (pred bound) tv t) (ptrs clos) i
656 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
657 let unboxeds = extractUnboxed subTtypesNP clos
658 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
659 subTerms = reOrderTerms subTermsP subTermsNP
660 (drop extra_args subTtypes)
661 return (Term tv (Right dc) a subTerms)
662 -- The otherwise case: can be a Thunk,AP,PAP,etc.
664 return (Suspension tipe_clos tv a Nothing)
667 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
668 -- assumption: ^^^ looks through newtypes
669 , isVanillaDataCon dc --TODO non-vanilla case
670 = dataConInstArgTys dc ty_args
671 | otherwise = dataConRepArgTys dc
673 -- This is used to put together pointed and nonpointed subterms in the
675 reOrderTerms _ _ [] = []
676 reOrderTerms pointed unpointed (ty:tys)
677 | isPointed ty = ASSERT2(not(null pointed)
678 , ptext SLIT("reOrderTerms") $$
679 (ppr pointed $$ ppr unpointed))
680 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
681 | otherwise = ASSERT2(not(null unpointed)
682 , ptext SLIT("reOrderTerms") $$
683 (ppr pointed $$ ppr unpointed))
684 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
686 expandNewtypes t@Term{ ty=ty, subTerms=tt }
687 | Just (tc, args) <- splitNewTyConApp_maybe ty
689 , wrapped_type <- newTyConInstRhs tc args
690 , Just dc <- maybeTyConSingleCon tc
691 , t' <- expandNewtypes t{ ty = wrapped_type
692 , subTerms = map expandNewtypes tt }
693 = NewtypeWrap ty (Right dc) t'
695 | otherwise = t{ subTerms = map expandNewtypes tt }
700 -- Fast, breadth-first Type reconstruction
701 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
702 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
703 tv <- newVar argTypeKind
705 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
707 (Seq.singleton (tv, hval))
709 zonkTcType tv -- TODO untested!
710 Just ty | isMonomorphic ty -> return ty
712 (ty',rev_subst) <- instScheme (sigmaType ty)
714 search (isMonomorphic `fmap` zonkTcType tv)
716 (Seq.singleton (tv, hval))
718 substTy rev_subst `fmap` zonkTcType tv
720 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
721 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
722 int max_depth <> text " steps")
723 search stop expand l d =
726 x :< xx -> unlessM stop $ do
728 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
730 -- returns unification tasks,since we are going to want a breadth-first search
731 go :: Type -> HValue -> TR [(Type, HValue)]
733 clos <- trIO $ getClosureData a
735 Indirection _ -> go tv $! (ptrs clos ! 0)
737 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
738 tv' <- newVar liftedTypeKind
739 world <- newVar liftedTypeKind
740 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
741 -- x <- go tv' ty_contents contents
742 return [(tv', contents)]
744 Right dcname <- dataConInfoPtrToName (infoPtr clos)
745 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
748 -- TODO: Check this case
749 forM [0..length (elems $ ptrs clos)] $ \i -> do
750 tv <- newVar liftedTypeKind
751 return$ appArr (\e->(tv,e)) (ptrs clos) i
754 let extra_args = length(dataConRepArgTys dc) -
755 length(dataConOrigArgTys dc)
756 subTtypes <- mapMif (not . isMonomorphic)
757 (\t -> newVar (typeKind t))
758 (dataConRepArgTys dc)
760 -- It is vital for newtype reconstruction that the unification step
761 -- is done right here, _before_ the subterms are RTTI reconstructed
762 let myType = mkFunTys subTtypes tv
763 (signatureType,_) <- instScheme(dataConRepType dc)
764 addConstraint myType signatureType
765 return $ [ appArr (\e->(t,e)) (ptrs clos) i
766 | (i,t) <- drop extra_args $
767 zip [0..] (filter isPointed subTtypes)]
770 -- This helper computes the difference between a base type t and the
771 -- improved rtti_t computed by RTTI
772 -- The main difference between RTTI types and their normal counterparts
773 -- is that the former are _not_ polymorphic, thus polymorphism must
774 -- be stripped. Syntactically, forall's must be stripped.
775 -- We also remove predicates.
776 unifyRTTI :: Type -> Type -> TvSubst
777 unifyRTTI ty rtti_ty =
780 Nothing -> pprPanic "Failed to compute a RTTI substitution"
782 -- In addition, we strip newtypes too, since the reconstructed type might
783 -- not have recovered them all
784 -- TODO stripping newtypes shouldn't be necessary, test
785 where mb_subst = tcUnifyTys (const BindMe)
789 -- Dealing with newtypes
791 A parallel fold over two Type values,
792 compensating for missing newtypes on both sides.
793 This is necessary because newtypes are not present
794 in runtime, but since sometimes there is evidence
795 available we do our best to reconstruct them.
796 Evidence can come from DataCon signatures or
797 from compile-time type inference.
798 I am using the words congruence and rewriting
799 because what we are doing here is an approximation
800 of unification modulo a set of equations, which would
801 come from newtype definitions. These should be the
802 equality coercions seen in System Fc. Rewriting
803 is performed, taking those equations as rules,
804 before launching unification.
806 It doesn't make sense to rewrite everywhere,
807 or we would end up with all newtypes. So we rewrite
808 only in presence of evidence.
809 The lhs comes from the heap structure of ptrs,nptrs.
810 The rhs comes from a DataCon type signature.
811 Rewriting in the rhs is restricted to the result type.
813 Note that it is very tricky to make this 'rewriting'
814 work with the unification implemented by TcM, where
815 substitutions are 'inlined'. The order in which
816 constraints are unified is vital for this.
817 This is a simple form of residuation, the technique of
818 delaying unification steps until enough information
821 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
822 congruenceNewtypes lhs rhs
823 -- TyVar lhs inductive case
824 | Just tv <- getTyVar_maybe lhs
825 = recoverTc (return (lhs,rhs)) $ do
826 Indirect ty_v <- readMetaTyVar tv
827 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
829 -- FunTy inductive case
830 | Just (l1,l2) <- splitFunTy_maybe lhs
831 , Just (r1,r2) <- splitFunTy_maybe rhs
832 = do (l2',r2') <- congruenceNewtypes l2 r2
833 (l1',r1') <- congruenceNewtypes l1 r1
834 return (mkFunTy l1' l2', mkFunTy r1' r2')
835 -- TyconApp Inductive case; this is the interesting bit.
836 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
837 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
839 = do rhs' <- upgrade tycon_l rhs
842 | otherwise = return (lhs,rhs)
844 where upgrade :: TyCon -> Type -> TR Type
846 | not (isNewTyCon new_tycon) = return ty
848 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
849 let ty' = mkTyConApp new_tycon vars
850 liftTcM (unifyType ty (repType ty'))
851 -- assumes that reptype doesn't ^^^^ touch tyconApp args
855 --------------------------------------------------------------------------------
856 -- Semantically different to recoverM in TcRnMonad
857 -- recoverM retains the errors in the first action,
858 -- whereas recoverTc here does not
859 recoverTc :: TcM a -> TcM a -> TcM a
860 recoverTc recover thing = do
861 (_,mb_res) <- tryTcErrs thing
864 Just res -> return res
866 isMonomorphic :: Type -> Bool
867 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
868 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
870 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
871 mapMif pred f xx = sequence $ mapMif_ pred f xx
874 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
876 unlessM :: Monad m => m Bool -> m () -> m ()
877 unlessM condM acc = condM >>= \c -> unless c acc
879 -- Strict application of f at index i
880 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
881 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
882 = ASSERT (i < length(elems a))
883 case indexArray# ptrs# i# of
886 zonkTerm :: Term -> TcM Term
887 zonkTerm = foldTerm idTermFoldM {
888 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
889 zonkTcType ty >>= \ty' ->
890 return (Term ty' dc v tt)
891 ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
892 return (Suspension ct ty v b)
893 ,fNewtypeWrap= \ty dc t ->
894 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
897 -- Is this defined elsewhere?
898 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
899 sigmaType :: Type -> Type
900 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty