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
80 import Data.List ( partition )
81 import qualified Data.Sequence as Seq
83 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
85 import System.IO.Unsafe
87 ---------------------------------------------
88 -- * A representation of semi evaluated Terms
89 ---------------------------------------------
91 A few examples in this representation:
93 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
95 > (('a',_,_),_,('b',_,_)) =
96 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
97 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
99 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
102 data Term = Term { ty :: Type
103 , dc :: Either String DataCon
104 -- The heap datacon. If ty is a newtype,
105 -- this is NOT the newtype datacon.
106 -- Empty if the datacon aint exported by the .hi
107 -- (private constructors in -O0 libraries)
109 , subTerms :: [Term] }
114 | Suspension { ctype :: ClosureType
115 , mb_ty :: Maybe Type
117 , bound_to :: Maybe Name -- Useful for printing
120 isTerm, isSuspension, isPrim :: Term -> Bool
123 isSuspension Suspension{} = True
124 isSuspension _ = False
128 termType :: Term -> Maybe Type
129 termType t@(Suspension {}) = mb_ty t
130 termType t = Just$ ty t
132 isFullyEvaluatedTerm :: Term -> Bool
133 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
134 isFullyEvaluatedTerm Suspension {} = False
135 isFullyEvaluatedTerm Prim {} = True
137 instance Outputable (Term) where
138 ppr = head . cPprTerm cPprTermBase
140 -------------------------------------------------------------------------
141 -- Runtime Closure Datatype and functions for retrieving closure related stuff
142 -------------------------------------------------------------------------
143 data ClosureType = Constr
154 data Closure = Closure { tipe :: ClosureType
156 , infoTable :: StgInfoTable
157 , ptrs :: Array Int HValue
161 instance Outputable ClosureType where
164 #include "../includes/ClosureTypes.h"
166 aP_CODE, pAP_CODE :: Int
172 getClosureData :: a -> IO Closure
174 case unpackClosure# a of
175 (# iptr, ptrs, nptrs #) -> do
176 itbl <- peek (Ptr iptr)
177 let tipe = readCType (BCI.tipe itbl)
178 elems = fromIntegral (BCI.ptrs itbl)
179 ptrsList = Array 0 (elems - 1) elems ptrs
180 nptrs_data = [W# (indexWordArray# nptrs i)
181 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
182 ASSERT(fromIntegral elems >= 0) return ()
184 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
186 readCType :: Integral a => a -> ClosureType
188 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
189 | i >= FUN && i <= FUN_STATIC = Fun
190 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
191 | i == THUNK_SELECTOR = ThunkSelector
192 | i == BLACKHOLE = Blackhole
193 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
194 | fromIntegral i == aP_CODE = AP
196 | fromIntegral i == pAP_CODE = PAP
197 | otherwise = Other (fromIntegral i)
199 isConstr, isIndirection, isThunk :: ClosureType -> Bool
200 isConstr Constr = True
203 isIndirection (Indirection _) = True
204 --isIndirection ThunkSelector = True
205 isIndirection _ = False
207 isThunk (Thunk _) = True
208 isThunk ThunkSelector = True
212 isFullyEvaluated :: a -> IO Bool
213 isFullyEvaluated a = do
214 closure <- getClosureData a
216 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
217 return$ and are_subs_evaluated
219 where amapM f = sequence . amap' f
221 amap' :: (t -> b) -> Array Int t -> [b]
222 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
223 where g (I# i#) = case indexArray# arr# i# of
226 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
228 unsafeDeepSeq :: a -> b -> b
229 unsafeDeepSeq = unsafeDeepSeq1 2
230 where unsafeDeepSeq1 0 a b = seq a $! b
231 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
232 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
233 -- | unsafePerformIO (isFullyEvaluated a) = b
234 | otherwise = case unsafePerformIO (getClosureData a) of
235 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
236 where tipe = unsafePerformIO (getClosureType a)
238 isPointed :: Type -> Bool
239 isPointed t | Just (t, _) <- splitTyConApp_maybe t
240 = not$ isUnliftedTypeKind (tyConKind t)
243 extractUnboxed :: [Type] -> Closure -> [[Word]]
244 extractUnboxed tt clos = go tt (nonPtrs clos)
246 | Just (tycon,_) <- splitTyConApp_maybe t
247 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
248 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
251 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
254 sizeofTyCon :: TyCon -> Int
255 sizeofTyCon = sizeofPrimRep . tyConPrimRep
257 -----------------------------------
258 -- * Traversals for Terms
259 -----------------------------------
260 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
262 data TermFold a = TermFold { fTerm :: TermProcessor a a
263 , fPrim :: Type -> [Word] -> a
264 , fSuspension :: ClosureType -> Maybe Type -> HValue
268 foldTerm :: TermFold a -> Term -> a
269 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
270 foldTerm tf (Prim ty v ) = fPrim tf ty v
271 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
273 idTermFold :: TermFold Term
274 idTermFold = TermFold {
277 fSuspension = Suspension
279 idTermFoldM :: Monad m => TermFold (m Term)
280 idTermFoldM = TermFold {
281 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
282 fPrim = (return.). Prim,
283 fSuspension = (((return.).).). Suspension
286 mapTermType :: (Type -> Type) -> Term -> Term
287 mapTermType f = foldTerm idTermFold {
288 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
289 fSuspension = \ct mb_ty hval n ->
290 Suspension ct (fmap f mb_ty) hval n }
292 termTyVars :: Term -> TyVarSet
293 termTyVars = foldTerm TermFold {
294 fTerm = \ty _ _ tt ->
295 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
296 fSuspension = \_ mb_ty _ _ ->
297 maybe emptyVarEnv tyVarsOfType mb_ty,
298 fPrim = \ _ _ -> emptyVarEnv }
299 where concatVarEnv = foldr plusVarEnv emptyVarEnv
300 ----------------------------------
301 -- Pretty printing of terms
302 ----------------------------------
304 app_prec,cons_prec ::Int
306 cons_prec = 5 -- TODO Extract this info from GHC itself
308 pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
309 pprTerm y p t | Just doc <- pprTermM y p t = doc
310 pprTerm _ _ _ = panic "pprTerm"
312 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
313 pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
314 tt_docs <- mapM (y app_prec) tt
315 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
317 pprTermM y p t@Term{dc=Right dc, subTerms=tt, ty=ty}
318 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
319 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
320 <+> hsep (map (pprTerm1 True) tt)
321 -} -- TODO Printing infix constructors properly
322 | null tt = return$ ppr dc
323 | Just (tc,_) <- splitNewTyConApp_maybe ty
325 , Just new_dc <- maybeTyConSingleCon tc = do
326 real_value <- y 10 t{ty=repType ty}
327 return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
329 tt_docs <- mapM (y app_prec) tt
330 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
332 pprTermM _ _ t = pprTermM1 t
334 pprTermM1 :: Monad m => Term -> m SDoc
335 pprTermM1 Prim{value=words, ty=ty} =
336 return$ text$ repPrim (tyConAppTyCon ty) words
337 pprTermM1 Term{} = panic "pprTermM1 - unreachable"
338 pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
339 pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
340 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
341 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
342 pprTermM1 _ = panic "pprTermM1"
344 type CustomTermPrinter m = Int -> TermProcessor Term (m (Maybe SDoc))
346 -- Takes a list of custom printers with a explicit recursion knot and a term,
347 -- and returns the output of the first succesful printer, or the default printer
348 cPprTerm :: Monad m =>
349 ((Int->Term->m SDoc)->[CustomTermPrinter m]) -> Term -> m SDoc
350 cPprTerm printers_ = go 0 where
351 printers = printers_ go
352 go prec t@(Term ty dc val tt) = do
353 let default_ = Just `liftM` pprTermM go prec t
354 mb_customDocs = [pp prec ty dc val tt | pp <- printers] ++ [default_]
355 Just doc <- firstJustM mb_customDocs
356 return$ cparen (prec>app_prec+1) doc
358 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
359 firstJustM [] = return Nothing
361 -- Default set of custom printers. Note that the recursion knot is explicit
362 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[CustomTermPrinter m]
365 ifTerm isTupleTy (\ _ _ tt ->
366 liftM (parens . hcat . punctuate comma)
369 , ifTerm (\ty tt -> isTyCon listTyCon ty tt && tt `lengthIs` 2)
370 (\ p _ [h,t] -> doList p h t)
371 , ifTerm (isTyCon intTyCon) (coerceShow$ \(a::Int)->a)
372 , ifTerm (isTyCon charTyCon) (coerceShow$ \(a::Char)->a)
373 -- , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
374 , ifTerm (isTyCon floatTyCon) (coerceShow$ \(a::Float)->a)
375 , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
376 , ifTerm isIntegerTy (coerceShow$ \(a::Integer)->a)
378 where ifTerm pred f prec ty _ val tt
379 | pred ty tt = liftM Just (f prec val tt)
380 | otherwise = return Nothing
381 isIntegerTy ty _ = fromMaybe False $ do
382 (tc,_) <- splitTyConApp_maybe ty
383 return (tyConName tc == integerTyConName)
384 isTupleTy ty _ = fromMaybe False $ do
385 (tc,_) <- splitTyConApp_maybe ty
386 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
387 isTyCon a_tc ty _ = fromMaybe False $ do
388 (tc,_) <- splitTyConApp_maybe ty
390 coerceShow f _ val _ = (return . text . show . f . unsafeCoerce#) val
391 --TODO pprinting of list terms is not lazy
393 let elems = h : getListTerms t
394 isConsLast = termType(last elems) /= termType h
395 print_elems <- mapM (y cons_prec) elems
396 return$ if isConsLast
397 then cparen (p >= cons_prec)
399 . punctuate (space<>colon)
401 else brackets (hcat$ punctuate comma print_elems)
403 where Just a /= Just b = not (a `coreEqType` b)
405 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
406 getListTerms Term{subTerms=[]} = []
407 getListTerms t@Suspension{} = [t]
408 getListTerms t = pprPanic "getListTerms" (ppr t)
411 repPrim :: TyCon -> [Word] -> String
412 repPrim t = rep where
414 | t == charPrimTyCon = show (build x :: Char)
415 | t == intPrimTyCon = show (build x :: Int)
416 | t == wordPrimTyCon = show (build x :: Word)
417 | t == floatPrimTyCon = show (build x :: Float)
418 | t == doublePrimTyCon = show (build x :: Double)
419 | t == int32PrimTyCon = show (build x :: Int32)
420 | t == word32PrimTyCon = show (build x :: Word32)
421 | t == int64PrimTyCon = show (build x :: Int64)
422 | t == word64PrimTyCon = show (build x :: Word64)
423 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
424 | t == stablePtrPrimTyCon = "<stablePtr>"
425 | t == stableNamePrimTyCon = "<stableName>"
426 | t == statePrimTyCon = "<statethread>"
427 | t == realWorldTyCon = "<realworld>"
428 | t == threadIdPrimTyCon = "<ThreadId>"
429 | t == weakPrimTyCon = "<Weak>"
430 | t == arrayPrimTyCon = "<array>"
431 | t == byteArrayPrimTyCon = "<bytearray>"
432 | t == mutableArrayPrimTyCon = "<mutableArray>"
433 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
434 | t == mutVarPrimTyCon= "<mutVar>"
435 | t == mVarPrimTyCon = "<mVar>"
436 | t == tVarPrimTyCon = "<tVar>"
437 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
438 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
439 -- This ^^^ relies on the representation of Haskell heap values being
440 -- the same as in a C array.
442 -----------------------------------
443 -- Type Reconstruction
444 -----------------------------------
446 Type Reconstruction is type inference done on heap closures.
447 The algorithm walks the heap generating a set of equations, which
448 are solved with syntactic unification.
449 A type reconstruction equation looks like:
451 <datacon reptype> = <actual heap contents>
453 The full equation set is generated by traversing all the subterms, starting
456 The only difficult part is that newtypes are only found in the lhs of equations.
457 Right hand sides are missing them. We can either (a) drop them from the lhs, or
458 (b) reconstruct them in the rhs when possible.
460 The function congruenceNewtypes takes a shot at (b)
463 -- The Type Reconstruction monad
466 runTR :: HscEnv -> TR a -> IO a
468 mb_term <- runTR_maybe hsc_env c
470 Nothing -> panic "Can't unify"
473 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
474 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
477 trIO = liftTcM . ioToTcRn
479 liftTcM :: TcM a -> TR a
482 newVar :: Kind -> TR TcType
483 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
485 -- | Returns the instantiated type scheme ty', and the substitution sigma
486 -- such that sigma(ty') = ty
487 instScheme :: Type -> TR (TcType, TvSubst)
488 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
489 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
490 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
492 -- Adds a constraint of the form t1 == t2
493 -- t1 is expected to come from walking the heap
494 -- t2 is expected to come from a datacon signature
495 -- Before unification, congruenceNewtypes needs to
497 addConstraint :: TcType -> TcType -> TR ()
498 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
499 >> return () -- TOMDO: what about the coercion?
500 -- we should consider family instances
502 -- Type & Term reconstruction
503 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
504 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
505 tv <- newVar argTypeKind
507 Nothing -> go bound tv tv hval >>= zonkTerm
508 Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
510 (ty',rev_subst) <- instScheme (sigmaType ty)
512 term <- go bound tv tv hval >>= zonkTerm
513 --restore original Tyvars
514 return$ mapTermType (substTy rev_subst) term
516 go bound _ _ _ | seq bound False = undefined
518 clos <- trIO $ getClosureData a
519 return (Suspension (tipe clos) (Just tv) a Nothing)
520 go bound tv ty a = do
521 let monomorphic = not(isTyVarTy tv)
522 -- This ^^^ is a convention. The ancestor tests for
523 -- monomorphism and passes a type instead of a tv
524 clos <- trIO $ getClosureData a
526 -- Thunks we may want to force
527 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
528 -- force blackholes, because it would almost certainly result in deadlock,
529 -- and showing the '_' is more useful.
530 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
531 -- We always follow indirections
532 Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
533 -- The interesting case
535 Right dcname <- dataConInfoPtrToName (infoPtr clos)
536 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
538 Nothing -> do -- This can happen for private constructors compiled -O0
539 -- where the .hi descriptor does not export them
540 -- In such case, we return a best approximation:
541 -- ignore the unpointed args, and recover the pointeds
542 -- This preserves laziness, and should be safe.
543 let tag = showSDoc (ppr dcname)
544 vars <- replicateM (length$ elems$ ptrs clos)
545 (newVar (liftedTypeKind))
546 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
547 | (i, tv) <- zip [0..] vars]
548 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
550 let extra_args = length(dataConRepArgTys dc) -
551 length(dataConOrigArgTys dc)
552 subTtypes = matchSubTypes dc ty
553 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
554 subTermTvs <- sequence
555 [ if isMonomorphic t then return t
557 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
558 -- It is vital for newtype reconstruction that the unification step
559 -- is done right here, _before_ the subterms are RTTI reconstructed
560 when (not monomorphic) $ do
561 let myType = mkFunTys (reOrderTerms subTermTvs
565 (signatureType,_) <- instScheme(dataConRepType dc)
566 addConstraint myType signatureType
567 subTermsP <- sequence $ drop extra_args
568 -- ^^^ all extra arguments are pointed
569 [ appArr (go (pred bound) tv t) (ptrs clos) i
570 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
571 let unboxeds = extractUnboxed subTtypesNP clos
572 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
573 subTerms = reOrderTerms subTermsP subTermsNP
574 (drop extra_args subTtypes)
575 return (Term tv (Right dc) a subTerms)
576 -- The otherwise case: can be a Thunk,AP,PAP,etc.
578 return (Suspension tipe_clos (Just tv) a Nothing)
580 -- matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
582 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
583 -- assumption: ^^^ looks through newtypes
584 , isVanillaDataCon dc --TODO non-vanilla case
585 = dataConInstArgTys dc ty_args
586 | otherwise = dataConRepArgTys dc
588 -- This is used to put together pointed and nonpointed subterms in the
590 reOrderTerms _ _ [] = []
591 reOrderTerms pointed unpointed (ty:tys)
592 | isPointed ty = ASSERT2(not(null pointed)
593 , ptext SLIT("reOrderTerms") $$
594 (ppr pointed $$ ppr unpointed))
595 head pointed : reOrderTerms (tail pointed) unpointed tys
596 | otherwise = ASSERT2(not(null unpointed)
597 , ptext SLIT("reOrderTerms") $$
598 (ppr pointed $$ ppr unpointed))
599 head unpointed : reOrderTerms pointed (tail unpointed) tys
603 -- Fast, breadth-first Type reconstruction
604 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
605 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
606 tv <- newVar argTypeKind
608 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
610 (Seq.singleton (tv, hval))
612 zonkTcType tv -- TODO untested!
613 Just ty | isMonomorphic ty -> return ty
615 (ty',rev_subst) <- instScheme (sigmaType ty)
617 search (isMonomorphic `fmap` zonkTcType tv)
619 (Seq.singleton (tv, hval))
621 substTy rev_subst `fmap` zonkTcType tv
623 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
624 search _ _ _ 0 = fail$ "Failed to reconstruct a type after " ++
625 show max_depth ++ " steps"
626 search stop expand l d =
629 x :< xx -> unlessM stop $ do
631 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
633 -- returns unification tasks,since we are going to want a breadth-first search
634 go :: Type -> HValue -> TR [(Type, HValue)]
636 clos <- trIO $ getClosureData a
638 Indirection _ -> go tv $! (ptrs clos ! 0)
640 Right dcname <- dataConInfoPtrToName (infoPtr clos)
641 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
644 -- TODO: Check this case
645 forM [0..length (elems $ ptrs clos)] $ \i -> do
646 tv <- newVar liftedTypeKind
647 return$ appArr (\e->(tv,e)) (ptrs clos) i
650 let extra_args = length(dataConRepArgTys dc) -
651 length(dataConOrigArgTys dc)
652 subTtypes <- mapMif (not . isMonomorphic)
653 (\t -> newVar (typeKind t))
654 (dataConRepArgTys dc)
656 -- It is vital for newtype reconstruction that the unification step
657 -- is done right here, _before_ the subterms are RTTI reconstructed
658 let myType = mkFunTys subTtypes tv
659 (signatureType,_) <- instScheme(dataConRepType dc)
660 addConstraint myType signatureType
661 return $ [ appArr (\e->(t,e)) (ptrs clos) i
662 | (i,t) <- drop extra_args $
663 zip [0..] (filter isPointed subTtypes)]
666 -- This helper computes the difference between a base type t and the
667 -- improved rtti_t computed by RTTI
668 -- The main difference between RTTI types and their normal counterparts
669 -- is that the former are _not_ polymorphic, thus polymorphism must
670 -- be stripped. Syntactically, forall's must be stripped
671 computeRTTIsubst :: Type -> Type -> Maybe TvSubst
672 computeRTTIsubst ty rtti_ty =
673 -- In addition, we strip newtypes too, since the reconstructed type might
674 -- not have recovered them all
675 tcUnifyTys (const BindMe)
676 [repType' $ dropForAlls$ ty]
678 -- TODO stripping newtypes shouldn't be necessary, test
681 -- Dealing with newtypes
683 A parallel fold over two Type values,
684 compensating for missing newtypes on both sides.
685 This is necessary because newtypes are not present
686 in runtime, but since sometimes there is evidence
687 available we do our best to reconstruct them.
688 Evidence can come from DataCon signatures or
689 from compile-time type inference.
690 I am using the words congruence and rewriting
691 because what we are doing here is an approximation
692 of unification modulo a set of equations, which would
693 come from newtype definitions. These should be the
694 equality coercions seen in System Fc. Rewriting
695 is performed, taking those equations as rules,
696 before launching unification.
698 It doesn't make sense to rewrite everywhere,
699 or we would end up with all newtypes. So we rewrite
700 only in presence of evidence.
701 The lhs comes from the heap structure of ptrs,nptrs.
702 The rhs comes from a DataCon type signature.
703 Rewriting in the rhs is restricted to the result type.
705 Note that it is very tricky to make this 'rewriting'
706 work with the unification implemented by TcM, where
707 substitutions are 'inlined'. The order in which
708 constraints are unified is vital for this (or I am
711 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
712 congruenceNewtypes lhs rhs
713 -- TyVar lhs inductive case
714 | Just tv <- getTyVar_maybe lhs
715 = recoverTc (return (lhs,rhs)) $ do
716 Indirect ty_v <- readMetaTyVar tv
717 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
719 -- FunTy inductive case
720 | Just (l1,l2) <- splitFunTy_maybe lhs
721 , Just (r1,r2) <- splitFunTy_maybe rhs
722 = do (l2',r2') <- congruenceNewtypes l2 r2
723 (l1',r1') <- congruenceNewtypes l1 r1
724 return (mkFunTy l1' l2', mkFunTy r1' r2')
725 -- TyconApp Inductive case; this is the interesting bit.
726 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
727 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
729 = return (lhs, upgrade tycon_l rhs)
731 | otherwise = return (lhs,rhs)
733 where upgrade :: TyCon -> Type -> Type
735 | not (isNewTyCon new_tycon) = ty
736 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
737 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
739 upgrade _ _ = panic "congruenceNewtypes.upgrade"
740 -- assumes that reptype doesn't touch tyconApp args ^^^
743 --------------------------------------------------------------------------------
744 -- Semantically different to recoverM in TcRnMonad
745 -- recoverM retains the errors in the first action,
746 -- whereas recoverTc here does not
747 recoverTc :: TcM a -> TcM a -> TcM a
748 recoverTc recover thing = do
749 (_,mb_res) <- tryTcErrs thing
752 Just res -> return res
754 isMonomorphic :: Type -> Bool
755 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
756 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
758 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
759 mapMif pred f xx = sequence $ mapMif_ pred f xx
762 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
764 unlessM :: Monad m => m Bool -> m () -> m ()
765 unlessM condM acc = condM >>= \c -> unless c acc
767 -- Strict application of f at index i
768 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
769 appArr f (Array _ _ _ ptrs#) (I# i#)
770 = ASSERT (i < length(elems a))
771 case indexArray# ptrs# i# of
774 zonkTerm :: Term -> TcM Term
775 zonkTerm = foldTerm idTermFoldM {
776 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
777 zonkTcType ty >>= \ty' ->
778 return (Term ty' dc v tt)
779 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
780 return (Suspension ct ty v b)}
783 -- Is this defined elsewhere?
784 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
785 sigmaType :: Type -> Type
786 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty