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
41 #include "HsVersions.h"
43 import ByteCodeItbls ( StgInfoTable )
44 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
45 import HscTypes ( HscEnv )
50 import TcRnMonad ( TcM, initTc, ioToTcRn,
73 import GHC.Arr ( Array(..) )
78 import Data.Array.Base
79 import Data.List ( partition )
81 import System.IO.Unsafe
83 ---------------------------------------------
84 -- * A representation of semi evaluated Terms
85 ---------------------------------------------
87 A few examples in this representation:
89 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
91 > (('a',_,_),_,('b',_,_)) =
92 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
93 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
95 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
98 data Term = Term { ty :: Type
99 , dc :: Either String DataCon
100 -- The heap datacon. If ty is a newtype,
101 -- this is NOT the newtype datacon.
102 -- Empty if the datacon aint exported by the .hi
103 -- (private constructors in -O0 libraries)
105 , subTerms :: [Term] }
110 | Suspension { ctype :: ClosureType
111 , mb_ty :: Maybe Type
113 , bound_to :: Maybe Name -- Useful for printing
116 isTerm, isSuspension, isPrim :: Term -> Bool
119 isSuspension Suspension{} = True
120 isSuspension _ = False
124 termType :: Term -> Maybe Type
125 termType t@(Suspension {}) = mb_ty t
126 termType t = Just$ ty t
128 isFullyEvaluatedTerm :: Term -> Bool
129 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
130 isFullyEvaluatedTerm Suspension {} = False
131 isFullyEvaluatedTerm Prim {} = True
133 instance Outputable (Term) where
134 ppr = head . cPprTerm cPprTermBase
136 -------------------------------------------------------------------------
137 -- Runtime Closure Datatype and functions for retrieving closure related stuff
138 -------------------------------------------------------------------------
139 data ClosureType = Constr
150 data Closure = Closure { tipe :: ClosureType
152 , infoTable :: StgInfoTable
153 , ptrs :: Array Int HValue
157 instance Outputable ClosureType where
160 #include "../includes/ClosureTypes.h"
167 getClosureData :: a -> IO Closure
169 case unpackClosure# a of
170 (# iptr, ptrs, nptrs #) -> do
171 itbl <- peek (Ptr iptr)
172 let tipe = readCType (BCI.tipe itbl)
173 elems = fromIntegral (BCI.ptrs itbl)
174 ptrsList = Array 0 (elems - 1) elems ptrs
175 nptrs_data = [W# (indexWordArray# nptrs i)
176 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
177 ASSERT(fromIntegral elems >= 0) return ()
179 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
181 readCType :: Integral a => a -> ClosureType
183 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
184 | i >= FUN && i <= FUN_STATIC = Fun
185 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
186 | i == THUNK_SELECTOR = ThunkSelector
187 | i == BLACKHOLE = Blackhole
188 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
189 | fromIntegral i == aP_CODE = AP
191 | fromIntegral i == pAP_CODE = PAP
192 | otherwise = Other (fromIntegral i)
194 isConstr, isIndirection, isThunk :: ClosureType -> Bool
195 isConstr Constr = True
198 isIndirection (Indirection _) = True
199 --isIndirection ThunkSelector = True
200 isIndirection _ = False
202 isThunk (Thunk _) = True
203 isThunk ThunkSelector = True
207 isFullyEvaluated :: a -> IO Bool
208 isFullyEvaluated a = do
209 closure <- getClosureData a
211 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
212 return$ and are_subs_evaluated
213 otherwise -> return False
214 where amapM f = sequence . amap' f
216 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
217 where g (I# i#) = case indexArray# arr# i# of
220 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
222 unsafeDeepSeq :: a -> b -> b
223 unsafeDeepSeq = unsafeDeepSeq1 2
224 where unsafeDeepSeq1 0 a b = seq a $! b
225 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
226 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
227 -- | unsafePerformIO (isFullyEvaluated a) = b
228 | otherwise = case unsafePerformIO (getClosureData a) of
229 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
230 where tipe = unsafePerformIO (getClosureType a)
232 isPointed :: Type -> Bool
233 isPointed t | Just (t, _) <- splitTyConApp_maybe t
234 = not$ isUnliftedTypeKind (tyConKind t)
237 extractUnboxed :: [Type] -> Closure -> [[Word]]
238 extractUnboxed tt clos = go tt (nonPtrs clos)
240 | Just (tycon,_) <- splitTyConApp_maybe t
241 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
242 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
245 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
248 sizeofTyCon = sizeofPrimRep . tyConPrimRep
250 -----------------------------------
251 -- * Traversals for Terms
252 -----------------------------------
254 data TermFold a = TermFold { fTerm :: Type -> Either String DataCon -> HValue -> [a] -> a
255 , fPrim :: Type -> [Word] -> a
256 , fSuspension :: ClosureType -> Maybe Type -> HValue
260 foldTerm :: TermFold a -> Term -> a
261 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
262 foldTerm tf (Prim ty v ) = fPrim tf ty v
263 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
265 idTermFold :: TermFold Term
266 idTermFold = TermFold {
269 fSuspension = Suspension
271 idTermFoldM :: Monad m => TermFold (m Term)
272 idTermFoldM = TermFold {
273 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
274 fPrim = (return.). Prim,
275 fSuspension = (((return.).).). Suspension
278 mapTermType :: (Type -> Type) -> Term -> Term
279 mapTermType f = foldTerm idTermFold {
280 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
281 fSuspension = \ct mb_ty hval n ->
282 Suspension ct (fmap f mb_ty) hval n }
284 termTyVars :: Term -> TyVarSet
285 termTyVars = foldTerm TermFold {
286 fTerm = \ty _ _ tt ->
287 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
288 fSuspension = \_ mb_ty _ _ ->
289 maybe emptyVarEnv tyVarsOfType mb_ty,
290 fPrim = \ _ _ -> emptyVarEnv }
291 where concatVarEnv = foldr plusVarEnv emptyVarEnv
292 ----------------------------------
293 -- Pretty printing of terms
294 ----------------------------------
296 app_prec,cons_prec ::Int
298 cons_prec = 5 -- TODO Extract this info from GHC itself
300 pprTerm y p t | Just doc <- pprTermM y p t = doc
302 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
303 pprTermM y p t@Term{dc=Left dc_tag, subTerms=tt, ty=ty} = do
304 tt_docs <- mapM (y app_prec) tt
305 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
307 pprTermM y p t@Term{dc=Right dc, subTerms=tt, ty=ty}
308 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
309 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
310 <+> hsep (map (pprTerm1 True) tt)
311 -} -- TODO Printing infix constructors properly
312 | null tt = return$ ppr dc
313 | Just (tc,_) <- splitNewTyConApp_maybe ty
315 , Just new_dc <- maybeTyConSingleCon tc = do
316 real_value <- y 10 t{ty=repType ty}
317 return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
319 tt_docs <- mapM (y app_prec) tt
320 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
322 pprTermM y _ t = pprTermM1 y t
323 pprTermM1 _ Prim{value=words, ty=ty} =
324 return$ text$ repPrim (tyConAppTyCon ty) words
325 pprTermM1 y t@Term{} = panic "pprTermM1 - unreachable"
326 pprTermM1 _ Suspension{bound_to=Nothing} = return$ char '_'
327 pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
328 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
329 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
331 -- Takes a list of custom printers with a explicit recursion knot and a term,
332 -- and returns the output of the first succesful printer, or the default printer
333 cPprTerm :: forall m. Monad m =>
334 ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
335 cPprTerm custom = go 0 where
336 go prec t@Term{} = do
337 let default_ prec t = Just `liftM` pprTermM go prec t
338 mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
339 Just doc <- firstJustM mb_customDocs
340 return$ cparen (prec>app_prec+1) doc
341 go _ t = pprTermM1 go t
342 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
343 firstJustM [] = return Nothing
345 -- Default set of custom printers. Note that the recursion knot is explicit
346 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
349 ifTerm isTupleTy (\_ -> liftM (parens . hcat . punctuate comma)
350 . mapM (y (-1)) . subTerms)
351 , ifTerm (\t -> isTyCon listTyCon t && subTerms t `lengthIs` 2)
352 (\ p Term{subTerms=[h,t]} -> doList p h t)
353 , ifTerm (isTyCon intTyCon) (coerceShow$ \(a::Int)->a)
354 , ifTerm (isTyCon charTyCon) (coerceShow$ \(a::Char)->a)
355 -- , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
356 , ifTerm (isTyCon floatTyCon) (coerceShow$ \(a::Float)->a)
357 , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
358 , ifTerm isIntegerTy (coerceShow$ \(a::Integer)->a)
360 where ifTerm pred f p t@Term{} | pred t = liftM Just (f p t)
361 ifTerm _ _ _ _ = return Nothing
362 isIntegerTy Term{ty=ty} = fromMaybe False $ do
363 (tc,_) <- splitTyConApp_maybe ty
364 return (tyConName tc == integerTyConName)
365 isTupleTy Term{ty=ty} = fromMaybe False $ do
366 (tc,_) <- splitTyConApp_maybe ty
367 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
368 isTyCon a_tc Term{ty=ty} = fromMaybe False $ do
369 (tc,_) <- splitTyConApp_maybe ty
371 coerceShow f _ = return . text . show . f . unsafeCoerce# . val
372 --TODO pprinting of list terms is not lazy
374 let elems = h : getListTerms t
375 isConsLast = termType(last elems) /= termType h
376 print_elems <- mapM (y cons_prec) elems
377 return$ if isConsLast
378 then cparen (p >= cons_prec) . hsep . punctuate (space<>colon)
380 else brackets (hcat$ punctuate comma print_elems)
382 where Just a /= Just b = not (a `coreEqType` b)
384 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
385 getListTerms t@Term{subTerms=[]} = []
386 getListTerms t@Suspension{} = [t]
387 getListTerms t = pprPanic "getListTerms" (ppr t)
390 repPrim :: TyCon -> [Word] -> String
391 repPrim t = rep where
393 | t == charPrimTyCon = show (build x :: Char)
394 | t == intPrimTyCon = show (build x :: Int)
395 | t == wordPrimTyCon = show (build x :: Word)
396 | t == floatPrimTyCon = show (build x :: Float)
397 | t == doublePrimTyCon = show (build x :: Double)
398 | t == int32PrimTyCon = show (build x :: Int32)
399 | t == word32PrimTyCon = show (build x :: Word32)
400 | t == int64PrimTyCon = show (build x :: Int64)
401 | t == word64PrimTyCon = show (build x :: Word64)
402 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
403 | t == stablePtrPrimTyCon = "<stablePtr>"
404 | t == stableNamePrimTyCon = "<stableName>"
405 | t == statePrimTyCon = "<statethread>"
406 | t == realWorldTyCon = "<realworld>"
407 | t == threadIdPrimTyCon = "<ThreadId>"
408 | t == weakPrimTyCon = "<Weak>"
409 | t == arrayPrimTyCon = "<array>"
410 | t == byteArrayPrimTyCon = "<bytearray>"
411 | t == mutableArrayPrimTyCon = "<mutableArray>"
412 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
413 | t == mutVarPrimTyCon= "<mutVar>"
414 | t == mVarPrimTyCon = "<mVar>"
415 | t == tVarPrimTyCon = "<tVar>"
416 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
417 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
418 -- This ^^^ relies on the representation of Haskell heap values being
419 -- the same as in a C array.
421 -----------------------------------
422 -- Type Reconstruction
423 -----------------------------------
425 Type Reconstruction is type inference done on heap closures.
426 The algorithm walks the heap generating a set of equations, which
427 are solved with syntactic unification.
428 A type reconstruction equation looks like:
430 <datacon reptype> = <actual heap contents>
432 The full equation set is generated by traversing all the subterms, starting
435 The only difficult part is that newtypes are only found in the lhs of equations.
436 Right hand sides are missing them. We can either (a) drop them from the lhs, or
437 (b) reconstruct them in the rhs when possible.
439 The function congruenceNewtypes takes a shot at (b)
442 -- The Type Reconstruction monad
445 runTR :: HscEnv -> TR a -> IO a
447 mb_term <- runTR_maybe hsc_env c
449 Nothing -> panic "Can't unify"
452 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
453 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
456 trIO = liftTcM . ioToTcRn
458 liftTcM :: TcM a -> TR a
461 newVar :: Kind -> TR TcType
462 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
464 -- | Returns the instantiated type scheme ty', and the substitution sigma
465 -- such that sigma(ty') = ty
466 instScheme :: Type -> TR (TcType, TvSubst)
467 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
468 (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
469 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
471 -- Adds a constraint of the form t1 == t2
472 -- t1 is expected to come from walking the heap
473 -- t2 is expected to come from a datacon signature
474 -- Before unification, congruenceNewtypes needs to
476 addConstraint :: TcType -> TcType -> TR ()
477 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
478 >> return () -- TOMDO: what about the coercion?
479 -- we should consider family instances
481 -- Type & Term reconstruction
482 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
483 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
484 tv <- newVar argTypeKind
486 Nothing -> go bound tv tv hval >>= zonkTerm
487 Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
489 (ty',rev_subst) <- instScheme (sigmaType ty)
491 term <- go bound tv tv hval >>= zonkTerm
492 --restore original Tyvars
493 return$ mapTermType (substTy rev_subst) term
495 go bound _ _ _ | seq bound False = undefined
497 clos <- trIO $ getClosureData a
498 return (Suspension (tipe clos) (Just tv) a Nothing)
499 go bound tv ty a = do
500 let monomorphic = not(isTyVarTy tv)
501 -- This ^^^ is a convention. The ancestor tests for
502 -- monomorphism and passes a type instead of a tv
503 clos <- trIO $ getClosureData a
505 -- Thunks we may want to force
506 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
507 -- force blackholes, because it would almost certainly result in deadlock,
508 -- and showing the '_' is more useful.
509 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
510 -- We always follow indirections
511 Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
512 -- The interesting case
514 Right dcname <- dataConInfoPtrToName (infoPtr clos)
515 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
517 Nothing -> do -- This can happen for private constructors compiled -O0
518 -- where the .hi descriptor does not export them
519 -- In such case, we return a best approximation:
520 -- ignore the unpointed args, and recover the pointeds
521 -- This preserves laziness, and should be safe.
522 let tag = showSDoc (ppr dcname)
523 vars <- replicateM (length$ elems$ ptrs clos)
524 (newVar (liftedTypeKind))
525 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
526 | (i, tv) <- zip [0..] vars]
527 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
529 let extra_args = length(dataConRepArgTys dc) -
530 length(dataConOrigArgTys dc)
531 subTtypes = matchSubTypes dc ty
532 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
533 subTermTvs <- sequence
534 [ if isMonomorphic t then return t
536 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
537 -- It is vital for newtype reconstruction that the unification step
538 -- is done right here, _before_ the subterms are RTTI reconstructed
539 when (not monomorphic) $ do
540 let myType = mkFunTys (reOrderTerms subTermTvs
544 (signatureType,_) <- instScheme(dataConRepType dc)
545 addConstraint myType signatureType
546 subTermsP <- sequence $ drop extra_args
547 -- ^^^ all extra arguments are pointed
548 [ appArr (go (pred bound) tv t) (ptrs clos) i
549 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
550 let unboxeds = extractUnboxed subTtypesNP clos
551 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
552 subTerms = reOrderTerms subTermsP subTermsNP
553 (drop extra_args subTtypes)
554 return (Term tv (Right dc) a subTerms)
555 -- The otherwise case: can be a Thunk,AP,PAP,etc.
557 return (Suspension tipe_clos (Just tv) a Nothing)
559 -- matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
561 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
562 -- assumption: ^^^ looks through newtypes
563 , isVanillaDataCon dc --TODO non-vanilla case
564 = dataConInstArgTys dc ty_args
565 | otherwise = dataConRepArgTys dc
567 -- This is used to put together pointed and nonpointed subterms in the
569 reOrderTerms _ _ [] = []
570 reOrderTerms pointed unpointed (ty:tys)
571 | isPointed ty = ASSERT2(not(null pointed)
572 , ptext SLIT("reOrderTerms") $$
573 (ppr pointed $$ ppr unpointed))
574 head pointed : reOrderTerms (tail pointed) unpointed tys
575 | otherwise = ASSERT2(not(null unpointed)
576 , ptext SLIT("reOrderTerms") $$
577 (ppr pointed $$ ppr unpointed))
578 head unpointed : reOrderTerms pointed (tail unpointed) tys
582 -- Fast, breadth-first Type reconstruction
583 max_depth = 10 :: Int
584 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO (Maybe Type)
585 cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
586 tv <- newVar argTypeKind
588 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
592 zonkTcType tv -- TODO untested!
593 Just ty | isMonomorphic ty -> return ty
595 (ty',rev_subst) <- instScheme (sigmaType ty)
597 search (isMonomorphic `fmap` zonkTcType tv)
601 substTy rev_subst `fmap` zonkTcType tv
603 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
604 search stop expand [] depth = return ()
605 search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
606 show max_depth ++ " steps"
607 search stop expand (x:xx) d = unlessM stop $ do
609 search stop expand (xx ++ new) $! (pred d)
611 -- returns unification tasks,since we are going to want a breadth-first search
612 go :: Type -> HValue -> TR [(Type, HValue)]
614 clos <- trIO $ getClosureData a
616 Indirection _ -> go tv $! (ptrs clos ! 0)
618 Right dcname <- dataConInfoPtrToName (infoPtr clos)
619 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
622 -- TODO: Check this case
623 vars <- replicateM (length$ elems$ ptrs clos)
624 (newVar (liftedTypeKind))
625 subTerms <- sequence [ appArr (go tv) (ptrs clos) i
626 | (i, tv) <- zip [0..] vars]
627 forM [0..length (elems $ ptrs clos)] $ \i -> do
628 tv <- newVar liftedTypeKind
629 return$ appArr (\e->(tv,e)) (ptrs clos) i
632 let extra_args = length(dataConRepArgTys dc) -
633 length(dataConOrigArgTys dc)
634 subTtypes <- mapMif (not . isMonomorphic)
635 (\t -> newVar (typeKind t))
636 (dataConRepArgTys dc)
637 -- It is vital for newtype reconstruction that the unification step
638 -- is done right here, _before_ the subterms are RTTI reconstructed
639 let myType = mkFunTys subTtypes tv
640 (signatureType,_) <- instScheme(dataConRepType dc)
641 addConstraint myType signatureType
642 return $ [ appArr (\e->(t,e)) (ptrs clos) i
643 | (i,t) <- drop extra_args $ zip [0..] subTtypes]
644 otherwise -> return []
646 -- This helper computes the difference between a base type t and the
647 -- improved rtti_t computed by RTTI
648 -- The main difference between RTTI types and their normal counterparts
649 -- is that the former are _not_ polymorphic, thus polymorphism must
650 -- be stripped. Syntactically, forall's must be stripped
651 computeRTTIsubst ty rtti_ty =
652 -- In addition, we strip newtypes too, since the reconstructed type might
653 -- not have recovered them all
654 tcUnifyTys (const BindMe)
655 [repType' $ dropForAlls$ ty]
657 -- TODO stripping newtypes shouldn't be necessary, test
660 -- Dealing with newtypes
662 A parallel fold over two Type values,
663 compensating for missing newtypes on both sides.
664 This is necessary because newtypes are not present
665 in runtime, but since sometimes there is evidence
666 available we do our best to reconstruct them.
667 Evidence can come from DataCon signatures or
668 from compile-time type inference.
669 I am using the words congruence and rewriting
670 because what we are doing here is an approximation
671 of unification modulo a set of equations, which would
672 come from newtype definitions. These should be the
673 equality coercions seen in System Fc. Rewriting
674 is performed, taking those equations as rules,
675 before launching unification.
677 It doesn't make sense to rewrite everywhere,
678 or we would end up with all newtypes. So we rewrite
679 only in presence of evidence.
680 The lhs comes from the heap structure of ptrs,nptrs.
681 The rhs comes from a DataCon type signature.
682 Rewriting in the rhs is restricted to the result type.
684 Note that it is very tricky to make this 'rewriting'
685 work with the unification implemented by TcM, where
686 substitutions are 'inlined'. The order in which
687 constraints are unified is vital for this (or I am
690 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
691 congruenceNewtypes lhs rhs
692 -- TyVar lhs inductive case
693 | Just tv <- getTyVar_maybe lhs
694 = recoverTc (return (lhs,rhs)) $ do
695 Indirect ty_v <- readMetaTyVar tv
696 (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
698 -- FunTy inductive case
699 | Just (l1,l2) <- splitFunTy_maybe lhs
700 , Just (r1,r2) <- splitFunTy_maybe rhs
701 = do (l2',r2') <- congruenceNewtypes l2 r2
702 (l1',r1') <- congruenceNewtypes l1 r1
703 return (mkFunTy l1' l2', mkFunTy r1' r2')
704 -- TyconApp Inductive case; this is the interesting bit.
705 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
706 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
708 = return (lhs, upgrade tycon_l rhs)
710 | otherwise = return (lhs,rhs)
712 where upgrade :: TyCon -> Type -> Type
714 | not (isNewTyCon new_tycon) = ty
715 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
716 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
718 -- assumes that reptype doesn't touch tyconApp args ^^^
721 --------------------------------------------------------------------------------
722 -- Semantically different to recoverM in TcRnMonad
723 -- recoverM retains the errors in the first action,
724 -- whereas recoverTc here does not
725 recoverTc recover thing = do
726 (_,mb_res) <- tryTcErrs thing
729 Just res -> return res
731 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
732 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
734 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
735 mapMif pred f xx = sequence $ mapMif_ pred f xx
736 mapMif_ pred f [] = []
737 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
739 unlessM condM acc = condM >>= \c -> unless c acc
741 -- Strict application of f at index i
742 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
743 = ASSERT (i < length(elems a))
744 case indexArray# ptrs# i# of
747 zonkTerm :: Term -> TcM Term
748 zonkTerm = foldTerm idTermFoldM {
749 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
750 zonkTcType ty >>= \ty' ->
751 return (Term ty' dc v tt)
752 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
753 return (Suspension ct ty v b)}
756 -- Is this defined elsewhere?
757 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
758 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty