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
42 #include "HsVersions.h"
44 import ByteCodeItbls ( StgInfoTable )
45 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
46 import HscTypes ( HscEnv )
51 import TcRnMonad ( TcM, initTc, ioToTcRn,
74 import GHC.Arr ( Array(..) )
79 import Data.Array.Base
81 import Data.List ( partition )
82 import qualified Data.Sequence as Seq
84 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
86 import System.IO.Unsafe
88 ---------------------------------------------
89 -- * A representation of semi evaluated Terms
90 ---------------------------------------------
92 A few examples in this representation:
94 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
96 > (('a',_,_),_,('b',_,_)) =
97 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
98 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
100 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
103 data Term = Term { ty :: Type
104 , dc :: Either String DataCon
105 -- The heap datacon. If ty is a newtype,
106 -- this is NOT the newtype datacon.
107 -- Empty if the datacon aint exported by the .hi
108 -- (private constructors in -O0 libraries)
110 , subTerms :: [Term] }
115 | Suspension { ctype :: ClosureType
116 , mb_ty :: Maybe Type
118 , bound_to :: Maybe Name -- Useful for printing
121 isTerm, isSuspension, isPrim :: Term -> Bool
124 isSuspension Suspension{} = True
125 isSuspension _ = False
129 termType :: Term -> Maybe Type
130 termType t@(Suspension {}) = mb_ty t
131 termType t = Just$ ty t
133 isFullyEvaluatedTerm :: Term -> Bool
134 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
135 isFullyEvaluatedTerm Suspension {} = False
136 isFullyEvaluatedTerm Prim {} = True
138 instance Outputable (Term) where
139 ppr = head . cPprTerm cPprTermBase
141 -------------------------------------------------------------------------
142 -- Runtime Closure Datatype and functions for retrieving closure related stuff
143 -------------------------------------------------------------------------
144 data ClosureType = Constr
155 data Closure = Closure { tipe :: ClosureType
157 , infoTable :: StgInfoTable
158 , ptrs :: Array Int HValue
162 instance Outputable ClosureType where
165 #include "../includes/ClosureTypes.h"
167 aP_CODE, pAP_CODE :: Int
173 getClosureData :: a -> IO Closure
175 case unpackClosure# a of
176 (# iptr, ptrs, nptrs #) -> do
177 itbl <- peek (Ptr iptr)
178 let tipe = readCType (BCI.tipe itbl)
179 elems = fromIntegral (BCI.ptrs itbl)
180 ptrsList = Array 0 (elems - 1) elems ptrs
181 nptrs_data = [W# (indexWordArray# nptrs i)
182 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
183 ASSERT(elems >= 0) return ()
185 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
187 readCType :: Integral a => a -> ClosureType
189 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
190 | i >= FUN && i <= FUN_STATIC = Fun
191 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
192 | i == THUNK_SELECTOR = ThunkSelector
193 | i == BLACKHOLE = Blackhole
194 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
195 | fromIntegral i == aP_CODE = AP
197 | fromIntegral i == pAP_CODE = PAP
198 | otherwise = Other (fromIntegral i)
200 isConstr, isIndirection, isThunk :: ClosureType -> Bool
201 isConstr Constr = True
204 isIndirection (Indirection _) = True
205 --isIndirection ThunkSelector = True
206 isIndirection _ = False
208 isThunk (Thunk _) = True
209 isThunk ThunkSelector = True
213 isFullyEvaluated :: a -> IO Bool
214 isFullyEvaluated a = do
215 closure <- getClosureData a
217 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
218 return$ and are_subs_evaluated
220 where amapM f = sequence . amap' f
222 amap' :: (t -> b) -> Array Int t -> [b]
223 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
224 where g (I# i#) = case indexArray# arr# i# of
227 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
229 unsafeDeepSeq :: a -> b -> b
230 unsafeDeepSeq = unsafeDeepSeq1 2
231 where unsafeDeepSeq1 0 a b = seq a $! b
232 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
233 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
234 -- | unsafePerformIO (isFullyEvaluated a) = b
235 | otherwise = case unsafePerformIO (getClosureData a) of
236 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
237 where tipe = unsafePerformIO (getClosureType a)
239 isPointed :: Type -> Bool
240 isPointed t | Just (t, _) <- splitTyConApp_maybe t
241 = not$ isUnliftedTypeKind (tyConKind t)
244 extractUnboxed :: [Type] -> Closure -> [[Word]]
245 extractUnboxed tt clos = go tt (nonPtrs clos)
247 | Just (tycon,_) <- splitTyConApp_maybe t
248 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
249 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
252 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
255 sizeofTyCon :: TyCon -> Int
256 sizeofTyCon = sizeofPrimRep . tyConPrimRep
258 -----------------------------------
259 -- * Traversals for Terms
260 -----------------------------------
261 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
263 data TermFold a = TermFold { fTerm :: TermProcessor a a
264 , fPrim :: Type -> [Word] -> a
265 , fSuspension :: ClosureType -> Maybe Type -> HValue
269 foldTerm :: TermFold a -> Term -> a
270 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
271 foldTerm tf (Prim ty v ) = fPrim tf ty v
272 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
274 idTermFold :: TermFold Term
275 idTermFold = TermFold {
278 fSuspension = Suspension
280 idTermFoldM :: Monad m => TermFold (m Term)
281 idTermFoldM = TermFold {
282 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
283 fPrim = (return.). Prim,
284 fSuspension = (((return.).).). Suspension
287 mapTermType :: (Type -> Type) -> Term -> Term
288 mapTermType f = foldTerm idTermFold {
289 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
290 fSuspension = \ct mb_ty hval n ->
291 Suspension ct (fmap f mb_ty) hval n }
293 termTyVars :: Term -> TyVarSet
294 termTyVars = foldTerm TermFold {
295 fTerm = \ty _ _ tt ->
296 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
297 fSuspension = \_ mb_ty _ _ ->
298 maybe emptyVarEnv tyVarsOfType mb_ty,
299 fPrim = \ _ _ -> emptyVarEnv }
300 where concatVarEnv = foldr plusVarEnv emptyVarEnv
302 ----------------------------------
303 -- Pretty printing of terms
304 ----------------------------------
306 app_prec,cons_prec ::Int
308 cons_prec = 5 -- TODO Extract this info from GHC itself
310 pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
311 pprTerm y p t | Just doc <- pprTermM y p t = doc
312 pprTerm _ _ _ = panic "pprTerm"
314 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
315 pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
316 tt_docs <- mapM (y app_prec) tt
317 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
319 pprTermM y p t@Term{dc=Right dc, subTerms=tt, ty=ty}
320 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
321 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
322 <+> hsep (map (pprTerm1 True) tt)
323 -} -- TODO Printing infix constructors properly
324 | null tt = return$ ppr dc
325 | Just (tc,_) <- splitNewTyConApp_maybe ty
327 , Just new_dc <- maybeTyConSingleCon tc = do
328 real_value <- y 10 t{ty=repType ty}
329 return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
331 tt_docs <- mapM (y app_prec) tt
332 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
334 pprTermM _ _ t = pprTermM1 t
336 pprTermM1 :: Monad m => Term -> m SDoc
337 pprTermM1 Prim{value=words, ty=ty} =
338 return$ text$ repPrim (tyConAppTyCon ty) words
339 pprTermM1 Term{} = panic "pprTermM1 - unreachable"
340 pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
341 pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
342 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
343 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
344 pprTermM1 _ = panic "pprTermM1"
346 -------------------------------------------------------
347 -- Custom Term Pretty Printers
348 -------------------------------------------------------
350 -- We can want to customize the representation of a
351 -- term depending on its type.
352 -- However, note that custom printers have to work with
353 -- type representations, instead of directly with types.
354 -- We cannot use type classes here, unless we employ some
355 -- typerep trickery (e.g. Weirich's RepLib tricks),
356 -- which I didn't. Therefore, this code replicates a lot
357 -- of what type classes provide for free.
359 -- Concretely a custom term printer takes an explicit
360 -- recursion knot, and produces a list of Term Processors,
361 -- which additionally need a precedence value to
362 -- either produce a SDoc or fail (and they do this in some monad m).
364 type Precedence = Int
365 type RecursionKnot m = Int-> Term -> m SDoc
366 type CustomTermPrinter m = RecursionKnot m
367 -> [Precedence -> TermProcessor Term (m (Maybe SDoc))]
369 -- Takes a list of custom printers with a explicit recursion knot and a term,
370 -- and returns the output of the first succesful printer, or the default printer
371 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
372 cPprTerm printers_ = go 0 where
373 printers = printers_ go
374 go prec t@(Term ty dc val tt) = do
375 let default_ = Just `liftM` pprTermM go prec t
376 mb_customDocs = [pp prec ty dc val tt | pp <- printers] ++ [default_]
377 Just doc <- firstJustM mb_customDocs
378 return$ cparen (prec>app_prec+1) doc
380 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
381 firstJustM [] = return Nothing
383 -- Default set of custom printers. Note that the recursion knot is explicit
384 cPprTermBase :: Monad m => CustomTermPrinter m
387 ifTerm isTupleTy (\ _ _ tt ->
388 liftM (parens . hcat . punctuate comma)
391 , ifTerm (\ty tt -> isTyCon listTyCon ty tt && tt `lengthIs` 2)
392 (\ p _ [h,t] -> doList p h t)
393 , ifTerm (isTyCon intTyCon) (coerceShow$ \(a::Int)->a)
394 , ifTerm (isTyCon charTyCon) (coerceShow$ \(a::Char)->a)
395 -- , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
396 , ifTerm (isTyCon floatTyCon) (coerceShow$ \(a::Float)->a)
397 , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
398 , ifTerm isIntegerTy (coerceShow$ \(a::Integer)->a)
400 where ifTerm pred f prec ty _ val tt
401 | pred ty tt = liftM Just (f prec val tt)
402 | otherwise = return Nothing
403 isIntegerTy ty _ = fromMaybe False $ do
404 (tc,_) <- splitTyConApp_maybe ty
405 return (tyConName tc == integerTyConName)
406 isTupleTy ty _ = fromMaybe False $ do
407 (tc,_) <- splitTyConApp_maybe ty
408 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
409 isTyCon a_tc ty _ = fromMaybe False $ do
410 (tc,_) <- splitTyConApp_maybe ty
412 coerceShow f _ val _ = (return . text . show . f . unsafeCoerce#) val
413 --TODO pprinting of list terms is not lazy
415 let elems = h : getListTerms t
416 isConsLast = termType(last elems) /= termType h
417 print_elems <- mapM (y cons_prec) elems
418 return$ if isConsLast
419 then cparen (p >= cons_prec)
421 . punctuate (space<>colon)
423 else brackets (hcat$ punctuate comma print_elems)
425 where Just a /= Just b = not (a `coreEqType` b)
427 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
428 getListTerms Term{subTerms=[]} = []
429 getListTerms t@Suspension{} = [t]
430 getListTerms t = pprPanic "getListTerms" (ppr t)
433 repPrim :: TyCon -> [Word] -> String
434 repPrim t = rep where
436 | t == charPrimTyCon = show (build x :: Char)
437 | t == intPrimTyCon = show (build x :: Int)
438 | t == wordPrimTyCon = show (build x :: Word)
439 | t == floatPrimTyCon = show (build x :: Float)
440 | t == doublePrimTyCon = show (build x :: Double)
441 | t == int32PrimTyCon = show (build x :: Int32)
442 | t == word32PrimTyCon = show (build x :: Word32)
443 | t == int64PrimTyCon = show (build x :: Int64)
444 | t == word64PrimTyCon = show (build x :: Word64)
445 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
446 | t == stablePtrPrimTyCon = "<stablePtr>"
447 | t == stableNamePrimTyCon = "<stableName>"
448 | t == statePrimTyCon = "<statethread>"
449 | t == realWorldTyCon = "<realworld>"
450 | t == threadIdPrimTyCon = "<ThreadId>"
451 | t == weakPrimTyCon = "<Weak>"
452 | t == arrayPrimTyCon = "<array>"
453 | t == byteArrayPrimTyCon = "<bytearray>"
454 | t == mutableArrayPrimTyCon = "<mutableArray>"
455 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
456 | t == mutVarPrimTyCon= "<mutVar>"
457 | t == mVarPrimTyCon = "<mVar>"
458 | t == tVarPrimTyCon = "<tVar>"
459 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
460 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
461 -- This ^^^ relies on the representation of Haskell heap values being
462 -- the same as in a C array.
464 -----------------------------------
465 -- Type Reconstruction
466 -----------------------------------
468 Type Reconstruction is type inference done on heap closures.
469 The algorithm walks the heap generating a set of equations, which
470 are solved with syntactic unification.
471 A type reconstruction equation looks like:
473 <datacon reptype> = <actual heap contents>
475 The full equation set is generated by traversing all the subterms, starting
478 The only difficult part is that newtypes are only found in the lhs of equations.
479 Right hand sides are missing them. We can either (a) drop them from the lhs, or
480 (b) reconstruct them in the rhs when possible.
482 The function congruenceNewtypes takes a shot at (b)
485 -- The Type Reconstruction monad
488 runTR :: HscEnv -> TR a -> IO a
490 mb_term <- runTR_maybe hsc_env c
492 Nothing -> panic "Can't unify"
495 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
496 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
499 trIO = liftTcM . ioToTcRn
501 liftTcM :: TcM a -> TR a
504 newVar :: Kind -> TR TcType
505 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
507 -- | Returns the instantiated type scheme ty', and the substitution sigma
508 -- such that sigma(ty') = ty
509 instScheme :: Type -> TR (TcType, TvSubst)
510 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
511 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
512 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
514 -- Adds a constraint of the form t1 == t2
515 -- t1 is expected to come from walking the heap
516 -- t2 is expected to come from a datacon signature
517 -- Before unification, congruenceNewtypes needs to
519 addConstraint :: TcType -> TcType -> TR ()
520 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
521 >> return () -- TOMDO: what about the coercion?
522 -- we should consider family instances
524 -- Type & Term reconstruction
525 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
526 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
527 tv <- newVar argTypeKind
529 Nothing -> go bound tv tv hval >>= zonkTerm
530 Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
532 (ty',rev_subst) <- instScheme (sigmaType ty)
534 term <- go bound tv tv hval >>= zonkTerm
535 --restore original Tyvars
536 return$ mapTermType (substTy rev_subst) term
538 go bound _ _ _ | seq bound False = undefined
540 clos <- trIO $ getClosureData a
541 return (Suspension (tipe clos) (Just tv) a Nothing)
542 go bound tv ty a = do
543 let monomorphic = not(isTyVarTy tv)
544 -- This ^^^ is a convention. The ancestor tests for
545 -- monomorphism and passes a type instead of a tv
546 clos <- trIO $ getClosureData a
548 -- Thunks we may want to force
549 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
550 -- force blackholes, because it would almost certainly result in deadlock,
551 -- and showing the '_' is more useful.
552 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
553 -- We always follow indirections
554 Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
555 -- The interesting case
557 Right dcname <- dataConInfoPtrToName (infoPtr clos)
558 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
560 Nothing -> do -- This can happen for private constructors compiled -O0
561 -- where the .hi descriptor does not export them
562 -- In such case, we return a best approximation:
563 -- ignore the unpointed args, and recover the pointeds
564 -- This preserves laziness, and should be safe.
565 let tag = showSDoc (ppr dcname)
566 vars <- replicateM (length$ elems$ ptrs clos)
567 (newVar (liftedTypeKind))
568 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
569 | (i, tv) <- zip [0..] vars]
570 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
572 let extra_args = length(dataConRepArgTys dc) -
573 length(dataConOrigArgTys dc)
574 subTtypes = matchSubTypes dc ty
575 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
576 subTermTvs <- sequence
577 [ if isMonomorphic t then return t
579 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
580 -- It is vital for newtype reconstruction that the unification step
581 -- is done right here, _before_ the subterms are RTTI reconstructed
582 when (not monomorphic) $ do
583 let myType = mkFunTys (reOrderTerms subTermTvs
587 (signatureType,_) <- instScheme(dataConRepType dc)
588 addConstraint myType signatureType
589 subTermsP <- sequence $ drop extra_args
590 -- ^^^ all extra arguments are pointed
591 [ appArr (go (pred bound) tv t) (ptrs clos) i
592 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
593 let unboxeds = extractUnboxed subTtypesNP clos
594 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
595 subTerms = reOrderTerms subTermsP subTermsNP
596 (drop extra_args subTtypes)
597 return (Term tv (Right dc) a subTerms)
598 -- The otherwise case: can be a Thunk,AP,PAP,etc.
600 return (Suspension tipe_clos (Just tv) a Nothing)
602 -- matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
604 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
605 -- assumption: ^^^ looks through newtypes
606 , isVanillaDataCon dc --TODO non-vanilla case
607 = dataConInstArgTys dc ty_args
608 | otherwise = dataConRepArgTys dc
610 -- This is used to put together pointed and nonpointed subterms in the
612 reOrderTerms _ _ [] = []
613 reOrderTerms pointed unpointed (ty:tys)
614 | isPointed ty = ASSERT2(not(null pointed)
615 , ptext SLIT("reOrderTerms") $$
616 (ppr pointed $$ ppr unpointed))
617 head pointed : reOrderTerms (tail pointed) unpointed tys
618 | otherwise = ASSERT2(not(null unpointed)
619 , ptext SLIT("reOrderTerms") $$
620 (ppr pointed $$ ppr unpointed))
621 head unpointed : reOrderTerms pointed (tail unpointed) tys
625 -- Fast, breadth-first Type reconstruction
626 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
627 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
628 tv <- newVar argTypeKind
630 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
632 (Seq.singleton (tv, hval))
634 zonkTcType tv -- TODO untested!
635 Just ty | isMonomorphic ty -> return ty
637 (ty',rev_subst) <- instScheme (sigmaType ty)
639 search (isMonomorphic `fmap` zonkTcType tv)
641 (Seq.singleton (tv, hval))
643 substTy rev_subst `fmap` zonkTcType tv
645 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
646 search _ _ _ 0 = fail$ "Failed to reconstruct a type after " ++
647 show max_depth ++ " steps"
648 search stop expand l d =
651 x :< xx -> unlessM stop $ do
653 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
655 -- returns unification tasks,since we are going to want a breadth-first search
656 go :: Type -> HValue -> TR [(Type, HValue)]
658 clos <- trIO $ getClosureData a
660 Indirection _ -> go tv $! (ptrs clos ! 0)
662 Right dcname <- dataConInfoPtrToName (infoPtr clos)
663 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
666 -- TODO: Check this case
667 forM [0..length (elems $ ptrs clos)] $ \i -> do
668 tv <- newVar liftedTypeKind
669 return$ appArr (\e->(tv,e)) (ptrs clos) i
672 let extra_args = length(dataConRepArgTys dc) -
673 length(dataConOrigArgTys dc)
674 subTtypes <- mapMif (not . isMonomorphic)
675 (\t -> newVar (typeKind t))
676 (dataConRepArgTys dc)
678 -- It is vital for newtype reconstruction that the unification step
679 -- is done right here, _before_ the subterms are RTTI reconstructed
680 let myType = mkFunTys subTtypes tv
681 (signatureType,_) <- instScheme(dataConRepType dc)
682 addConstraint myType signatureType
683 return $ [ appArr (\e->(t,e)) (ptrs clos) i
684 | (i,t) <- drop extra_args $
685 zip [0..] (filter isPointed subTtypes)]
688 -- This helper computes the difference between a base type t and the
689 -- improved rtti_t computed by RTTI
690 -- The main difference between RTTI types and their normal counterparts
691 -- is that the former are _not_ polymorphic, thus polymorphism must
692 -- be stripped. Syntactically, forall's must be stripped
693 computeRTTIsubst :: Type -> Type -> Maybe TvSubst
694 computeRTTIsubst ty rtti_ty =
695 -- In addition, we strip newtypes too, since the reconstructed type might
696 -- not have recovered them all
697 tcUnifyTys (const BindMe)
698 [repType' $ dropForAlls$ ty]
700 -- TODO stripping newtypes shouldn't be necessary, test
703 -- Dealing with newtypes
705 A parallel fold over two Type values,
706 compensating for missing newtypes on both sides.
707 This is necessary because newtypes are not present
708 in runtime, but since sometimes there is evidence
709 available we do our best to reconstruct them.
710 Evidence can come from DataCon signatures or
711 from compile-time type inference.
712 I am using the words congruence and rewriting
713 because what we are doing here is an approximation
714 of unification modulo a set of equations, which would
715 come from newtype definitions. These should be the
716 equality coercions seen in System Fc. Rewriting
717 is performed, taking those equations as rules,
718 before launching unification.
720 It doesn't make sense to rewrite everywhere,
721 or we would end up with all newtypes. So we rewrite
722 only in presence of evidence.
723 The lhs comes from the heap structure of ptrs,nptrs.
724 The rhs comes from a DataCon type signature.
725 Rewriting in the rhs is restricted to the result type.
727 Note that it is very tricky to make this 'rewriting'
728 work with the unification implemented by TcM, where
729 substitutions are 'inlined'. The order in which
730 constraints are unified is vital for this (or I am
733 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
734 congruenceNewtypes lhs rhs
735 -- TyVar lhs inductive case
736 | Just tv <- getTyVar_maybe lhs
737 = recoverTc (return (lhs,rhs)) $ do
738 Indirect ty_v <- readMetaTyVar tv
739 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
741 -- FunTy inductive case
742 | Just (l1,l2) <- splitFunTy_maybe lhs
743 , Just (r1,r2) <- splitFunTy_maybe rhs
744 = do (l2',r2') <- congruenceNewtypes l2 r2
745 (l1',r1') <- congruenceNewtypes l1 r1
746 return (mkFunTy l1' l2', mkFunTy r1' r2')
747 -- TyconApp Inductive case; this is the interesting bit.
748 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
749 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
751 = return (lhs, upgrade tycon_l rhs)
753 | otherwise = return (lhs,rhs)
755 where upgrade :: TyCon -> Type -> Type
757 | not (isNewTyCon new_tycon) = ty
758 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
759 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
761 upgrade _ _ = panic "congruenceNewtypes.upgrade"
762 -- assumes that reptype doesn't touch tyconApp args ^^^
765 --------------------------------------------------------------------------------
766 -- Semantically different to recoverM in TcRnMonad
767 -- recoverM retains the errors in the first action,
768 -- whereas recoverTc here does not
769 recoverTc :: TcM a -> TcM a -> TcM a
770 recoverTc recover thing = do
771 (_,mb_res) <- tryTcErrs thing
774 Just res -> return res
776 isMonomorphic :: Type -> Bool
777 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
778 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
780 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
781 mapMif pred f xx = sequence $ mapMif_ pred f xx
784 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
786 unlessM :: Monad m => m Bool -> m () -> m ()
787 unlessM condM acc = condM >>= \c -> unless c acc
789 -- Strict application of f at index i
790 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
791 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
792 = ASSERT (i < length(elems a))
793 case indexArray# ptrs# i# of
796 zonkTerm :: Term -> TcM Term
797 zonkTerm = foldTerm idTermFoldM {
798 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
799 zonkTcType ty >>= \ty' ->
800 return (Term ty' dc v tt)
801 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
802 return (Suspension ct ty v b)}
805 -- Is this defined elsewhere?
806 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
807 sigmaType :: Type -> Type
808 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty