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