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
43 #include "HsVersions.h"
45 import ByteCodeItbls ( StgInfoTable )
46 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
47 import HscTypes ( HscEnv )
73 import Constants ( wORD_SIZE )
75 import GHC.Arr ( Array(..) )
77 import GHC.IOBase ( IO(IO) )
81 import Data.Array.Base
83 import Data.List ( partition )
84 import qualified Data.Sequence as Seq
86 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
88 import System.IO.Unsafe
91 ---------------------------------------------
92 -- * A representation of semi evaluated Terms
93 ---------------------------------------------
98 data Term = Term { ty :: Type
99 , dc :: Either String DataCon
100 -- Carries a text representation if the datacon is
101 -- not exported by the .hi file, which is the case
102 -- for private constructors in -O0 compiled libraries
104 , subTerms :: [Term] }
109 | Suspension { ctype :: ClosureType
112 , bound_to :: Maybe Name -- Useful for printing
114 | NewtypeWrap{ ty :: Type
115 , dc :: Either String DataCon
116 , wrapped_term :: Term }
117 | RefWrap { ty :: Type
118 , wrapped_term :: Term }
120 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
123 isSuspension Suspension{} = True
124 isSuspension _ = False
127 isNewtypeWrap NewtypeWrap{} = True
128 isNewtypeWrap _ = False
130 termType :: Term -> Type
133 isFullyEvaluatedTerm :: Term -> Bool
134 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
135 isFullyEvaluatedTerm Prim {} = True
136 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
137 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
138 isFullyEvaluatedTerm _ = False
140 instance Outputable (Term) where
141 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
142 | otherwise = panic "Outputable Term instance"
144 -------------------------------------------------------------------------
145 -- Runtime Closure Datatype and functions for retrieving closure related stuff
146 -------------------------------------------------------------------------
147 data ClosureType = Constr
159 data Closure = Closure { tipe :: ClosureType
161 , infoTable :: StgInfoTable
162 , ptrs :: Array Int HValue
166 instance Outputable ClosureType where
169 #include "../includes/ClosureTypes.h"
171 aP_CODE, pAP_CODE :: Int
177 getClosureData :: a -> IO Closure
179 case unpackClosure# a of
180 (# iptr, ptrs, nptrs #) -> do
182 | ghciTablesNextToCode =
185 -- the info pointer we get back from unpackClosure#
186 -- is to the beginning of the standard info table,
187 -- but the Storable instance for info tables takes
188 -- into account the extra entry pointer when
189 -- !ghciTablesNextToCode, so we must adjust here:
190 Ptr iptr `plusPtr` negate wORD_SIZE
192 let tipe = readCType (BCI.tipe itbl)
193 elems = fromIntegral (BCI.ptrs itbl)
194 ptrsList = Array 0 (elems - 1) elems ptrs
195 nptrs_data = [W# (indexWordArray# nptrs i)
196 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
197 ASSERT(elems >= 0) return ()
199 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
201 readCType :: Integral a => a -> ClosureType
203 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
204 | i >= FUN && i <= FUN_STATIC = Fun
205 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
206 | i == THUNK_SELECTOR = ThunkSelector
207 | i == BLACKHOLE = Blackhole
208 | i >= IND && i <= IND_STATIC = Indirection i'
211 | i' == pAP_CODE = PAP
212 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
213 | otherwise = Other i'
214 where i' = fromIntegral i
216 isConstr, isIndirection, isThunk :: ClosureType -> Bool
217 isConstr Constr = True
220 isIndirection (Indirection _) = True
221 isIndirection _ = False
223 isThunk (Thunk _) = True
224 isThunk ThunkSelector = True
228 isFullyEvaluated :: a -> IO Bool
229 isFullyEvaluated a = do
230 closure <- getClosureData a
232 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
233 return$ and are_subs_evaluated
235 where amapM f = sequence . amap' f
237 amap' :: (t -> b) -> Array Int t -> [b]
238 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
239 where g (I# i#) = case indexArray# arr# i# of
242 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
244 unsafeDeepSeq :: a -> b -> b
245 unsafeDeepSeq = unsafeDeepSeq1 2
246 where unsafeDeepSeq1 0 a b = seq a $! b
247 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
248 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
249 -- | unsafePerformIO (isFullyEvaluated a) = b
250 | otherwise = case unsafePerformIO (getClosureData a) of
251 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
252 where tipe = unsafePerformIO (getClosureType a)
254 isPointed :: Type -> Bool
255 isPointed t | Just (t, _) <- splitTyConApp_maybe t
256 = not$ isUnliftedTypeKind (tyConKind t)
259 extractUnboxed :: [Type] -> Closure -> [[Word]]
260 extractUnboxed tt clos = go tt (nonPtrs clos)
262 | Just (tycon,_) <- splitTyConApp_maybe t
263 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
264 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
267 | (x, rest) <- splitAt (sizeofType t) xx
270 sizeofTyCon :: TyCon -> Int -- in *words*
271 sizeofTyCon = primRepSizeW . tyConPrimRep
273 -----------------------------------
274 -- * Traversals for Terms
275 -----------------------------------
276 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
278 data TermFold a = TermFold { fTerm :: TermProcessor a a
279 , fPrim :: Type -> [Word] -> a
280 , fSuspension :: ClosureType -> Type -> HValue
282 , fNewtypeWrap :: Type -> Either String DataCon
284 , fRefWrap :: Type -> a -> a
287 foldTerm :: TermFold a -> Term -> a
288 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
289 foldTerm tf (Prim ty v ) = fPrim tf ty v
290 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
291 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
292 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
294 idTermFold :: TermFold Term
295 idTermFold = TermFold {
298 fSuspension = Suspension,
299 fNewtypeWrap = NewtypeWrap,
302 idTermFoldM :: Monad m => TermFold (m Term)
303 idTermFoldM = TermFold {
304 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
305 fPrim = (return.). Prim,
306 fSuspension = (((return.).).). Suspension,
307 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
308 fRefWrap = \ty t -> RefWrap ty `liftM` t
311 mapTermType :: (Type -> Type) -> Term -> Term
312 mapTermType f = foldTerm idTermFold {
313 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
314 fSuspension = \ct ty hval n ->
315 Suspension ct (f ty) hval n,
316 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
317 fRefWrap = \ty t -> RefWrap (f ty) t}
319 termTyVars :: Term -> TyVarSet
320 termTyVars = foldTerm TermFold {
321 fTerm = \ty _ _ tt ->
322 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
323 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
324 fPrim = \ _ _ -> emptyVarEnv,
325 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
326 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
327 where concatVarEnv = foldr plusVarEnv emptyVarEnv
329 ----------------------------------
330 -- Pretty printing of terms
331 ----------------------------------
333 type Precedence = Int
334 type TermPrinter = Precedence -> Term -> SDoc
335 type TermPrinterM m = Precedence -> Term -> m SDoc
337 app_prec,cons_prec, max_prec ::Int
340 cons_prec = 5 -- TODO Extract this info from GHC itself
342 pprTerm :: TermPrinter -> TermPrinter
343 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
344 pprTerm _ _ _ = panic "pprTerm"
346 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
347 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
349 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
350 tt_docs <- mapM (y app_prec) tt
351 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
353 ppr_termM y p Term{dc=Right dc, subTerms=tt}
354 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
355 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
356 <+> hsep (map (ppr_term1 True) tt)
357 -} -- TODO Printing infix constructors properly
358 | null tt = return$ ppr dc
360 tt_docs <- mapM (y app_prec) tt
361 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
363 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
364 ppr_termM y p RefWrap{wrapped_term=t} = do
365 contents <- y app_prec t
366 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
367 -- The constructor name is wired in here ^^^ for the sake of simplicity.
368 -- I don't think mutvars are going to change in a near future.
369 -- In any case this is solely a presentation matter: MutVar# is
370 -- a datatype with no constructors, implemented by the RTS
371 -- (hence there is no way to obtain a datacon and print it).
372 ppr_termM _ _ t = ppr_termM1 t
375 ppr_termM1 :: Monad m => Term -> m SDoc
376 ppr_termM1 Prim{value=words, ty=ty} =
377 return$ text$ repPrim (tyConAppTyCon ty) words
378 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
379 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
380 | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit "<function>")
381 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
382 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
383 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
384 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
386 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
387 | Just (tc,_) <- splitNewTyConApp_maybe ty
388 , ASSERT(isNewTyCon tc) True
389 , Just new_dc <- tyConSingleDataCon_maybe tc = do
390 real_term <- y max_prec t
391 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
392 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
394 -------------------------------------------------------
395 -- Custom Term Pretty Printers
396 -------------------------------------------------------
398 -- We can want to customize the representation of a
399 -- term depending on its type.
400 -- However, note that custom printers have to work with
401 -- type representations, instead of directly with types.
402 -- We cannot use type classes here, unless we employ some
403 -- typerep trickery (e.g. Weirich's RepLib tricks),
404 -- which I didn't. Therefore, this code replicates a lot
405 -- of what type classes provide for free.
407 type CustomTermPrinter m = TermPrinterM m
408 -> [Precedence -> Term -> (m (Maybe SDoc))]
410 -- | Takes a list of custom printers with a explicit recursion knot and a term,
411 -- and returns the output of the first succesful printer, or the default printer
412 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
413 cPprTerm printers_ = go 0 where
414 printers = printers_ go
416 let default_ = Just `liftM` pprTermM go prec t
417 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
418 Just doc <- firstJustM mb_customDocs
419 return$ cparen (prec>app_prec+1) doc
421 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
422 firstJustM [] = return Nothing
424 -- Default set of custom printers. Note that the recursion knot is explicit
425 cPprTermBase :: Monad m => CustomTermPrinter m
427 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
430 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
431 (\ p Term{subTerms=[h,t]} -> doList p h t)
432 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
433 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
434 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
435 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
436 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
438 where ifTerm pred f prec t@Term{}
439 | pred t = Just `liftM` f prec t
440 ifTerm _ _ _ _ = return Nothing
442 isIntegerTy ty = fromMaybe False $ do
443 (tc,_) <- splitTyConApp_maybe ty
444 return (tyConName tc == integerTyConName)
446 isTupleTy ty = fromMaybe False $ do
447 (tc,_) <- splitTyConApp_maybe ty
448 return (isBoxedTupleTyCon tc)
450 isTyCon a_tc ty = fromMaybe False $ do
451 (tc,_) <- splitTyConApp_maybe ty
454 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
456 --Note pprinting of list terms is not lazy
458 let elems = h : getListTerms t
459 isConsLast = not(termType(last elems) `coreEqType` termType h)
460 print_elems <- mapM (y cons_prec) elems
461 return$ if isConsLast
462 then cparen (p >= cons_prec)
464 . punctuate (space<>colon)
466 else brackets (pprDeeperList fcat$
467 punctuate comma print_elems)
469 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
470 getListTerms Term{subTerms=[]} = []
471 getListTerms t@Suspension{} = [t]
472 getListTerms t = pprPanic "getListTerms" (ppr t)
475 repPrim :: TyCon -> [Word] -> String
476 repPrim t = rep where
478 | t == charPrimTyCon = show (build x :: Char)
479 | t == intPrimTyCon = show (build x :: Int)
480 | t == wordPrimTyCon = show (build x :: Word)
481 | t == floatPrimTyCon = show (build x :: Float)
482 | t == doublePrimTyCon = show (build x :: Double)
483 | t == int32PrimTyCon = show (build x :: Int32)
484 | t == word32PrimTyCon = show (build x :: Word32)
485 | t == int64PrimTyCon = show (build x :: Int64)
486 | t == word64PrimTyCon = show (build x :: Word64)
487 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
488 | t == stablePtrPrimTyCon = "<stablePtr>"
489 | t == stableNamePrimTyCon = "<stableName>"
490 | t == statePrimTyCon = "<statethread>"
491 | t == realWorldTyCon = "<realworld>"
492 | t == threadIdPrimTyCon = "<ThreadId>"
493 | t == weakPrimTyCon = "<Weak>"
494 | t == arrayPrimTyCon = "<array>"
495 | t == byteArrayPrimTyCon = "<bytearray>"
496 | t == mutableArrayPrimTyCon = "<mutableArray>"
497 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
498 | t == mutVarPrimTyCon= "<mutVar>"
499 | t == mVarPrimTyCon = "<mVar>"
500 | t == tVarPrimTyCon = "<tVar>"
501 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
502 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
503 -- This ^^^ relies on the representation of Haskell heap values being
504 -- the same as in a C array.
506 -----------------------------------
507 -- Type Reconstruction
508 -----------------------------------
510 Type Reconstruction is type inference done on heap closures.
511 The algorithm walks the heap generating a set of equations, which
512 are solved with syntactic unification.
513 A type reconstruction equation looks like:
515 <datacon reptype> = <actual heap contents>
517 The full equation set is generated by traversing all the subterms, starting
520 The only difficult part is that newtypes are only found in the lhs of equations.
521 Right hand sides are missing them. We can either (a) drop them from the lhs, or
522 (b) reconstruct them in the rhs when possible.
524 The function congruenceNewtypes takes a shot at (b)
527 -- The Type Reconstruction monad
530 runTR :: HscEnv -> TR a -> IO a
532 mb_term <- runTR_maybe hsc_env c
534 Nothing -> panic "Can't unify"
537 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
538 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
540 traceTR :: SDoc -> TR ()
541 traceTR = liftTcM . traceTc
544 trIO = liftTcM . liftIO
546 liftTcM :: TcM a -> TR a
549 newVar :: Kind -> TR TcType
550 newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
552 -- | Returns the instantiated type scheme ty', and the substitution sigma
553 -- such that sigma(ty') = ty
554 instScheme :: Type -> TR (TcType, TvSubst)
555 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
556 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
557 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
559 -- Adds a constraint of the form t1 == t2
560 -- t1 is expected to come from walking the heap
561 -- t2 is expected to come from a datacon signature
562 -- Before unification, congruenceNewtypes needs to
564 addConstraint :: TcType -> TcType -> TR ()
565 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry boxyUnify
566 >> return () -- TOMDO: what about the coercion?
567 -- we should consider family instances
569 -- Type & Term reconstruction
570 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
571 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
572 tv <- newVar argTypeKind
574 Nothing -> go bound tv tv hval
576 >>= return . expandNewtypes
577 Just ty | isMonomorphic ty -> go bound ty ty hval
579 >>= return . expandNewtypes
581 (ty',rev_subst) <- instScheme (sigmaType ty)
583 term <- go bound tv tv hval >>= zonkTerm
584 --restore original Tyvars
585 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
587 go bound _ _ _ | seq bound False = undefined
589 clos <- trIO $ getClosureData a
590 return (Suspension (tipe clos) tv a Nothing)
591 go bound tv ty a = do
592 let monomorphic = not(isTyVarTy tv)
593 -- This ^^^ is a convention. The ancestor tests for
594 -- monomorphism and passes a type instead of a tv
595 clos <- trIO $ getClosureData a
597 -- Thunks we may want to force
598 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
599 -- force blackholes, because it would almost certainly result in deadlock,
600 -- and showing the '_' is more useful.
601 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
602 -- We always follow indirections
603 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
604 -- We also follow references
605 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
606 -- , tycon == mutVarPrimTyCon
608 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
609 tv' <- newVar liftedTypeKind
610 addConstraint tv (mkTyConApp tycon [world,tv'])
611 x <- go bound tv' ty_contents contents
612 return (RefWrap ty x)
614 -- The interesting case
616 Right dcname <- dataConInfoPtrToName (infoPtr clos)
617 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
619 Nothing -> do -- This can happen for private constructors compiled -O0
620 -- where the .hi descriptor does not export them
621 -- In such case, we return a best approximation:
622 -- ignore the unpointed args, and recover the pointeds
623 -- This preserves laziness, and should be safe.
624 let tag = showSDoc (ppr dcname)
625 vars <- replicateM (length$ elems$ ptrs clos)
626 (newVar (liftedTypeKind))
627 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
628 | (i, tv) <- zip [0..] vars]
629 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
631 let extra_args = length(dataConRepArgTys dc) -
632 length(dataConOrigArgTys dc)
633 subTtypes = matchSubTypes dc ty
634 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
635 subTermTvs <- sequence
636 [ if isMonomorphic t then return t
638 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
639 -- It is vital for newtype reconstruction that the unification step
640 -- is done right here, _before_ the subterms are RTTI reconstructed
641 when (not monomorphic) $ do
642 let myType = mkFunTys (reOrderTerms subTermTvs
646 (signatureType,_) <- instScheme(dataConRepType dc)
647 addConstraint myType signatureType
648 subTermsP <- sequence $ drop extra_args
649 -- \^^^ all extra arguments are pointed
650 [ appArr (go (pred bound) tv t) (ptrs clos) i
651 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
652 let unboxeds = extractUnboxed subTtypesNP clos
653 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
654 subTerms = reOrderTerms subTermsP subTermsNP
655 (drop extra_args subTtypes)
656 return (Term tv (Right dc) a subTerms)
657 -- The otherwise case: can be a Thunk,AP,PAP,etc.
659 return (Suspension tipe_clos tv a Nothing)
662 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
663 -- assumption: ^^^ looks through newtypes
664 , isVanillaDataCon dc --TODO non-vanilla case
665 = dataConInstArgTys dc ty_args
666 | otherwise = dataConRepArgTys dc
668 -- This is used to put together pointed and nonpointed subterms in the
670 reOrderTerms _ _ [] = []
671 reOrderTerms pointed unpointed (ty:tys)
672 | isPointed ty = ASSERT2(not(null pointed)
673 , ptext (sLit "reOrderTerms") $$
674 (ppr pointed $$ ppr unpointed))
675 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
676 | otherwise = ASSERT2(not(null unpointed)
677 , ptext (sLit "reOrderTerms") $$
678 (ppr pointed $$ ppr unpointed))
679 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
681 expandNewtypes t@Term{ ty=ty, subTerms=tt }
682 | Just (tc, args) <- splitNewTyConApp_maybe ty
684 , wrapped_type <- newTyConInstRhs tc args
685 , Just dc <- tyConSingleDataCon_maybe tc
686 , t' <- expandNewtypes t{ ty = wrapped_type
687 , subTerms = map expandNewtypes tt }
688 = NewtypeWrap ty (Right dc) t'
690 | otherwise = t{ subTerms = map expandNewtypes tt }
695 -- Fast, breadth-first Type reconstruction
696 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
697 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
698 tv <- newVar argTypeKind
700 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
702 (Seq.singleton (tv, hval))
704 zonkTcType tv -- TODO untested!
705 Just ty | isMonomorphic ty -> return ty
707 (ty',rev_subst) <- instScheme (sigmaType ty)
709 search (isMonomorphic `fmap` zonkTcType tv)
711 (Seq.singleton (tv, hval))
713 substTy rev_subst `fmap` zonkTcType tv
715 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
716 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
717 int max_depth <> text " steps")
718 search stop expand l d =
721 x :< xx -> unlessM stop $ do
723 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
725 -- returns unification tasks,since we are going to want a breadth-first search
726 go :: Type -> HValue -> TR [(Type, HValue)]
728 clos <- trIO $ getClosureData a
730 Indirection _ -> go tv $! (ptrs clos ! 0)
732 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
733 tv' <- newVar liftedTypeKind
734 world <- newVar liftedTypeKind
735 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
736 -- x <- go tv' ty_contents contents
737 return [(tv', contents)]
739 Right dcname <- dataConInfoPtrToName (infoPtr clos)
740 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
743 -- TODO: Check this case
744 forM [0..length (elems $ ptrs clos)] $ \i -> do
745 tv <- newVar liftedTypeKind
746 return$ appArr (\e->(tv,e)) (ptrs clos) i
749 let extra_args = length(dataConRepArgTys dc) -
750 length(dataConOrigArgTys dc)
751 subTtypes <- mapMif (not . isMonomorphic)
752 (\t -> newVar (typeKind t))
753 (dataConRepArgTys dc)
755 -- It is vital for newtype reconstruction that the unification step
756 -- is done right here, _before_ the subterms are RTTI reconstructed
757 let myType = mkFunTys subTtypes tv
758 (signatureType,_) <- instScheme(dataConRepType dc)
759 addConstraint myType signatureType
760 return $ [ appArr (\e->(t,e)) (ptrs clos) i
761 | (i,t) <- drop extra_args $
762 zip [0..] (filter isPointed subTtypes)]
765 -- Compute the difference between a base type and the type found by RTTI
766 -- improveType <base_type> <rtti_type>
767 -- The types can contain skolem type variables, which need to be treated as normal vars.
768 -- In particular, we want them to unify with things.
769 improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst)
770 improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
771 let (_,ty0) = splitForAllTys ty
772 ty_tvs = varSetElems $ tyVarsOfType ty0
773 let (_,rtti_ty0)= splitForAllTys rtti_ty
774 rtti_tvs = varSetElems $ tyVarsOfType rtti_ty0
775 (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs [] ty0)
776 (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
777 boxyUnify rtti_ty' ty'
778 tvs1_contents <- zonkTcTyVars ty_tvs'
779 let subst = uncurry zipTopTvSubst
780 (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
781 , getTyVar_maybe ty /= Just tv
782 , not(isTyVarTy ty)])
783 -- liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
786 -- Dealing with newtypes
788 congruenceNewtypes does a parallel fold over two Type values,
789 compensating for missing newtypes on both sides.
790 This is necessary because newtypes are not present
791 in runtime, but sometimes there is evidence available.
792 Evidence can come from DataCon signatures or
793 from compile-time type inference.
794 What we are doing here is an approximation
795 of unification modulo a set of equations derived
796 from newtype definitions. These equations should be the
797 same as the equality coercions generated for newtypes
798 in System Fc. The idea is to perform a sort of rewriting,
799 taking those equations as rules, before launching unification.
801 The caller must ensure the following.
802 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
803 The 2nd type (rhs) comes from a DataCon type signature.
804 Rewriting (i.e. adding/removing a newtype wrapper) can happen
805 in both types, but in the rhs it is restricted to the result type.
807 Note that it is very tricky to make this 'rewriting'
808 work with the unification implemented by TcM, where
809 substitutions are operationally inlined. The order in which
810 constraints are unified is vital as we cannot modify
811 anything that has been touched by a previous unification step.
812 Therefore, congruenceNewtypes is sound only if the types
813 recovered by the RTTI mechanism are unified Top-Down.
815 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
816 congruenceNewtypes lhs rhs
817 -- TyVar lhs inductive case
818 | Just tv <- getTyVar_maybe lhs
819 = recoverTc (return (lhs,rhs)) $ do
820 Indirect ty_v <- readMetaTyVar tv
821 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
823 -- FunTy inductive case
824 | Just (l1,l2) <- splitFunTy_maybe lhs
825 , Just (r1,r2) <- splitFunTy_maybe rhs
826 = do (l2',r2') <- congruenceNewtypes l2 r2
827 (l1',r1') <- congruenceNewtypes l1 r1
828 return (mkFunTy l1' l2', mkFunTy r1' r2')
829 -- TyconApp Inductive case; this is the interesting bit.
830 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
831 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
833 = do rhs' <- upgrade tycon_l rhs
836 | otherwise = return (lhs,rhs)
838 where upgrade :: TyCon -> Type -> TR Type
840 | not (isNewTyCon new_tycon) = return ty
842 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
843 let ty' = mkTyConApp new_tycon vars
844 liftTcM (unifyType ty (repType ty'))
845 -- assumes that reptype doesn't ^^^^ touch tyconApp args
849 --------------------------------------------------------------------------------
850 -- Semantically different to recoverM in TcRnMonad
851 -- recoverM retains the errors in the first action,
852 -- whereas recoverTc here does not
853 recoverTc :: TcM a -> TcM a -> TcM a
854 recoverTc recover thing = do
855 (_,mb_res) <- tryTcErrs thing
858 Just res -> return res
860 isMonomorphic :: Type -> Bool
861 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
862 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
864 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
865 mapMif pred f xx = sequence $ mapMif_ pred f xx
868 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
870 unlessM :: Monad m => m Bool -> m () -> m ()
871 unlessM condM acc = condM >>= \c -> unless c acc
873 -- Strict application of f at index i
874 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
875 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
876 = ASSERT (i < length(elems a))
877 case indexArray# ptrs# i# of
880 zonkTerm :: Term -> TcM Term
881 zonkTerm = foldTerm idTermFoldM {
882 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
883 zonkTcType ty >>= \ty' ->
884 return (Term ty' dc v tt)
885 ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
886 return (Suspension ct ty v b)
887 ,fNewtypeWrap= \ty dc t ->
888 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
891 -- Is this defined elsewhere?
892 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
893 sigmaType :: Type -> Type
894 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty