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 GHC.Arr ( Array(..) )
75 import GHC.IOBase ( IO(IO) )
79 import Data.Array.Base
81 import Data.List ( partition )
82 import qualified Data.Sequence as Seq
84 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
86 import System.IO.Unsafe
88 ---------------------------------------------
89 -- * A representation of semi evaluated Terms
90 ---------------------------------------------
95 data Term = Term { ty :: Type
96 , dc :: Either String DataCon
97 -- Carries a text representation if the datacon is
98 -- not exported by the .hi file, which is the case
99 -- for private constructors in -O0 compiled libraries
101 , subTerms :: [Term] }
106 | Suspension { ctype :: ClosureType
109 , bound_to :: Maybe Name -- Useful for printing
111 | NewtypeWrap{ ty :: Type
112 , dc :: Either String DataCon
113 , wrapped_term :: Term }
114 | RefWrap { ty :: Type
115 , wrapped_term :: Term }
117 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
120 isSuspension Suspension{} = True
121 isSuspension _ = False
124 isNewtypeWrap NewtypeWrap{} = True
125 isNewtypeWrap _ = False
127 termType :: Term -> Type
130 isFullyEvaluatedTerm :: Term -> Bool
131 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
132 isFullyEvaluatedTerm Prim {} = True
133 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
134 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
135 isFullyEvaluatedTerm _ = False
137 instance Outputable (Term) where
138 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
139 | otherwise = panic "Outputable Term instance"
141 -------------------------------------------------------------------------
142 -- Runtime Closure Datatype and functions for retrieving closure related stuff
143 -------------------------------------------------------------------------
144 data ClosureType = Constr
156 data Closure = Closure { tipe :: ClosureType
158 , infoTable :: StgInfoTable
159 , ptrs :: Array Int HValue
163 instance Outputable ClosureType where
166 #include "../includes/ClosureTypes.h"
168 aP_CODE, pAP_CODE :: Int
174 getClosureData :: a -> IO Closure
176 case unpackClosure# a of
177 (# iptr, ptrs, nptrs #) -> do
178 #ifndef GHCI_TABLES_NEXT_TO_CODE
179 -- the info pointer we get back from unpackClosure# is to the
180 -- beginning of the standard info table, but the Storable instance
181 -- for info tables takes into account the extra entry pointer
182 -- when !tablesNextToCode, so we must adjust here:
183 itbl <- peek (Ptr iptr `plusPtr` negate wORD_SIZE)
185 itbl <- peek (Ptr iptr)
187 let tipe = readCType (BCI.tipe itbl)
188 elems = fromIntegral (BCI.ptrs itbl)
189 ptrsList = Array 0 (elems - 1) elems ptrs
190 nptrs_data = [W# (indexWordArray# nptrs i)
191 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
192 ASSERT(elems >= 0) return ()
194 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
196 readCType :: Integral a => a -> ClosureType
198 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
199 | i >= FUN && i <= FUN_STATIC = Fun
200 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
201 | i == THUNK_SELECTOR = ThunkSelector
202 | i == BLACKHOLE = Blackhole
203 | i >= IND && i <= IND_STATIC = Indirection i'
206 | i' == pAP_CODE = PAP
207 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
208 | otherwise = Other i'
209 where i' = fromIntegral i
211 isConstr, isIndirection, isThunk :: ClosureType -> Bool
212 isConstr Constr = True
215 isIndirection (Indirection _) = True
216 isIndirection _ = False
218 isThunk (Thunk _) = True
219 isThunk ThunkSelector = True
223 isFullyEvaluated :: a -> IO Bool
224 isFullyEvaluated a = do
225 closure <- getClosureData a
227 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
228 return$ and are_subs_evaluated
230 where amapM f = sequence . amap' f
232 amap' :: (t -> b) -> Array Int t -> [b]
233 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
234 where g (I# i#) = case indexArray# arr# i# of
237 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
239 unsafeDeepSeq :: a -> b -> b
240 unsafeDeepSeq = unsafeDeepSeq1 2
241 where unsafeDeepSeq1 0 a b = seq a $! b
242 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
243 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
244 -- | unsafePerformIO (isFullyEvaluated a) = b
245 | otherwise = case unsafePerformIO (getClosureData a) of
246 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
247 where tipe = unsafePerformIO (getClosureType a)
249 isPointed :: Type -> Bool
250 isPointed t | Just (t, _) <- splitTyConApp_maybe t
251 = not$ isUnliftedTypeKind (tyConKind t)
254 extractUnboxed :: [Type] -> Closure -> [[Word]]
255 extractUnboxed tt clos = go tt (nonPtrs clos)
257 | Just (tycon,_) <- splitTyConApp_maybe t
258 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
259 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
262 | (x, rest) <- splitAt (sizeofType t) xx
265 sizeofTyCon :: TyCon -> Int -- in *words*
266 sizeofTyCon = primRepSizeW . tyConPrimRep
268 -----------------------------------
269 -- * Traversals for Terms
270 -----------------------------------
271 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
273 data TermFold a = TermFold { fTerm :: TermProcessor a a
274 , fPrim :: Type -> [Word] -> a
275 , fSuspension :: ClosureType -> Type -> HValue
277 , fNewtypeWrap :: Type -> Either String DataCon
279 , fRefWrap :: Type -> a -> a
282 foldTerm :: TermFold a -> Term -> a
283 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
284 foldTerm tf (Prim ty v ) = fPrim tf ty v
285 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
286 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
287 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
289 idTermFold :: TermFold Term
290 idTermFold = TermFold {
293 fSuspension = Suspension,
294 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,
303 fRefWrap = \ty t -> RefWrap ty `liftM` t
306 mapTermType :: (Type -> Type) -> Term -> Term
307 mapTermType f = foldTerm idTermFold {
308 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
309 fSuspension = \ct ty hval n ->
310 Suspension ct (f ty) hval n,
311 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
312 fRefWrap = \ty t -> RefWrap (f ty) t}
314 termTyVars :: Term -> TyVarSet
315 termTyVars = foldTerm TermFold {
316 fTerm = \ty _ _ tt ->
317 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
318 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
319 fPrim = \ _ _ -> emptyVarEnv,
320 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
321 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
322 where concatVarEnv = foldr plusVarEnv emptyVarEnv
324 ----------------------------------
325 -- Pretty printing of terms
326 ----------------------------------
328 type Precedence = Int
329 type TermPrinter = Precedence -> Term -> SDoc
330 type TermPrinterM m = Precedence -> Term -> m SDoc
332 app_prec,cons_prec, max_prec ::Int
335 cons_prec = 5 -- TODO Extract this info from GHC itself
337 pprTerm :: TermPrinter -> TermPrinter
338 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
339 pprTerm _ _ _ = panic "pprTerm"
341 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
342 pprTermM y p t = pprDeeper `liftM` ppr_termM y p 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
359 ppr_termM y p RefWrap{wrapped_term=t} = do
360 contents <- y app_prec t
361 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
362 -- The constructor name is wired in here ^^^ for the sake of simplicity.
363 -- I don't think mutvars are going to change in a near future.
364 -- In any case this is solely a presentation matter: MutVar# is
365 -- a datatype with no constructors, implemented by the RTS
366 -- (hence there is no way to obtain a datacon and print it).
367 ppr_termM _ _ t = ppr_termM1 t
370 ppr_termM1 :: Monad m => Term -> m SDoc
371 ppr_termM1 Prim{value=words, ty=ty} =
372 return$ text$ repPrim (tyConAppTyCon ty) words
373 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
374 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
375 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
376 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
377 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
378 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
379 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
381 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
382 | Just (tc,_) <- splitNewTyConApp_maybe ty
383 , ASSERT(isNewTyCon tc) True
384 , Just new_dc <- maybeTyConSingleCon tc = do
385 real_term <- y max_prec t
386 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
387 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
389 -------------------------------------------------------
390 -- Custom Term Pretty Printers
391 -------------------------------------------------------
393 -- We can want to customize the representation of a
394 -- term depending on its type.
395 -- However, note that custom printers have to work with
396 -- type representations, instead of directly with types.
397 -- We cannot use type classes here, unless we employ some
398 -- typerep trickery (e.g. Weirich's RepLib tricks),
399 -- which I didn't. Therefore, this code replicates a lot
400 -- of what type classes provide for free.
402 type CustomTermPrinter m = TermPrinterM m
403 -> [Precedence -> Term -> (m (Maybe SDoc))]
405 -- | Takes a list of custom printers with a explicit recursion knot and a term,
406 -- and returns the output of the first succesful printer, or the default printer
407 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
408 cPprTerm printers_ = go 0 where
409 printers = printers_ go
411 let default_ = Just `liftM` pprTermM go prec t
412 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
413 Just doc <- firstJustM mb_customDocs
414 return$ cparen (prec>app_prec+1) doc
416 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
417 firstJustM [] = return Nothing
419 -- Default set of custom printers. Note that the recursion knot is explicit
420 cPprTermBase :: Monad m => CustomTermPrinter m
422 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
425 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
426 (\ p Term{subTerms=[h,t]} -> doList p h t)
427 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
428 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
429 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
430 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
431 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
433 where ifTerm pred f prec t@Term{}
434 | pred t = Just `liftM` f prec t
435 ifTerm _ _ _ _ = return Nothing
437 isIntegerTy ty = fromMaybe False $ do
438 (tc,_) <- splitTyConApp_maybe ty
439 return (tyConName tc == integerTyConName)
441 isTupleTy ty = fromMaybe False $ do
442 (tc,_) <- splitTyConApp_maybe ty
443 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
445 isTyCon a_tc ty = fromMaybe False $ do
446 (tc,_) <- splitTyConApp_maybe ty
449 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
451 --Note pprinting of list terms is not lazy
453 let elems = h : getListTerms t
454 isConsLast = not(termType(last elems) `coreEqType` termType h)
455 print_elems <- mapM (y cons_prec) elems
456 return$ if isConsLast
457 then cparen (p >= cons_prec)
459 . punctuate (space<>colon)
461 else brackets (pprDeeperList fcat$
462 punctuate comma print_elems)
464 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
465 getListTerms Term{subTerms=[]} = []
466 getListTerms t@Suspension{} = [t]
467 getListTerms t = pprPanic "getListTerms" (ppr t)
470 repPrim :: TyCon -> [Word] -> String
471 repPrim t = rep where
473 | t == charPrimTyCon = show (build x :: Char)
474 | t == intPrimTyCon = show (build x :: Int)
475 | t == wordPrimTyCon = show (build x :: Word)
476 | t == floatPrimTyCon = show (build x :: Float)
477 | t == doublePrimTyCon = show (build x :: Double)
478 | t == int32PrimTyCon = show (build x :: Int32)
479 | t == word32PrimTyCon = show (build x :: Word32)
480 | t == int64PrimTyCon = show (build x :: Int64)
481 | t == word64PrimTyCon = show (build x :: Word64)
482 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
483 | t == stablePtrPrimTyCon = "<stablePtr>"
484 | t == stableNamePrimTyCon = "<stableName>"
485 | t == statePrimTyCon = "<statethread>"
486 | t == realWorldTyCon = "<realworld>"
487 | t == threadIdPrimTyCon = "<ThreadId>"
488 | t == weakPrimTyCon = "<Weak>"
489 | t == arrayPrimTyCon = "<array>"
490 | t == byteArrayPrimTyCon = "<bytearray>"
491 | t == mutableArrayPrimTyCon = "<mutableArray>"
492 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
493 | t == mutVarPrimTyCon= "<mutVar>"
494 | t == mVarPrimTyCon = "<mVar>"
495 | t == tVarPrimTyCon = "<tVar>"
496 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
497 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
498 -- This ^^^ relies on the representation of Haskell heap values being
499 -- the same as in a C array.
501 -----------------------------------
502 -- Type Reconstruction
503 -----------------------------------
505 Type Reconstruction is type inference done on heap closures.
506 The algorithm walks the heap generating a set of equations, which
507 are solved with syntactic unification.
508 A type reconstruction equation looks like:
510 <datacon reptype> = <actual heap contents>
512 The full equation set is generated by traversing all the subterms, starting
515 The only difficult part is that newtypes are only found in the lhs of equations.
516 Right hand sides are missing them. We can either (a) drop them from the lhs, or
517 (b) reconstruct them in the rhs when possible.
519 The function congruenceNewtypes takes a shot at (b)
522 -- The Type Reconstruction monad
525 runTR :: HscEnv -> TR a -> IO a
527 mb_term <- runTR_maybe hsc_env c
529 Nothing -> panic "Can't unify"
532 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
533 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
535 traceTR :: SDoc -> TR ()
536 traceTR = liftTcM . traceTc
539 trIO = liftTcM . liftIO
541 liftTcM :: TcM a -> TR a
544 newVar :: Kind -> TR TcType
545 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
547 -- | Returns the instantiated type scheme ty', and the substitution sigma
548 -- such that sigma(ty') = ty
549 instScheme :: Type -> TR (TcType, TvSubst)
550 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
551 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
552 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
554 -- Adds a constraint of the form t1 == t2
555 -- t1 is expected to come from walking the heap
556 -- t2 is expected to come from a datacon signature
557 -- Before unification, congruenceNewtypes needs to
559 addConstraint :: TcType -> TcType -> TR ()
560 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
561 >> return () -- TOMDO: what about the coercion?
562 -- we should consider family instances
564 -- Type & Term reconstruction
565 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
566 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
567 tv <- newVar argTypeKind
569 Nothing -> go bound tv tv hval
571 >>= return . expandNewtypes
572 Just ty | isMonomorphic ty -> go bound ty ty hval
574 >>= return . expandNewtypes
576 (ty',rev_subst) <- instScheme (sigmaType ty)
578 term <- go bound tv tv hval >>= zonkTerm
579 --restore original Tyvars
580 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
582 go bound _ _ _ | seq bound False = undefined
584 clos <- trIO $ getClosureData a
585 return (Suspension (tipe clos) tv a Nothing)
586 go bound tv ty a = do
587 let monomorphic = not(isTyVarTy tv)
588 -- This ^^^ is a convention. The ancestor tests for
589 -- monomorphism and passes a type instead of a tv
590 clos <- trIO $ getClosureData a
592 -- Thunks we may want to force
593 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
594 -- force blackholes, because it would almost certainly result in deadlock,
595 -- and showing the '_' is more useful.
596 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
597 -- We always follow indirections
598 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
599 -- We also follow references
600 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
601 -- , tycon == mutVarPrimTyCon
603 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
604 tv' <- newVar liftedTypeKind
605 addConstraint tv (mkTyConApp tycon [world,tv'])
606 x <- go bound tv' ty_contents contents
607 return (RefWrap ty x)
609 -- The interesting case
611 Right dcname <- dataConInfoPtrToName (infoPtr clos)
612 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
614 Nothing -> do -- This can happen for private constructors compiled -O0
615 -- where the .hi descriptor does not export them
616 -- In such case, we return a best approximation:
617 -- ignore the unpointed args, and recover the pointeds
618 -- This preserves laziness, and should be safe.
619 let tag = showSDoc (ppr dcname)
620 vars <- replicateM (length$ elems$ ptrs clos)
621 (newVar (liftedTypeKind))
622 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
623 | (i, tv) <- zip [0..] vars]
624 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
626 let extra_args = length(dataConRepArgTys dc) -
627 length(dataConOrigArgTys dc)
628 subTtypes = matchSubTypes dc ty
629 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
630 subTermTvs <- sequence
631 [ if isMonomorphic t then return t
633 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
634 -- It is vital for newtype reconstruction that the unification step
635 -- is done right here, _before_ the subterms are RTTI reconstructed
636 when (not monomorphic) $ do
637 let myType = mkFunTys (reOrderTerms subTermTvs
641 (signatureType,_) <- instScheme(dataConRepType dc)
642 addConstraint myType signatureType
643 subTermsP <- sequence $ drop extra_args
644 -- ^^^ all extra arguments are pointed
645 [ appArr (go (pred bound) tv t) (ptrs clos) i
646 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
647 let unboxeds = extractUnboxed subTtypesNP clos
648 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
649 subTerms = reOrderTerms subTermsP subTermsNP
650 (drop extra_args subTtypes)
651 return (Term tv (Right dc) a subTerms)
652 -- The otherwise case: can be a Thunk,AP,PAP,etc.
654 return (Suspension tipe_clos tv a Nothing)
657 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
658 -- assumption: ^^^ looks through newtypes
659 , isVanillaDataCon dc --TODO non-vanilla case
660 = dataConInstArgTys dc ty_args
661 | otherwise = dataConRepArgTys dc
663 -- This is used to put together pointed and nonpointed subterms in the
665 reOrderTerms _ _ [] = []
666 reOrderTerms pointed unpointed (ty:tys)
667 | isPointed ty = ASSERT2(not(null pointed)
668 , ptext SLIT("reOrderTerms") $$
669 (ppr pointed $$ ppr unpointed))
670 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
671 | otherwise = ASSERT2(not(null unpointed)
672 , ptext SLIT("reOrderTerms") $$
673 (ppr pointed $$ ppr unpointed))
674 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
676 expandNewtypes t@Term{ ty=ty, subTerms=tt }
677 | Just (tc, args) <- splitNewTyConApp_maybe ty
679 , wrapped_type <- newTyConInstRhs tc args
680 , Just dc <- maybeTyConSingleCon tc
681 , t' <- expandNewtypes t{ ty = wrapped_type
682 , subTerms = map expandNewtypes tt }
683 = NewtypeWrap ty (Right dc) t'
685 | otherwise = t{ subTerms = map expandNewtypes tt }
690 -- Fast, breadth-first Type reconstruction
691 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
692 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
693 tv <- newVar argTypeKind
695 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
697 (Seq.singleton (tv, hval))
699 zonkTcType tv -- TODO untested!
700 Just ty | isMonomorphic ty -> return ty
702 (ty',rev_subst) <- instScheme (sigmaType ty)
704 search (isMonomorphic `fmap` zonkTcType tv)
706 (Seq.singleton (tv, hval))
708 substTy rev_subst `fmap` zonkTcType tv
710 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
711 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
712 int max_depth <> text " steps")
713 search stop expand l d =
716 x :< xx -> unlessM stop $ do
718 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
720 -- returns unification tasks,since we are going to want a breadth-first search
721 go :: Type -> HValue -> TR [(Type, HValue)]
723 clos <- trIO $ getClosureData a
725 Indirection _ -> go tv $! (ptrs clos ! 0)
727 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
728 tv' <- newVar liftedTypeKind
729 world <- newVar liftedTypeKind
730 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
731 -- x <- go tv' ty_contents contents
732 return [(tv', contents)]
734 Right dcname <- dataConInfoPtrToName (infoPtr clos)
735 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
738 -- TODO: Check this case
739 forM [0..length (elems $ ptrs clos)] $ \i -> do
740 tv <- newVar liftedTypeKind
741 return$ appArr (\e->(tv,e)) (ptrs clos) i
744 let extra_args = length(dataConRepArgTys dc) -
745 length(dataConOrigArgTys dc)
746 subTtypes <- mapMif (not . isMonomorphic)
747 (\t -> newVar (typeKind t))
748 (dataConRepArgTys dc)
750 -- It is vital for newtype reconstruction that the unification step
751 -- is done right here, _before_ the subterms are RTTI reconstructed
752 let myType = mkFunTys subTtypes tv
753 (signatureType,_) <- instScheme(dataConRepType dc)
754 addConstraint myType signatureType
755 return $ [ appArr (\e->(t,e)) (ptrs clos) i
756 | (i,t) <- drop extra_args $
757 zip [0..] (filter isPointed subTtypes)]
761 This helper computes the difference between a base type t and the
762 improved rtti_t computed by RTTI
763 The main difference between RTTI types and their normal counterparts
764 is that the former are _not_ polymorphic, thus polymorphism must
765 be stripped. Syntactically, forall's must be stripped.
766 We also remove predicates.
768 unifyRTTI :: Type -> Type -> TvSubst
769 unifyRTTI ty rtti_ty =
772 Nothing -> pprPanic "Failed to compute a RTTI substitution"
774 -- In addition, we strip newtypes too, since the reconstructed type might
775 -- not have recovered them all
776 -- TODO stripping newtypes shouldn't be necessary, test
777 where mb_subst = tcUnifyTys (const BindMe)
781 -- Dealing with newtypes
783 congruenceNewtypes does a parallel fold over two Type values,
784 compensating for missing newtypes on both sides.
785 This is necessary because newtypes are not present
786 in runtime, but sometimes there is evidence available.
787 Evidence can come from DataCon signatures or
788 from compile-time type inference.
789 What we are doing here is an approximation
790 of unification modulo a set of equations derived
791 from newtype definitions. These equations should be the
792 same as the equality coercions generated for newtypes
793 in System Fc. The idea is to perform a sort of rewriting,
794 taking those equations as rules, before launching unification.
796 The caller must ensure the following.
797 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
798 The 2nd type (rhs) comes from a DataCon type signature.
799 Rewriting (i.e. adding/removing a newtype wrapper) can happen
800 in both types, but in the rhs it is restricted to the result type.
802 Note that it is very tricky to make this 'rewriting'
803 work with the unification implemented by TcM, where
804 substitutions are operationally inlined. The order in which
805 constraints are unified is vital as we cannot modify
806 anything that has been touched by a previous unification step.
807 Therefore, congruenceNewtypes is sound only if the types
808 recovered by the RTTI mechanism are unified Top-Down.
810 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
811 congruenceNewtypes lhs rhs
812 -- TyVar lhs inductive case
813 | Just tv <- getTyVar_maybe lhs
814 = recoverTc (return (lhs,rhs)) $ do
815 Indirect ty_v <- readMetaTyVar tv
816 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
818 -- FunTy inductive case
819 | Just (l1,l2) <- splitFunTy_maybe lhs
820 , Just (r1,r2) <- splitFunTy_maybe rhs
821 = do (l2',r2') <- congruenceNewtypes l2 r2
822 (l1',r1') <- congruenceNewtypes l1 r1
823 return (mkFunTy l1' l2', mkFunTy r1' r2')
824 -- TyconApp Inductive case; this is the interesting bit.
825 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
826 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
828 = do rhs' <- upgrade tycon_l rhs
831 | otherwise = return (lhs,rhs)
833 where upgrade :: TyCon -> Type -> TR Type
835 | not (isNewTyCon new_tycon) = return ty
837 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
838 let ty' = mkTyConApp new_tycon vars
839 liftTcM (unifyType ty (repType ty'))
840 -- assumes that reptype doesn't ^^^^ touch tyconApp args
844 --------------------------------------------------------------------------------
845 -- Semantically different to recoverM in TcRnMonad
846 -- recoverM retains the errors in the first action,
847 -- whereas recoverTc here does not
848 recoverTc :: TcM a -> TcM a -> TcM a
849 recoverTc recover thing = do
850 (_,mb_res) <- tryTcErrs thing
853 Just res -> return res
855 isMonomorphic :: Type -> Bool
856 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
857 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
859 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
860 mapMif pred f xx = sequence $ mapMif_ pred f xx
863 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
865 unlessM :: Monad m => m Bool -> m () -> m ()
866 unlessM condM acc = condM >>= \c -> unless c acc
868 -- Strict application of f at index i
869 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
870 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
871 = ASSERT (i < length(elems a))
872 case indexArray# ptrs# i# of
875 zonkTerm :: Term -> TcM Term
876 zonkTerm = foldTerm idTermFoldM {
877 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
878 zonkTcType ty >>= \ty' ->
879 return (Term ty' dc v tt)
880 ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
881 return (Suspension ct ty v b)
882 ,fNewtypeWrap= \ty dc t ->
883 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
886 -- Is this defined elsewhere?
887 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
888 sigmaType :: Type -> Type
889 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty