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 )
52 import TcRnMonad ( TcM, initTc, ioToTcRn,
75 import GHC.Arr ( Array(..) )
80 import Data.Array.Base
82 import Data.List ( partition )
83 import qualified Data.Sequence as Seq
85 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
87 import System.IO.Unsafe
89 ---------------------------------------------
90 -- * A representation of semi evaluated Terms
91 ---------------------------------------------
93 A few examples in this representation:
95 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
97 > (('a',_,_),_,('b',_,_)) =
98 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
99 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
101 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
104 data Term = Term { ty :: Type
105 , dc :: Either String 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
119 | NewtypeWrap{ ty :: Type
120 , dc :: Either String DataCon
121 , wrapped_term :: Term }
123 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
126 isSuspension Suspension{} = True
127 isSuspension _ = False
130 isNewtypeWrap NewtypeWrap{} = True
131 isNewtypeWrap _ = False
133 termType :: Term -> Maybe Type
134 termType t@(Suspension {}) = mb_ty t
135 termType t = Just$ ty t
137 isFullyEvaluatedTerm :: Term -> Bool
138 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
139 isFullyEvaluatedTerm Prim {} = True
140 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
141 isFullyEvaluatedTerm _ = False
143 instance Outputable (Term) where
144 ppr = head . cPprTerm cPprTermBase
146 -------------------------------------------------------------------------
147 -- Runtime Closure Datatype and functions for retrieving closure related stuff
148 -------------------------------------------------------------------------
149 data ClosureType = Constr
160 data Closure = Closure { tipe :: ClosureType
162 , infoTable :: StgInfoTable
163 , ptrs :: Array Int HValue
167 instance Outputable ClosureType where
170 #include "../includes/ClosureTypes.h"
172 aP_CODE, pAP_CODE :: Int
178 getClosureData :: a -> IO Closure
180 case unpackClosure# a of
181 (# iptr, ptrs, nptrs #) -> do
182 #ifndef GHCI_TABLES_NEXT_TO_CODE
183 -- the info pointer we get back from unpackClosure# is to the
184 -- beginning of the standard info table, but the Storable instance
185 -- for info tables takes into account the extra entry pointer
186 -- when !tablesNextToCode, so we must adjust here:
187 itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
189 itbl <- peek (Ptr iptr)
191 let tipe = readCType (BCI.tipe itbl)
192 elems = fromIntegral (BCI.ptrs itbl)
193 ptrsList = Array 0 (elems - 1) elems ptrs
194 nptrs_data = [W# (indexWordArray# nptrs i)
195 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
196 ASSERT(elems >= 0) return ()
198 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
200 readCType :: Integral a => a -> ClosureType
202 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
203 | i >= FUN && i <= FUN_STATIC = Fun
204 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
205 | i == THUNK_SELECTOR = ThunkSelector
206 | i == BLACKHOLE = Blackhole
207 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
208 | fromIntegral i == aP_CODE = AP
210 | fromIntegral i == pAP_CODE = PAP
211 | otherwise = Other (fromIntegral i)
213 isConstr, isIndirection, isThunk :: ClosureType -> Bool
214 isConstr Constr = True
217 isIndirection (Indirection _) = True
218 --isIndirection ThunkSelector = True
219 isIndirection _ = False
221 isThunk (Thunk _) = True
222 isThunk ThunkSelector = True
226 isFullyEvaluated :: a -> IO Bool
227 isFullyEvaluated a = do
228 closure <- getClosureData a
230 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
231 return$ and are_subs_evaluated
233 where amapM f = sequence . amap' f
235 amap' :: (t -> b) -> Array Int t -> [b]
236 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
237 where g (I# i#) = case indexArray# arr# i# of
240 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
242 unsafeDeepSeq :: a -> b -> b
243 unsafeDeepSeq = unsafeDeepSeq1 2
244 where unsafeDeepSeq1 0 a b = seq a $! b
245 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
246 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
247 -- | unsafePerformIO (isFullyEvaluated a) = b
248 | otherwise = case unsafePerformIO (getClosureData a) of
249 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
250 where tipe = unsafePerformIO (getClosureType a)
252 isPointed :: Type -> Bool
253 isPointed t | Just (t, _) <- splitTyConApp_maybe t
254 = not$ isUnliftedTypeKind (tyConKind t)
257 extractUnboxed :: [Type] -> Closure -> [[Word]]
258 extractUnboxed tt clos = go tt (nonPtrs clos)
260 | Just (tycon,_) <- splitTyConApp_maybe t
261 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
262 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
265 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
268 sizeofTyCon :: TyCon -> Int
269 sizeofTyCon = sizeofPrimRep . tyConPrimRep
271 -----------------------------------
272 -- * Traversals for Terms
273 -----------------------------------
274 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
276 data TermFold a = TermFold { fTerm :: TermProcessor a a
277 , fPrim :: Type -> [Word] -> a
278 , fSuspension :: ClosureType -> Maybe Type -> HValue
280 , fNewtypeWrap :: Type -> Either String DataCon
284 foldTerm :: TermFold a -> Term -> a
285 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
286 foldTerm tf (Prim ty v ) = fPrim tf ty v
287 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
288 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
290 idTermFold :: TermFold Term
291 idTermFold = TermFold {
294 fSuspension = Suspension,
295 fNewtypeWrap = NewtypeWrap
297 idTermFoldM :: Monad m => TermFold (m Term)
298 idTermFoldM = TermFold {
299 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
300 fPrim = (return.). Prim,
301 fSuspension = (((return.).).). Suspension,
302 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t
305 mapTermType :: (Type -> Type) -> Term -> Term
306 mapTermType f = foldTerm idTermFold {
307 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
308 fSuspension = \ct mb_ty hval n ->
309 Suspension ct (fmap f mb_ty) hval n,
310 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t}
312 termTyVars :: Term -> TyVarSet
313 termTyVars = foldTerm TermFold {
314 fTerm = \ty _ _ tt ->
315 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
316 fSuspension = \_ mb_ty _ _ ->
317 maybe emptyVarEnv tyVarsOfType mb_ty,
318 fPrim = \ _ _ -> emptyVarEnv,
319 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t}
320 where concatVarEnv = foldr plusVarEnv emptyVarEnv
322 ----------------------------------
323 -- Pretty printing of terms
324 ----------------------------------
326 type Precedence = Int
327 type TermPrinter = Precedence -> Term -> SDoc
328 type TermPrinterM m = Precedence -> Term -> m SDoc
330 app_prec,cons_prec ::Int
332 cons_prec = 5 -- TODO Extract this info from GHC itself
334 pprTerm :: TermPrinter -> TermPrinter
335 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
336 pprTerm _ _ _ = panic "pprTerm"
338 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
339 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
341 pprTermM1, ppr_termM1 :: Monad m => Term -> m SDoc
342 pprTermM1 t = pprDeeper `liftM` ppr_termM1 t
344 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
345 tt_docs <- mapM (y app_prec) tt
346 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
348 ppr_termM y p Term{dc=Right dc, subTerms=tt}
349 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
350 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
351 <+> hsep (map (ppr_term1 True) tt)
352 -} -- TODO Printing infix constructors properly
353 | null tt = return$ ppr dc
355 tt_docs <- mapM (y app_prec) tt
356 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
358 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
360 ppr_termM _ _ t = ppr_termM1 t
363 ppr_termM1 Prim{value=words, ty=ty} =
364 return$ text$ repPrim (tyConAppTyCon ty) words
365 ppr_termM1 Term{} = panic "ppr_termM1 - unreachable"
366 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
367 ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
368 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
369 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
370 ppr_termM1 _ = panic "ppr_termM1"
372 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
373 | Just (tc,_) <- splitNewTyConApp_maybe ty
374 , ASSERT(isNewTyCon tc) True
375 , Just new_dc <- maybeTyConSingleCon tc = do
377 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
378 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
380 -------------------------------------------------------
381 -- Custom Term Pretty Printers
382 -------------------------------------------------------
384 -- We can want to customize the representation of a
385 -- term depending on its type.
386 -- However, note that custom printers have to work with
387 -- type representations, instead of directly with types.
388 -- We cannot use type classes here, unless we employ some
389 -- typerep trickery (e.g. Weirich's RepLib tricks),
390 -- which I didn't. Therefore, this code replicates a lot
391 -- of what type classes provide for free.
393 type CustomTermPrinter m = TermPrinterM m
394 -> [Precedence -> Term -> (m (Maybe SDoc))]
396 -- | Takes a list of custom printers with a explicit recursion knot and a term,
397 -- and returns the output of the first succesful printer, or the default printer
398 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
399 cPprTerm printers_ = go 0 where
400 printers = printers_ go
401 go prec t | isTerm t || isNewtypeWrap t = do
402 let default_ = Just `liftM` pprTermM go prec t
403 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
404 Just doc <- firstJustM mb_customDocs
405 return$ cparen (prec>app_prec+1) doc
408 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
409 firstJustM [] = return Nothing
411 -- Default set of custom printers. Note that the recursion knot is explicit
412 cPprTermBase :: Monad m => CustomTermPrinter m
414 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
417 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
418 (\ p Term{subTerms=[h,t]} -> doList p h t)
419 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
420 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
421 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
422 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
423 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
425 where ifTerm pred f prec t@Term{}
426 | pred t = Just `liftM` f prec t
427 ifTerm _ _ _ _ = return Nothing
429 isIntegerTy ty = fromMaybe False $ do
430 (tc,_) <- splitTyConApp_maybe ty
431 return (tyConName tc == integerTyConName)
433 isTupleTy ty = fromMaybe False $ do
434 (tc,_) <- splitTyConApp_maybe ty
435 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
437 isTyCon a_tc ty = fromMaybe False $ do
438 (tc,_) <- splitTyConApp_maybe ty
441 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
443 --NOTE pprinting of list terms is not lazy
445 let elems = h : getListTerms t
446 isConsLast = termType(last elems) /= termType h
447 print_elems <- mapM (y cons_prec) elems
448 return$ if isConsLast
449 then cparen (p >= cons_prec)
451 . punctuate (space<>colon)
453 else brackets (pprDeeperList fcat$
454 punctuate comma print_elems)
456 where Just a /= Just b = not (a `coreEqType` b)
458 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
459 getListTerms Term{subTerms=[]} = []
460 getListTerms t@Suspension{} = [t]
461 getListTerms t = pprPanic "getListTerms" (ppr t)
464 repPrim :: TyCon -> [Word] -> String
465 repPrim t = rep where
467 | t == charPrimTyCon = show (build x :: Char)
468 | t == intPrimTyCon = show (build x :: Int)
469 | t == wordPrimTyCon = show (build x :: Word)
470 | t == floatPrimTyCon = show (build x :: Float)
471 | t == doublePrimTyCon = show (build x :: Double)
472 | t == int32PrimTyCon = show (build x :: Int32)
473 | t == word32PrimTyCon = show (build x :: Word32)
474 | t == int64PrimTyCon = show (build x :: Int64)
475 | t == word64PrimTyCon = show (build x :: Word64)
476 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
477 | t == stablePtrPrimTyCon = "<stablePtr>"
478 | t == stableNamePrimTyCon = "<stableName>"
479 | t == statePrimTyCon = "<statethread>"
480 | t == realWorldTyCon = "<realworld>"
481 | t == threadIdPrimTyCon = "<ThreadId>"
482 | t == weakPrimTyCon = "<Weak>"
483 | t == arrayPrimTyCon = "<array>"
484 | t == byteArrayPrimTyCon = "<bytearray>"
485 | t == mutableArrayPrimTyCon = "<mutableArray>"
486 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
487 | t == mutVarPrimTyCon= "<mutVar>"
488 | t == mVarPrimTyCon = "<mVar>"
489 | t == tVarPrimTyCon = "<tVar>"
490 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
491 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
492 -- This ^^^ relies on the representation of Haskell heap values being
493 -- the same as in a C array.
495 -----------------------------------
496 -- Type Reconstruction
497 -----------------------------------
499 Type Reconstruction is type inference done on heap closures.
500 The algorithm walks the heap generating a set of equations, which
501 are solved with syntactic unification.
502 A type reconstruction equation looks like:
504 <datacon reptype> = <actual heap contents>
506 The full equation set is generated by traversing all the subterms, starting
509 The only difficult part is that newtypes are only found in the lhs of equations.
510 Right hand sides are missing them. We can either (a) drop them from the lhs, or
511 (b) reconstruct them in the rhs when possible.
513 The function congruenceNewtypes takes a shot at (b)
516 -- The Type Reconstruction monad
519 runTR :: HscEnv -> TR a -> IO a
521 mb_term <- runTR_maybe hsc_env c
523 Nothing -> panic "Can't unify"
526 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
527 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
529 traceTR :: SDoc -> TR ()
530 traceTR = liftTcM . traceTc
533 trIO = liftTcM . ioToTcRn
535 liftTcM :: TcM a -> TR a
538 newVar :: Kind -> TR TcType
539 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
541 -- | Returns the instantiated type scheme ty', and the substitution sigma
542 -- such that sigma(ty') = ty
543 instScheme :: Type -> TR (TcType, TvSubst)
544 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
545 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
546 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
548 -- Adds a constraint of the form t1 == t2
549 -- t1 is expected to come from walking the heap
550 -- t2 is expected to come from a datacon signature
551 -- Before unification, congruenceNewtypes needs to
553 addConstraint :: TcType -> TcType -> TR ()
554 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
555 >> return () -- TOMDO: what about the coercion?
556 -- we should consider family instances
558 -- Type & Term reconstruction
559 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
560 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
561 tv <- newVar argTypeKind
563 Nothing -> go bound tv tv hval
565 >>= return . expandNewtypes
566 Just ty | isMonomorphic ty -> go bound ty ty hval
568 >>= return . expandNewtypes
570 (ty',rev_subst) <- instScheme (sigmaType ty)
572 term <- go bound tv tv hval >>= zonkTerm
573 --restore original Tyvars
574 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
576 go bound _ _ _ | seq bound False = undefined
578 clos <- trIO $ getClosureData a
579 return (Suspension (tipe clos) (Just tv) a Nothing)
580 go bound tv ty a = do
581 let monomorphic = not(isTyVarTy tv)
582 -- This ^^^ is a convention. The ancestor tests for
583 -- monomorphism and passes a type instead of a tv
584 clos <- trIO $ getClosureData a
586 -- Thunks we may want to force
587 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
588 -- force blackholes, because it would almost certainly result in deadlock,
589 -- and showing the '_' is more useful.
590 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
591 -- We always follow indirections
592 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
593 -- The interesting case
595 Right dcname <- dataConInfoPtrToName (infoPtr clos)
596 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
598 Nothing -> do -- This can happen for private constructors compiled -O0
599 -- where the .hi descriptor does not export them
600 -- In such case, we return a best approximation:
601 -- ignore the unpointed args, and recover the pointeds
602 -- This preserves laziness, and should be safe.
603 let tag = showSDoc (ppr dcname)
604 vars <- replicateM (length$ elems$ ptrs clos)
605 (newVar (liftedTypeKind))
606 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
607 | (i, tv) <- zip [0..] vars]
608 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
610 let extra_args = length(dataConRepArgTys dc) -
611 length(dataConOrigArgTys dc)
612 subTtypes = matchSubTypes dc ty
613 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
614 subTermTvs <- sequence
615 [ if isMonomorphic t then return t
617 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
618 -- It is vital for newtype reconstruction that the unification step
619 -- is done right here, _before_ the subterms are RTTI reconstructed
620 when (not monomorphic) $ do
621 let myType = mkFunTys (reOrderTerms subTermTvs
625 (signatureType,_) <- instScheme(dataConRepType dc)
626 addConstraint myType signatureType
627 subTermsP <- sequence $ drop extra_args
628 -- ^^^ all extra arguments are pointed
629 [ appArr (go (pred bound) tv t) (ptrs clos) i
630 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
631 let unboxeds = extractUnboxed subTtypesNP clos
632 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
633 subTerms = reOrderTerms subTermsP subTermsNP
634 (drop extra_args subTtypes)
635 return (Term tv (Right dc) a subTerms)
636 -- The otherwise case: can be a Thunk,AP,PAP,etc.
638 return (Suspension tipe_clos (Just tv) a Nothing)
641 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
642 -- assumption: ^^^ looks through newtypes
643 , isVanillaDataCon dc --TODO non-vanilla case
644 = dataConInstArgTys dc ty_args
645 | otherwise = dataConRepArgTys dc
647 -- This is used to put together pointed and nonpointed subterms in the
649 reOrderTerms _ _ [] = []
650 reOrderTerms pointed unpointed (ty:tys)
651 | isPointed ty = ASSERT2(not(null pointed)
652 , ptext SLIT("reOrderTerms") $$
653 (ppr pointed $$ ppr unpointed))
654 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
655 | otherwise = ASSERT2(not(null unpointed)
656 , ptext SLIT("reOrderTerms") $$
657 (ppr pointed $$ ppr unpointed))
658 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
660 expandNewtypes t@Term{ ty=ty, subTerms=tt }
661 | Just (tc, args) <- splitNewTyConApp_maybe ty
663 , wrapped_type <- newTyConInstRhs tc args
664 , Just dc <- maybeTyConSingleCon tc
665 , t' <- expandNewtypes t{ ty = wrapped_type
666 , subTerms = map expandNewtypes tt }
667 = NewtypeWrap ty (Right dc) t'
669 | otherwise = t{ subTerms = map expandNewtypes tt }
674 -- Fast, breadth-first Type reconstruction
675 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
676 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
677 tv <- newVar argTypeKind
679 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
681 (Seq.singleton (tv, hval))
683 zonkTcType tv -- TODO untested!
684 Just ty | isMonomorphic ty -> return ty
686 (ty',rev_subst) <- instScheme (sigmaType ty)
688 search (isMonomorphic `fmap` zonkTcType tv)
690 (Seq.singleton (tv, hval))
692 substTy rev_subst `fmap` zonkTcType tv
694 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
695 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
696 int max_depth <> text " steps")
697 search stop expand l d =
700 x :< xx -> unlessM stop $ do
702 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
704 -- returns unification tasks,since we are going to want a breadth-first search
705 go :: Type -> HValue -> TR [(Type, HValue)]
707 clos <- trIO $ getClosureData a
709 Indirection _ -> go tv $! (ptrs clos ! 0)
711 Right dcname <- dataConInfoPtrToName (infoPtr clos)
712 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
715 -- TODO: Check this case
716 forM [0..length (elems $ ptrs clos)] $ \i -> do
717 tv <- newVar liftedTypeKind
718 return$ appArr (\e->(tv,e)) (ptrs clos) i
721 let extra_args = length(dataConRepArgTys dc) -
722 length(dataConOrigArgTys dc)
723 subTtypes <- mapMif (not . isMonomorphic)
724 (\t -> newVar (typeKind t))
725 (dataConRepArgTys dc)
727 -- It is vital for newtype reconstruction that the unification step
728 -- is done right here, _before_ the subterms are RTTI reconstructed
729 let myType = mkFunTys subTtypes tv
730 (signatureType,_) <- instScheme(dataConRepType dc)
731 addConstraint myType signatureType
732 return $ [ appArr (\e->(t,e)) (ptrs clos) i
733 | (i,t) <- drop extra_args $
734 zip [0..] (filter isPointed subTtypes)]
737 -- This helper computes the difference between a base type t and the
738 -- improved rtti_t computed by RTTI
739 -- The main difference between RTTI types and their normal counterparts
740 -- is that the former are _not_ polymorphic, thus polymorphism must
741 -- be stripped. Syntactically, forall's must be stripped.
742 -- We also remove predicates.
743 computeRTTIsubst :: Type -> Type -> TvSubst
744 computeRTTIsubst ty rtti_ty =
747 Nothing -> pprPanic "Failed to compute a RTTI substitution"
749 -- In addition, we strip newtypes too, since the reconstructed type might
750 -- not have recovered them all
751 -- TODO stripping newtypes shouldn't be necessary, test
752 where mb_subst = tcUnifyTys (const BindMe)
756 -- Dealing with newtypes
758 A parallel fold over two Type values,
759 compensating for missing newtypes on both sides.
760 This is necessary because newtypes are not present
761 in runtime, but since sometimes there is evidence
762 available we do our best to reconstruct them.
763 Evidence can come from DataCon signatures or
764 from compile-time type inference.
765 I am using the words congruence and rewriting
766 because what we are doing here is an approximation
767 of unification modulo a set of equations, which would
768 come from newtype definitions. These should be the
769 equality coercions seen in System Fc. Rewriting
770 is performed, taking those equations as rules,
771 before launching unification.
773 It doesn't make sense to rewrite everywhere,
774 or we would end up with all newtypes. So we rewrite
775 only in presence of evidence.
776 The lhs comes from the heap structure of ptrs,nptrs.
777 The rhs comes from a DataCon type signature.
778 Rewriting in the rhs is restricted to the result type.
780 Note that it is very tricky to make this 'rewriting'
781 work with the unification implemented by TcM, where
782 substitutions are 'inlined'. The order in which
783 constraints are unified is vital for this.
784 This is a simple form of residuation, the technique of
785 delaying unification steps until enough information
788 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
789 congruenceNewtypes lhs rhs
790 -- TyVar lhs inductive case
791 | Just tv <- getTyVar_maybe lhs
792 = recoverTc (return (lhs,rhs)) $ do
793 Indirect ty_v <- readMetaTyVar tv
794 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
796 -- FunTy inductive case
797 | Just (l1,l2) <- splitFunTy_maybe lhs
798 , Just (r1,r2) <- splitFunTy_maybe rhs
799 = do (l2',r2') <- congruenceNewtypes l2 r2
800 (l1',r1') <- congruenceNewtypes l1 r1
801 return (mkFunTy l1' l2', mkFunTy r1' r2')
802 -- TyconApp Inductive case; this is the interesting bit.
803 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
804 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
806 = do rhs' <- upgrade tycon_l rhs
809 | otherwise = return (lhs,rhs)
811 where upgrade :: TyCon -> Type -> TR Type
813 | not (isNewTyCon new_tycon) = return ty
815 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
816 let ty' = mkTyConApp new_tycon vars
817 liftTcM (unifyType ty (repType ty'))
818 -- assumes that reptype doesn't ^^^^ touch tyconApp args
822 --------------------------------------------------------------------------------
823 -- Semantically different to recoverM in TcRnMonad
824 -- recoverM retains the errors in the first action,
825 -- whereas recoverTc here does not
826 recoverTc :: TcM a -> TcM a -> TcM a
827 recoverTc recover thing = do
828 (_,mb_res) <- tryTcErrs thing
831 Just res -> return res
833 isMonomorphic :: Type -> Bool
834 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
835 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
837 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
838 mapMif pred f xx = sequence $ mapMif_ pred f xx
841 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
843 unlessM :: Monad m => m Bool -> m () -> m ()
844 unlessM condM acc = condM >>= \c -> unless c acc
846 -- Strict application of f at index i
847 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
848 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
849 = ASSERT (i < length(elems a))
850 case indexArray# ptrs# i# of
853 zonkTerm :: Term -> TcM Term
854 zonkTerm = foldTerm idTermFoldM {
855 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
856 zonkTcType ty >>= \ty' ->
857 return (Term ty' dc v tt)
858 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
859 return (Suspension ct ty v b)
860 ,fNewtypeWrap= \ty dc t ->
861 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
864 -- Is this defined elsewhere?
865 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
866 sigmaType :: Type -> Type
867 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty