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