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