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 app_prec,cons_prec ::Int
328 cons_prec = 5 -- TODO Extract this info from GHC itself
330 pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
331 pprTerm y p t | Just doc <- pprTermM y p t = doc
332 pprTerm _ _ _ = panic "pprTerm"
334 pprTermM, pprNewtypeWrap :: Monad m =>
335 (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
336 pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
337 tt_docs <- mapM (y app_prec) tt
338 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> fsep tt_docs)
340 pprTermM y p Term{dc=Right dc, subTerms=tt}
341 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
342 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
343 <+> hsep (map (pprTerm1 True) tt)
344 -} -- TODO Printing infix constructors properly
345 | null tt = return$ ppr dc
347 tt_docs <- mapM (y app_prec) tt
348 return$ cparen (p >= app_prec) (ppr dc <+> fsep tt_docs)
350 pprTermM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
352 pprTermM _ _ t = pprTermM1 t
354 pprTermM1 :: Monad m => Term -> m SDoc
355 pprTermM1 Prim{value=words, ty=ty} =
356 return$ text$ repPrim (tyConAppTyCon ty) words
357 pprTermM1 Term{} = panic "pprTermM1 - unreachable"
358 pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
359 pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
360 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
361 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
362 pprTermM1 _ = panic "pprTermM1"
364 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
365 | Just (tc,_) <- splitNewTyConApp_maybe ty
366 , ASSERT(isNewTyCon tc) True
367 , Just new_dc <- maybeTyConSingleCon tc = do
369 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
370 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
372 -------------------------------------------------------
373 -- Custom Term Pretty Printers
374 -------------------------------------------------------
376 -- We can want to customize the representation of a
377 -- term depending on its type.
378 -- However, note that custom printers have to work with
379 -- type representations, instead of directly with types.
380 -- We cannot use type classes here, unless we employ some
381 -- typerep trickery (e.g. Weirich's RepLib tricks),
382 -- which I didn't. Therefore, this code replicates a lot
383 -- of what type classes provide for free.
385 -- Concretely a custom term printer takes an explicit
386 -- recursion knot, and produces a list of Term Processors,
387 -- which additionally need a precedence value to
388 -- either produce a SDoc or fail (and they do this in some monad m).
390 type Precedence = Int
391 type RecursionKnot m = Precedence -> Term -> m SDoc
392 type CustomTermPrinter m = RecursionKnot m
393 -> [Precedence -> Term -> (m (Maybe SDoc))]
395 -- Takes a list of custom printers with a explicit recursion knot and a term,
396 -- and returns the output of the first succesful printer, or the default printer
397 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
398 cPprTerm printers_ = go 0 where
399 printers = printers_ go
400 go prec t | isTerm t || isNewtypeWrap t = do
401 let default_ = Just `liftM` pprTermM go prec t
402 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
403 Just doc <- firstJustM mb_customDocs
404 return$ cparen (prec>app_prec+1) doc
407 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
408 firstJustM [] = return Nothing
410 -- Default set of custom printers. Note that the recursion knot is explicit
411 cPprTermBase :: Monad m => CustomTermPrinter m
413 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
416 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
417 (\ p Term{subTerms=[h,t]} -> doList p h t)
418 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
419 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
420 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
421 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
422 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
424 where ifTerm pred f prec t@Term{}
425 | pred t = Just `liftM` f prec t
426 ifTerm _ _ _ _ = return Nothing
428 isIntegerTy ty = fromMaybe False $ do
429 (tc,_) <- splitTyConApp_maybe ty
430 return (tyConName tc == integerTyConName)
432 isTupleTy ty = fromMaybe False $ do
433 (tc,_) <- splitTyConApp_maybe ty
434 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
436 isTyCon a_tc ty = fromMaybe False $ do
437 (tc,_) <- splitTyConApp_maybe ty
440 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
442 --TODO pprinting of list terms is not lazy
444 let elems = h : getListTerms t
445 isConsLast = termType(last elems) /= termType h
446 print_elems <- mapM (y cons_prec) elems
447 return$ if isConsLast
448 then cparen (p >= cons_prec)
450 . punctuate (space<>colon)
452 else brackets (fsep$ punctuate comma print_elems)
454 where Just a /= Just b = not (a `coreEqType` b)
456 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
457 getListTerms Term{subTerms=[]} = []
458 getListTerms t@Suspension{} = [t]
459 getListTerms t = pprPanic "getListTerms" (ppr t)
462 repPrim :: TyCon -> [Word] -> String
463 repPrim t = rep where
465 | t == charPrimTyCon = show (build x :: Char)
466 | t == intPrimTyCon = show (build x :: Int)
467 | t == wordPrimTyCon = show (build x :: Word)
468 | t == floatPrimTyCon = show (build x :: Float)
469 | t == doublePrimTyCon = show (build x :: Double)
470 | t == int32PrimTyCon = show (build x :: Int32)
471 | t == word32PrimTyCon = show (build x :: Word32)
472 | t == int64PrimTyCon = show (build x :: Int64)
473 | t == word64PrimTyCon = show (build x :: Word64)
474 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
475 | t == stablePtrPrimTyCon = "<stablePtr>"
476 | t == stableNamePrimTyCon = "<stableName>"
477 | t == statePrimTyCon = "<statethread>"
478 | t == realWorldTyCon = "<realworld>"
479 | t == threadIdPrimTyCon = "<ThreadId>"
480 | t == weakPrimTyCon = "<Weak>"
481 | t == arrayPrimTyCon = "<array>"
482 | t == byteArrayPrimTyCon = "<bytearray>"
483 | t == mutableArrayPrimTyCon = "<mutableArray>"
484 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
485 | t == mutVarPrimTyCon= "<mutVar>"
486 | t == mVarPrimTyCon = "<mVar>"
487 | t == tVarPrimTyCon = "<tVar>"
488 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
489 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
490 -- This ^^^ relies on the representation of Haskell heap values being
491 -- the same as in a C array.
493 -----------------------------------
494 -- Type Reconstruction
495 -----------------------------------
497 Type Reconstruction is type inference done on heap closures.
498 The algorithm walks the heap generating a set of equations, which
499 are solved with syntactic unification.
500 A type reconstruction equation looks like:
502 <datacon reptype> = <actual heap contents>
504 The full equation set is generated by traversing all the subterms, starting
507 The only difficult part is that newtypes are only found in the lhs of equations.
508 Right hand sides are missing them. We can either (a) drop them from the lhs, or
509 (b) reconstruct them in the rhs when possible.
511 The function congruenceNewtypes takes a shot at (b)
514 -- The Type Reconstruction monad
517 runTR :: HscEnv -> TR a -> IO a
519 mb_term <- runTR_maybe hsc_env c
521 Nothing -> panic "Can't unify"
524 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
525 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
527 traceTR :: SDoc -> TR ()
528 traceTR = liftTcM . traceTc
531 trIO = liftTcM . ioToTcRn
533 liftTcM :: TcM a -> TR a
536 newVar :: Kind -> TR TcType
537 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
539 -- | Returns the instantiated type scheme ty', and the substitution sigma
540 -- such that sigma(ty') = ty
541 instScheme :: Type -> TR (TcType, TvSubst)
542 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
543 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
544 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
546 -- Adds a constraint of the form t1 == t2
547 -- t1 is expected to come from walking the heap
548 -- t2 is expected to come from a datacon signature
549 -- Before unification, congruenceNewtypes needs to
551 addConstraint :: TcType -> TcType -> TR ()
552 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
553 >> return () -- TOMDO: what about the coercion?
554 -- we should consider family instances
556 -- Type & Term reconstruction
557 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
558 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
559 tv <- newVar argTypeKind
561 Nothing -> go bound tv tv hval
563 >>= return . expandNewtypes
564 Just ty | isMonomorphic ty -> go bound ty ty hval
566 >>= return . expandNewtypes
568 (ty',rev_subst) <- instScheme (sigmaType ty)
570 term <- go bound tv tv hval >>= zonkTerm
571 --restore original Tyvars
572 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
574 go bound _ _ _ | seq bound False = undefined
576 clos <- trIO $ getClosureData a
577 return (Suspension (tipe clos) (Just tv) a Nothing)
578 go bound tv ty a = do
579 let monomorphic = not(isTyVarTy tv)
580 -- This ^^^ is a convention. The ancestor tests for
581 -- monomorphism and passes a type instead of a tv
582 clos <- trIO $ getClosureData a
584 -- Thunks we may want to force
585 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
586 -- force blackholes, because it would almost certainly result in deadlock,
587 -- and showing the '_' is more useful.
588 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
589 -- We always follow indirections
590 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
591 -- The interesting case
593 Right dcname <- dataConInfoPtrToName (infoPtr clos)
594 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
596 Nothing -> do -- This can happen for private constructors compiled -O0
597 -- where the .hi descriptor does not export them
598 -- In such case, we return a best approximation:
599 -- ignore the unpointed args, and recover the pointeds
600 -- This preserves laziness, and should be safe.
601 let tag = showSDoc (ppr dcname)
602 vars <- replicateM (length$ elems$ ptrs clos)
603 (newVar (liftedTypeKind))
604 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
605 | (i, tv) <- zip [0..] vars]
606 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
608 let extra_args = length(dataConRepArgTys dc) -
609 length(dataConOrigArgTys dc)
610 subTtypes = matchSubTypes dc ty
611 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
612 subTermTvs <- sequence
613 [ if isMonomorphic t then return t
615 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
616 -- It is vital for newtype reconstruction that the unification step
617 -- is done right here, _before_ the subterms are RTTI reconstructed
618 when (not monomorphic) $ do
619 let myType = mkFunTys (reOrderTerms subTermTvs
623 (signatureType,_) <- instScheme(dataConRepType dc)
624 addConstraint myType signatureType
625 subTermsP <- sequence $ drop extra_args
626 -- ^^^ all extra arguments are pointed
627 [ appArr (go (pred bound) tv t) (ptrs clos) i
628 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
629 let unboxeds = extractUnboxed subTtypesNP clos
630 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
631 subTerms = reOrderTerms subTermsP subTermsNP
632 (drop extra_args subTtypes)
633 return (Term tv (Right dc) a subTerms)
634 -- The otherwise case: can be a Thunk,AP,PAP,etc.
636 return (Suspension tipe_clos (Just tv) a Nothing)
639 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
640 -- assumption: ^^^ looks through newtypes
641 , isVanillaDataCon dc --TODO non-vanilla case
642 = dataConInstArgTys dc ty_args
643 | otherwise = dataConRepArgTys dc
645 -- This is used to put together pointed and nonpointed subterms in the
647 reOrderTerms _ _ [] = []
648 reOrderTerms pointed unpointed (ty:tys)
649 | isPointed ty = ASSERT2(not(null pointed)
650 , ptext SLIT("reOrderTerms") $$
651 (ppr pointed $$ ppr unpointed))
652 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
653 | otherwise = ASSERT2(not(null unpointed)
654 , ptext SLIT("reOrderTerms") $$
655 (ppr pointed $$ ppr unpointed))
656 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
658 expandNewtypes t@Term{ ty=ty, subTerms=tt }
659 | Just (tc, args) <- splitNewTyConApp_maybe ty
661 , wrapped_type <- newTyConInstRhs tc args
662 , Just dc <- maybeTyConSingleCon tc
663 , t' <- expandNewtypes t{ ty = wrapped_type
664 , subTerms = map expandNewtypes tt }
665 = NewtypeWrap ty (Right dc) t'
667 | otherwise = t{ subTerms = map expandNewtypes tt }
672 -- Fast, breadth-first Type reconstruction
673 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
674 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
675 tv <- newVar argTypeKind
677 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
679 (Seq.singleton (tv, hval))
681 zonkTcType tv -- TODO untested!
682 Just ty | isMonomorphic ty -> return ty
684 (ty',rev_subst) <- instScheme (sigmaType ty)
686 search (isMonomorphic `fmap` zonkTcType tv)
688 (Seq.singleton (tv, hval))
690 substTy rev_subst `fmap` zonkTcType tv
692 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
693 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
694 int max_depth <> text " steps")
695 search stop expand l d =
698 x :< xx -> unlessM stop $ do
700 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
702 -- returns unification tasks,since we are going to want a breadth-first search
703 go :: Type -> HValue -> TR [(Type, HValue)]
705 clos <- trIO $ getClosureData a
707 Indirection _ -> go tv $! (ptrs clos ! 0)
709 Right dcname <- dataConInfoPtrToName (infoPtr clos)
710 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
713 -- TODO: Check this case
714 forM [0..length (elems $ ptrs clos)] $ \i -> do
715 tv <- newVar liftedTypeKind
716 return$ appArr (\e->(tv,e)) (ptrs clos) i
719 let extra_args = length(dataConRepArgTys dc) -
720 length(dataConOrigArgTys dc)
721 subTtypes <- mapMif (not . isMonomorphic)
722 (\t -> newVar (typeKind t))
723 (dataConRepArgTys dc)
725 -- It is vital for newtype reconstruction that the unification step
726 -- is done right here, _before_ the subterms are RTTI reconstructed
727 let myType = mkFunTys subTtypes tv
728 (signatureType,_) <- instScheme(dataConRepType dc)
729 addConstraint myType signatureType
730 return $ [ appArr (\e->(t,e)) (ptrs clos) i
731 | (i,t) <- drop extra_args $
732 zip [0..] (filter isPointed subTtypes)]
735 -- This helper computes the difference between a base type t and the
736 -- improved rtti_t computed by RTTI
737 -- The main difference between RTTI types and their normal counterparts
738 -- is that the former are _not_ polymorphic, thus polymorphism must
739 -- be stripped. Syntactically, forall's must be stripped.
740 -- We also remove predicates.
741 computeRTTIsubst :: Type -> Type -> TvSubst
742 computeRTTIsubst ty rtti_ty =
745 Nothing -> pprPanic "Failed to compute a RTTI substitution"
747 -- In addition, we strip newtypes too, since the reconstructed type might
748 -- not have recovered them all
749 -- TODO stripping newtypes shouldn't be necessary, test
750 where mb_subst = tcUnifyTys (const BindMe)
754 -- Dealing with newtypes
756 A parallel fold over two Type values,
757 compensating for missing newtypes on both sides.
758 This is necessary because newtypes are not present
759 in runtime, but since sometimes there is evidence
760 available we do our best to reconstruct them.
761 Evidence can come from DataCon signatures or
762 from compile-time type inference.
763 I am using the words congruence and rewriting
764 because what we are doing here is an approximation
765 of unification modulo a set of equations, which would
766 come from newtype definitions. These should be the
767 equality coercions seen in System Fc. Rewriting
768 is performed, taking those equations as rules,
769 before launching unification.
771 It doesn't make sense to rewrite everywhere,
772 or we would end up with all newtypes. So we rewrite
773 only in presence of evidence.
774 The lhs comes from the heap structure of ptrs,nptrs.
775 The rhs comes from a DataCon type signature.
776 Rewriting in the rhs is restricted to the result type.
778 Note that it is very tricky to make this 'rewriting'
779 work with the unification implemented by TcM, where
780 substitutions are 'inlined'. The order in which
781 constraints are unified is vital for this.
782 This is a simple form of residuation, the technique of
783 delaying unification steps until enough information
786 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
787 congruenceNewtypes lhs rhs
788 -- TyVar lhs inductive case
789 | Just tv <- getTyVar_maybe lhs
790 = recoverTc (return (lhs,rhs)) $ do
791 Indirect ty_v <- readMetaTyVar tv
792 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
794 -- FunTy inductive case
795 | Just (l1,l2) <- splitFunTy_maybe lhs
796 , Just (r1,r2) <- splitFunTy_maybe rhs
797 = do (l2',r2') <- congruenceNewtypes l2 r2
798 (l1',r1') <- congruenceNewtypes l1 r1
799 return (mkFunTy l1' l2', mkFunTy r1' r2')
800 -- TyconApp Inductive case; this is the interesting bit.
801 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
802 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
804 = do rhs' <- upgrade tycon_l rhs
807 | otherwise = return (lhs,rhs)
809 where upgrade :: TyCon -> Type -> TR Type
811 | not (isNewTyCon new_tycon) = return ty
813 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
814 let ty' = mkTyConApp new_tycon vars
815 liftTcM (unifyType ty (repType ty'))
816 -- assumes that reptype doesn't ^^^^ touch tyconApp args
820 --------------------------------------------------------------------------------
821 -- Semantically different to recoverM in TcRnMonad
822 -- recoverM retains the errors in the first action,
823 -- whereas recoverTc here does not
824 recoverTc :: TcM a -> TcM a -> TcM a
825 recoverTc recover thing = do
826 (_,mb_res) <- tryTcErrs thing
829 Just res -> return res
831 isMonomorphic :: Type -> Bool
832 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
833 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
835 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
836 mapMif pred f xx = sequence $ mapMif_ pred f xx
839 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
841 unlessM :: Monad m => m Bool -> m () -> m ()
842 unlessM condM acc = condM >>= \c -> unless c acc
844 -- Strict application of f at index i
845 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
846 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
847 = ASSERT (i < length(elems a))
848 case indexArray# ptrs# i# of
851 zonkTerm :: Term -> TcM Term
852 zonkTerm = foldTerm idTermFoldM {
853 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
854 zonkTcType ty >>= \ty' ->
855 return (Term ty' dc v tt)
856 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
857 return (Suspension ct ty v b)
858 ,fNewtypeWrap= \ty dc t ->
859 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
862 -- Is this defined elsewhere?
863 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
864 sigmaType :: Type -> Type
865 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty