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 )
53 import TcRnMonad ( TcM, initTc, ioToTcRn,
76 import GHC.Arr ( Array(..) )
82 import Data.Array.Base
84 import Data.List ( partition )
85 import qualified Data.Sequence as Seq
87 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
89 import System.IO.Unsafe
91 ---------------------------------------------
92 -- * A representation of semi evaluated Terms
93 ---------------------------------------------
95 A few examples in this representation:
97 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
99 > (('a',_,_),_,('b',_,_)) =
100 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
101 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
103 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
106 data Term = Term { ty :: Type
107 , dc :: Either String DataCon
108 -- Empty if the datacon aint exported by the .hi
109 -- (private constructors in -O0 libraries)
111 , subTerms :: [Term] }
116 | Suspension { ctype :: ClosureType
117 , mb_ty :: Maybe Type
119 , bound_to :: Maybe Name -- Useful for printing
121 | NewtypeWrap{ ty :: Type
122 , dc :: Either String DataCon
123 , wrapped_term :: Term }
124 | RefWrap { ty :: Type
125 , wrapped_term :: Term }
127 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
130 isSuspension Suspension{} = True
131 isSuspension _ = False
134 isNewtypeWrap NewtypeWrap{} = True
135 isNewtypeWrap _ = False
137 termType :: Term -> Maybe Type
138 termType t@(Suspension {}) = mb_ty t
139 termType t = Just$ ty t
141 isFullyEvaluatedTerm :: Term -> Bool
142 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
143 isFullyEvaluatedTerm Prim {} = True
144 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
145 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
146 isFullyEvaluatedTerm _ = False
148 instance Outputable (Term) where
149 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
150 | otherwise = panic "Outputable Term instance"
152 -------------------------------------------------------------------------
153 -- Runtime Closure Datatype and functions for retrieving closure related stuff
154 -------------------------------------------------------------------------
155 data ClosureType = Constr
167 data Closure = Closure { tipe :: ClosureType
169 , infoTable :: StgInfoTable
170 , ptrs :: Array Int HValue
174 instance Outputable ClosureType where
177 #include "../includes/ClosureTypes.h"
179 aP_CODE, pAP_CODE :: Int
185 getClosureData :: a -> IO Closure
187 case unpackClosure# a of
188 (# iptr, ptrs, nptrs #) -> do
189 #ifndef GHCI_TABLES_NEXT_TO_CODE
190 -- the info pointer we get back from unpackClosure# is to the
191 -- beginning of the standard info table, but the Storable instance
192 -- for info tables takes into account the extra entry pointer
193 -- when !tablesNextToCode, so we must adjust here:
194 itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
196 itbl <- peek (Ptr iptr)
198 let tipe = readCType (BCI.tipe itbl)
199 elems = fromIntegral (BCI.ptrs itbl)
200 ptrsList = Array 0 (elems - 1) elems ptrs
201 nptrs_data = [W# (indexWordArray# nptrs i)
202 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
203 ASSERT(elems >= 0) return ()
205 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
207 readCType :: Integral a => a -> ClosureType
209 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
210 | i >= FUN && i <= FUN_STATIC = Fun
211 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
212 | i == THUNK_SELECTOR = ThunkSelector
213 | i == BLACKHOLE = Blackhole
214 | i >= IND && i <= IND_STATIC = Indirection i'
217 | i' == pAP_CODE = PAP
218 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
219 | otherwise = Other i'
220 where i' = fromIntegral i
222 isConstr, isIndirection, isThunk :: ClosureType -> Bool
223 isConstr Constr = True
226 isIndirection (Indirection _) = True
227 --isIndirection ThunkSelector = True
228 isIndirection _ = False
230 isThunk (Thunk _) = True
231 isThunk ThunkSelector = True
235 isFullyEvaluated :: a -> IO Bool
236 isFullyEvaluated a = do
237 closure <- getClosureData a
239 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
240 return$ and are_subs_evaluated
242 where amapM f = sequence . amap' f
244 amap' :: (t -> b) -> Array Int t -> [b]
245 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
246 where g (I# i#) = case indexArray# arr# i# of
249 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
251 unsafeDeepSeq :: a -> b -> b
252 unsafeDeepSeq = unsafeDeepSeq1 2
253 where unsafeDeepSeq1 0 a b = seq a $! b
254 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
255 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
256 -- | unsafePerformIO (isFullyEvaluated a) = b
257 | otherwise = case unsafePerformIO (getClosureData a) of
258 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
259 where tipe = unsafePerformIO (getClosureType a)
261 isPointed :: Type -> Bool
262 isPointed t | Just (t, _) <- splitTyConApp_maybe t
263 = not$ isUnliftedTypeKind (tyConKind t)
266 extractUnboxed :: [Type] -> Closure -> [[Word]]
267 extractUnboxed tt clos = go tt (nonPtrs clos)
269 | Just (tycon,_) <- splitTyConApp_maybe t
270 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
271 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
274 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
277 sizeofTyCon :: TyCon -> Int
278 sizeofTyCon = sizeofPrimRep . tyConPrimRep
280 -----------------------------------
281 -- * Traversals for Terms
282 -----------------------------------
283 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
285 data TermFold a = TermFold { fTerm :: TermProcessor a a
286 , fPrim :: Type -> [Word] -> a
287 , fSuspension :: ClosureType -> Maybe Type -> HValue
289 , fNewtypeWrap :: Type -> Either String DataCon
291 , fRefWrap :: Type -> a -> a
294 foldTerm :: TermFold a -> Term -> a
295 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
296 foldTerm tf (Prim ty v ) = fPrim tf ty v
297 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
298 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
299 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
301 idTermFold :: TermFold Term
302 idTermFold = TermFold {
305 fSuspension = Suspension,
306 fNewtypeWrap = NewtypeWrap,
309 idTermFoldM :: Monad m => TermFold (m Term)
310 idTermFoldM = TermFold {
311 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
312 fPrim = (return.). Prim,
313 fSuspension = (((return.).).). Suspension,
314 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
315 fRefWrap = \ty t -> RefWrap ty `liftM` t
318 mapTermType :: (Type -> Type) -> Term -> Term
319 mapTermType f = foldTerm idTermFold {
320 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
321 fSuspension = \ct mb_ty hval n ->
322 Suspension ct (fmap f mb_ty) hval n,
323 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
324 fRefWrap = \ty t -> RefWrap (f ty) t}
326 termTyVars :: Term -> TyVarSet
327 termTyVars = foldTerm TermFold {
328 fTerm = \ty _ _ tt ->
329 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
330 fSuspension = \_ mb_ty _ _ ->
331 maybe emptyVarEnv tyVarsOfType mb_ty,
332 fPrim = \ _ _ -> emptyVarEnv,
333 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
334 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
335 where concatVarEnv = foldr plusVarEnv emptyVarEnv
337 ----------------------------------
338 -- Pretty printing of terms
339 ----------------------------------
341 type Precedence = Int
342 type TermPrinter = Precedence -> Term -> SDoc
343 type TermPrinterM m = Precedence -> Term -> m SDoc
345 app_prec,cons_prec, max_prec ::Int
348 cons_prec = 5 -- TODO Extract this info from GHC itself
350 pprTerm :: TermPrinter -> TermPrinter
351 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
352 pprTerm _ _ _ = panic "pprTerm"
354 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
355 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
357 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
358 tt_docs <- mapM (y app_prec) tt
359 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
361 ppr_termM y p Term{dc=Right dc, subTerms=tt}
362 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
363 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
364 <+> hsep (map (ppr_term1 True) tt)
365 -} -- TODO Printing infix constructors properly
366 | null tt = return$ ppr dc
368 tt_docs <- mapM (y app_prec) tt
369 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
371 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
372 ppr_termM y p RefWrap{wrapped_term=t} = braces `liftM` y p t
373 ppr_termM _ _ t = ppr_termM1 t
376 ppr_termM1 :: Monad m => Term -> m SDoc
377 ppr_termM1 Prim{value=words, ty=ty} =
378 return$ text$ repPrim (tyConAppTyCon ty) words
379 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
380 ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
381 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
382 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
383 ppr_termM1 Suspension{} = panic "ppr_termM1 - Suspension"
384 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
385 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
386 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
388 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
389 | Just (tc,_) <- splitNewTyConApp_maybe ty
390 , ASSERT(isNewTyCon tc) True
391 , Just new_dc <- maybeTyConSingleCon tc = do
392 real_term <- y max_prec t
393 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
394 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
396 -------------------------------------------------------
397 -- Custom Term Pretty Printers
398 -------------------------------------------------------
400 -- We can want to customize the representation of a
401 -- term depending on its type.
402 -- However, note that custom printers have to work with
403 -- type representations, instead of directly with types.
404 -- We cannot use type classes here, unless we employ some
405 -- typerep trickery (e.g. Weirich's RepLib tricks),
406 -- which I didn't. Therefore, this code replicates a lot
407 -- of what type classes provide for free.
409 type CustomTermPrinter m = TermPrinterM m
410 -> [Precedence -> Term -> (m (Maybe SDoc))]
412 -- | Takes a list of custom printers with a explicit recursion knot and a term,
413 -- and returns the output of the first succesful printer, or the default printer
414 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
415 cPprTerm printers_ = go 0 where
416 printers = printers_ go
418 let default_ = Just `liftM` pprTermM go prec t
419 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
420 Just doc <- firstJustM mb_customDocs
421 return$ cparen (prec>app_prec+1) doc
423 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
424 firstJustM [] = return Nothing
426 -- Default set of custom printers. Note that the recursion knot is explicit
427 cPprTermBase :: Monad m => CustomTermPrinter m
429 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
432 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
433 (\ p Term{subTerms=[h,t]} -> doList p h t)
434 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
435 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
436 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
437 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
438 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
440 where ifTerm pred f prec t@Term{}
441 | pred t = Just `liftM` f prec t
442 ifTerm _ _ _ _ = return Nothing
444 isIntegerTy ty = fromMaybe False $ do
445 (tc,_) <- splitTyConApp_maybe ty
446 return (tyConName tc == integerTyConName)
448 isTupleTy ty = fromMaybe False $ do
449 (tc,_) <- splitTyConApp_maybe ty
450 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
452 isTyCon a_tc ty = fromMaybe False $ do
453 (tc,_) <- splitTyConApp_maybe ty
456 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
458 --Note pprinting of list terms is not lazy
460 let elems = h : getListTerms t
461 isConsLast = termType(last elems) /= termType h
462 print_elems <- mapM (y cons_prec) elems
463 return$ if isConsLast
464 then cparen (p >= cons_prec)
466 . punctuate (space<>colon)
468 else brackets (pprDeeperList fcat$
469 punctuate comma print_elems)
471 where Just a /= Just b = not (a `coreEqType` b)
473 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
474 getListTerms Term{subTerms=[]} = []
475 getListTerms t@Suspension{} = [t]
476 getListTerms t = pprPanic "getListTerms" (ppr t)
479 repPrim :: TyCon -> [Word] -> String
480 repPrim t = rep where
482 | t == charPrimTyCon = show (build x :: Char)
483 | t == intPrimTyCon = show (build x :: Int)
484 | t == wordPrimTyCon = show (build x :: Word)
485 | t == floatPrimTyCon = show (build x :: Float)
486 | t == doublePrimTyCon = show (build x :: Double)
487 | t == int32PrimTyCon = show (build x :: Int32)
488 | t == word32PrimTyCon = show (build x :: Word32)
489 | t == int64PrimTyCon = show (build x :: Int64)
490 | t == word64PrimTyCon = show (build x :: Word64)
491 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
492 | t == stablePtrPrimTyCon = "<stablePtr>"
493 | t == stableNamePrimTyCon = "<stableName>"
494 | t == statePrimTyCon = "<statethread>"
495 | t == realWorldTyCon = "<realworld>"
496 | t == threadIdPrimTyCon = "<ThreadId>"
497 | t == weakPrimTyCon = "<Weak>"
498 | t == arrayPrimTyCon = "<array>"
499 | t == byteArrayPrimTyCon = "<bytearray>"
500 | t == mutableArrayPrimTyCon = "<mutableArray>"
501 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
502 | t == mutVarPrimTyCon= "<mutVar>"
503 | t == mVarPrimTyCon = "<mVar>"
504 | t == tVarPrimTyCon = "<tVar>"
505 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
506 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
507 -- This ^^^ relies on the representation of Haskell heap values being
508 -- the same as in a C array.
510 -----------------------------------
511 -- Type Reconstruction
512 -----------------------------------
514 Type Reconstruction is type inference done on heap closures.
515 The algorithm walks the heap generating a set of equations, which
516 are solved with syntactic unification.
517 A type reconstruction equation looks like:
519 <datacon reptype> = <actual heap contents>
521 The full equation set is generated by traversing all the subterms, starting
524 The only difficult part is that newtypes are only found in the lhs of equations.
525 Right hand sides are missing them. We can either (a) drop them from the lhs, or
526 (b) reconstruct them in the rhs when possible.
528 The function congruenceNewtypes takes a shot at (b)
531 -- The Type Reconstruction monad
534 runTR :: HscEnv -> TR a -> IO a
536 mb_term <- runTR_maybe hsc_env c
538 Nothing -> panic "Can't unify"
541 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
542 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
544 traceTR :: SDoc -> TR ()
545 traceTR = liftTcM . traceTc
548 trIO = liftTcM . ioToTcRn
550 liftTcM :: TcM a -> TR a
553 newVar :: Kind -> TR TcType
554 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
556 -- | Returns the instantiated type scheme ty', and the substitution sigma
557 -- such that sigma(ty') = ty
558 instScheme :: Type -> TR (TcType, TvSubst)
559 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
560 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
561 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
563 -- Adds a constraint of the form t1 == t2
564 -- t1 is expected to come from walking the heap
565 -- t2 is expected to come from a datacon signature
566 -- Before unification, congruenceNewtypes needs to
568 addConstraint :: TcType -> TcType -> TR ()
569 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
570 >> return () -- TOMDO: what about the coercion?
571 -- we should consider family instances
573 -- Type & Term reconstruction
574 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
575 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
576 tv <- newVar argTypeKind
578 Nothing -> go bound tv tv hval
580 >>= return . expandNewtypes
581 Just ty | isMonomorphic ty -> go bound ty ty hval
583 >>= return . expandNewtypes
585 (ty',rev_subst) <- instScheme (sigmaType ty)
587 term <- go bound tv tv hval >>= zonkTerm
588 --restore original Tyvars
589 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
591 go bound _ _ _ | seq bound False = undefined
593 clos <- trIO $ getClosureData a
594 return (Suspension (tipe clos) (Just tv) a Nothing)
595 go bound tv ty a = do
596 let monomorphic = not(isTyVarTy tv)
597 -- This ^^^ is a convention. The ancestor tests for
598 -- monomorphism and passes a type instead of a tv
599 clos <- trIO $ getClosureData a
601 -- Thunks we may want to force
602 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
603 -- force blackholes, because it would almost certainly result in deadlock,
604 -- and showing the '_' is more useful.
605 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
606 -- We always follow indirections
607 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
608 -- We also follow references
609 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
610 -- , tycon == mutVarPrimTyCon
612 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
613 tv' <- newVar liftedTypeKind
614 addConstraint tv (mkTyConApp tycon [world,tv'])
615 x <- go bound tv' ty_contents contents
616 return (RefWrap ty x)
618 -- The interesting case
620 Right dcname <- dataConInfoPtrToName (infoPtr clos)
621 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
623 Nothing -> do -- This can happen for private constructors compiled -O0
624 -- where the .hi descriptor does not export them
625 -- In such case, we return a best approximation:
626 -- ignore the unpointed args, and recover the pointeds
627 -- This preserves laziness, and should be safe.
628 let tag = showSDoc (ppr dcname)
629 vars <- replicateM (length$ elems$ ptrs clos)
630 (newVar (liftedTypeKind))
631 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
632 | (i, tv) <- zip [0..] vars]
633 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
635 let extra_args = length(dataConRepArgTys dc) -
636 length(dataConOrigArgTys dc)
637 subTtypes = matchSubTypes dc ty
638 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
639 subTermTvs <- sequence
640 [ if isMonomorphic t then return t
642 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
643 -- It is vital for newtype reconstruction that the unification step
644 -- is done right here, _before_ the subterms are RTTI reconstructed
645 when (not monomorphic) $ do
646 let myType = mkFunTys (reOrderTerms subTermTvs
650 (signatureType,_) <- instScheme(dataConRepType dc)
651 addConstraint myType signatureType
652 subTermsP <- sequence $ drop extra_args
653 -- ^^^ all extra arguments are pointed
654 [ appArr (go (pred bound) tv t) (ptrs clos) i
655 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
656 let unboxeds = extractUnboxed subTtypesNP clos
657 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
658 subTerms = reOrderTerms subTermsP subTermsNP
659 (drop extra_args subTtypes)
660 return (Term tv (Right dc) a subTerms)
661 -- The otherwise case: can be a Thunk,AP,PAP,etc.
663 return (Suspension tipe_clos (Just tv) a Nothing)
666 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
667 -- assumption: ^^^ looks through newtypes
668 , isVanillaDataCon dc --TODO non-vanilla case
669 = dataConInstArgTys dc ty_args
670 | otherwise = dataConRepArgTys dc
672 -- This is used to put together pointed and nonpointed subterms in the
674 reOrderTerms _ _ [] = []
675 reOrderTerms pointed unpointed (ty:tys)
676 | isPointed ty = ASSERT2(not(null pointed)
677 , ptext SLIT("reOrderTerms") $$
678 (ppr pointed $$ ppr unpointed))
679 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
680 | otherwise = ASSERT2(not(null unpointed)
681 , ptext SLIT("reOrderTerms") $$
682 (ppr pointed $$ ppr unpointed))
683 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
685 expandNewtypes t@Term{ ty=ty, subTerms=tt }
686 | Just (tc, args) <- splitNewTyConApp_maybe ty
688 , wrapped_type <- newTyConInstRhs tc args
689 , Just dc <- maybeTyConSingleCon tc
690 , t' <- expandNewtypes t{ ty = wrapped_type
691 , subTerms = map expandNewtypes tt }
692 = NewtypeWrap ty (Right dc) t'
694 | otherwise = t{ subTerms = map expandNewtypes tt }
699 -- Fast, breadth-first Type reconstruction
700 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
701 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
702 tv <- newVar argTypeKind
704 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
706 (Seq.singleton (tv, hval))
708 zonkTcType tv -- TODO untested!
709 Just ty | isMonomorphic ty -> return ty
711 (ty',rev_subst) <- instScheme (sigmaType ty)
713 search (isMonomorphic `fmap` zonkTcType tv)
715 (Seq.singleton (tv, hval))
717 substTy rev_subst `fmap` zonkTcType tv
719 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
720 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
721 int max_depth <> text " steps")
722 search stop expand l d =
725 x :< xx -> unlessM stop $ do
727 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
729 -- returns unification tasks,since we are going to want a breadth-first search
730 go :: Type -> HValue -> TR [(Type, HValue)]
732 clos <- trIO $ getClosureData a
734 Indirection _ -> go tv $! (ptrs clos ! 0)
736 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
737 tv' <- newVar liftedTypeKind
738 world <- newVar liftedTypeKind
739 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
740 -- x <- go tv' ty_contents contents
741 return [(tv', contents)]
743 Right dcname <- dataConInfoPtrToName (infoPtr clos)
744 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
747 -- TODO: Check this case
748 forM [0..length (elems $ ptrs clos)] $ \i -> do
749 tv <- newVar liftedTypeKind
750 return$ appArr (\e->(tv,e)) (ptrs clos) i
753 let extra_args = length(dataConRepArgTys dc) -
754 length(dataConOrigArgTys dc)
755 subTtypes <- mapMif (not . isMonomorphic)
756 (\t -> newVar (typeKind t))
757 (dataConRepArgTys dc)
759 -- It is vital for newtype reconstruction that the unification step
760 -- is done right here, _before_ the subterms are RTTI reconstructed
761 let myType = mkFunTys subTtypes tv
762 (signatureType,_) <- instScheme(dataConRepType dc)
763 addConstraint myType signatureType
764 return $ [ appArr (\e->(t,e)) (ptrs clos) i
765 | (i,t) <- drop extra_args $
766 zip [0..] (filter isPointed subTtypes)]
769 -- This helper computes the difference between a base type t and the
770 -- improved rtti_t computed by RTTI
771 -- The main difference between RTTI types and their normal counterparts
772 -- is that the former are _not_ polymorphic, thus polymorphism must
773 -- be stripped. Syntactically, forall's must be stripped.
774 -- We also remove predicates.
775 unifyRTTI :: Type -> Type -> TvSubst
776 unifyRTTI ty rtti_ty =
779 Nothing -> pprPanic "Failed to compute a RTTI substitution"
781 -- In addition, we strip newtypes too, since the reconstructed type might
782 -- not have recovered them all
783 -- TODO stripping newtypes shouldn't be necessary, test
784 where mb_subst = tcUnifyTys (const BindMe)
788 -- Dealing with newtypes
790 A parallel fold over two Type values,
791 compensating for missing newtypes on both sides.
792 This is necessary because newtypes are not present
793 in runtime, but since sometimes there is evidence
794 available we do our best to reconstruct them.
795 Evidence can come from DataCon signatures or
796 from compile-time type inference.
797 I am using the words congruence and rewriting
798 because what we are doing here is an approximation
799 of unification modulo a set of equations, which would
800 come from newtype definitions. These should be the
801 equality coercions seen in System Fc. Rewriting
802 is performed, taking those equations as rules,
803 before launching unification.
805 It doesn't make sense to rewrite everywhere,
806 or we would end up with all newtypes. So we rewrite
807 only in presence of evidence.
808 The lhs comes from the heap structure of ptrs,nptrs.
809 The rhs comes from a DataCon type signature.
810 Rewriting in the rhs is restricted to the result type.
812 Note that it is very tricky to make this 'rewriting'
813 work with the unification implemented by TcM, where
814 substitutions are 'inlined'. The order in which
815 constraints are unified is vital for this.
816 This is a simple form of residuation, the technique of
817 delaying unification steps until enough information
820 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
821 congruenceNewtypes lhs rhs
822 -- TyVar lhs inductive case
823 | Just tv <- getTyVar_maybe lhs
824 = recoverTc (return (lhs,rhs)) $ do
825 Indirect ty_v <- readMetaTyVar tv
826 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
828 -- FunTy inductive case
829 | Just (l1,l2) <- splitFunTy_maybe lhs
830 , Just (r1,r2) <- splitFunTy_maybe rhs
831 = do (l2',r2') <- congruenceNewtypes l2 r2
832 (l1',r1') <- congruenceNewtypes l1 r1
833 return (mkFunTy l1' l2', mkFunTy r1' r2')
834 -- TyconApp Inductive case; this is the interesting bit.
835 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
836 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
838 = do rhs' <- upgrade tycon_l rhs
841 | otherwise = return (lhs,rhs)
843 where upgrade :: TyCon -> Type -> TR Type
845 | not (isNewTyCon new_tycon) = return ty
847 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
848 let ty' = mkTyConApp new_tycon vars
849 liftTcM (unifyType ty (repType ty'))
850 -- assumes that reptype doesn't ^^^^ touch tyconApp args
854 --------------------------------------------------------------------------------
855 -- Semantically different to recoverM in TcRnMonad
856 -- recoverM retains the errors in the first action,
857 -- whereas recoverTc here does not
858 recoverTc :: TcM a -> TcM a -> TcM a
859 recoverTc recover thing = do
860 (_,mb_res) <- tryTcErrs thing
863 Just res -> return res
865 isMonomorphic :: Type -> Bool
866 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
867 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
869 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
870 mapMif pred f xx = sequence $ mapMif_ pred f xx
873 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
875 unlessM :: Monad m => m Bool -> m () -> m ()
876 unlessM condM acc = condM >>= \c -> unless c acc
878 -- Strict application of f at index i
879 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
880 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
881 = ASSERT (i < length(elems a))
882 case indexArray# ptrs# i# of
885 zonkTerm :: Term -> TcM Term
886 zonkTerm = foldTerm idTermFoldM {
887 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
888 zonkTcType ty >>= \ty' ->
889 return (Term ty' dc v tt)
890 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
891 return (Suspension ct ty v b)
892 ,fNewtypeWrap= \ty dc t ->
893 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
896 -- Is this defined elsewhere?
897 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
898 sigmaType :: Type -> Type
899 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty