1 -----------------------------------------------------------------------------
3 -- GHC Interactive support for inspecting arbitrary closures at runtime
5 -- Pepe Iborra (supported by Google SoC) 2006
7 -----------------------------------------------------------------------------
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
16 module RtClosureInspect(
18 cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
48 #include "HsVersions.h"
50 import ByteCodeItbls ( StgInfoTable )
51 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
52 import HscTypes ( HscEnv )
57 import TcRnMonad ( TcM, initTc, ioToTcRn,
80 import GHC.Arr ( Array(..) )
85 import Data.Array.Base
86 import Data.List ( partition )
87 import qualified Data.Sequence as Seq
89 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
91 import System.IO.Unsafe
93 ---------------------------------------------
94 -- * A representation of semi evaluated Terms
95 ---------------------------------------------
97 A few examples in this representation:
99 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
101 > (('a',_,_),_,('b',_,_)) =
102 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
103 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
105 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
108 data Term = Term { ty :: Type
109 , dc :: Either String DataCon
110 -- The heap datacon. If ty is a newtype,
111 -- this is NOT the newtype datacon.
112 -- Empty if the datacon aint exported by the .hi
113 -- (private constructors in -O0 libraries)
115 , subTerms :: [Term] }
120 | Suspension { ctype :: ClosureType
121 , mb_ty :: Maybe Type
123 , bound_to :: Maybe Name -- Useful for printing
126 isTerm, isSuspension, isPrim :: Term -> Bool
129 isSuspension Suspension{} = True
130 isSuspension _ = False
134 termType :: Term -> Maybe Type
135 termType t@(Suspension {}) = mb_ty t
136 termType t = Just$ ty t
138 isFullyEvaluatedTerm :: Term -> Bool
139 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
140 isFullyEvaluatedTerm Suspension {} = False
141 isFullyEvaluatedTerm Prim {} = True
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"
177 getClosureData :: a -> IO Closure
179 case unpackClosure# a of
180 (# iptr, ptrs, nptrs #) -> do
181 itbl <- peek (Ptr iptr)
182 let tipe = readCType (BCI.tipe itbl)
183 elems = fromIntegral (BCI.ptrs itbl)
184 ptrsList = Array 0 (elems - 1) elems ptrs
185 nptrs_data = [W# (indexWordArray# nptrs i)
186 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
187 ASSERT(fromIntegral elems >= 0) return ()
189 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
191 readCType :: Integral a => a -> ClosureType
193 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
194 | i >= FUN && i <= FUN_STATIC = Fun
195 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
196 | i == THUNK_SELECTOR = ThunkSelector
197 | i == BLACKHOLE = Blackhole
198 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
199 | fromIntegral i == aP_CODE = AP
201 | fromIntegral i == pAP_CODE = PAP
202 | otherwise = Other (fromIntegral i)
204 isConstr, isIndirection, isThunk :: ClosureType -> Bool
205 isConstr Constr = True
208 isIndirection (Indirection _) = True
209 --isIndirection ThunkSelector = True
210 isIndirection _ = False
212 isThunk (Thunk _) = True
213 isThunk ThunkSelector = True
217 isFullyEvaluated :: a -> IO Bool
218 isFullyEvaluated a = do
219 closure <- getClosureData a
221 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
222 return$ and are_subs_evaluated
223 otherwise -> return False
224 where amapM f = sequence . amap' f
226 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
227 where g (I# i#) = case indexArray# arr# i# of
230 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
232 unsafeDeepSeq :: a -> b -> b
233 unsafeDeepSeq = unsafeDeepSeq1 2
234 where unsafeDeepSeq1 0 a b = seq a $! b
235 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
236 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
237 -- | unsafePerformIO (isFullyEvaluated a) = b
238 | otherwise = case unsafePerformIO (getClosureData a) of
239 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
240 where tipe = unsafePerformIO (getClosureType a)
242 isPointed :: Type -> Bool
243 isPointed t | Just (t, _) <- splitTyConApp_maybe t
244 = not$ isUnliftedTypeKind (tyConKind t)
247 extractUnboxed :: [Type] -> Closure -> [[Word]]
248 extractUnboxed tt clos = go tt (nonPtrs clos)
250 | Just (tycon,_) <- splitTyConApp_maybe t
251 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
252 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
255 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
258 sizeofTyCon = sizeofPrimRep . tyConPrimRep
260 -----------------------------------
261 -- * Traversals for Terms
262 -----------------------------------
264 data TermFold a = TermFold { fTerm :: Type -> Either String DataCon -> HValue -> [a] -> a
265 , fPrim :: Type -> [Word] -> a
266 , fSuspension :: ClosureType -> Maybe Type -> HValue
270 foldTerm :: TermFold a -> Term -> a
271 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
272 foldTerm tf (Prim ty v ) = fPrim tf ty v
273 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
275 idTermFold :: TermFold Term
276 idTermFold = TermFold {
279 fSuspension = Suspension
281 idTermFoldM :: Monad m => TermFold (m Term)
282 idTermFoldM = TermFold {
283 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
284 fPrim = (return.). Prim,
285 fSuspension = (((return.).).). Suspension
288 mapTermType :: (Type -> Type) -> Term -> Term
289 mapTermType f = foldTerm idTermFold {
290 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
291 fSuspension = \ct mb_ty hval n ->
292 Suspension ct (fmap f mb_ty) hval n }
294 termTyVars :: Term -> TyVarSet
295 termTyVars = foldTerm TermFold {
296 fTerm = \ty _ _ tt ->
297 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
298 fSuspension = \_ mb_ty _ _ ->
299 maybe emptyVarEnv tyVarsOfType mb_ty,
300 fPrim = \ _ _ -> emptyVarEnv }
301 where concatVarEnv = foldr plusVarEnv emptyVarEnv
302 ----------------------------------
303 -- Pretty printing of terms
304 ----------------------------------
306 app_prec,cons_prec ::Int
308 cons_prec = 5 -- TODO Extract this info from GHC itself
310 pprTerm y p t | Just doc <- pprTermM y p t = doc
312 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
313 pprTermM y p t@Term{dc=Left dc_tag, subTerms=tt, ty=ty} = do
314 tt_docs <- mapM (y app_prec) tt
315 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
317 pprTermM y p t@Term{dc=Right dc, subTerms=tt, ty=ty}
318 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
319 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
320 <+> hsep (map (pprTerm1 True) tt)
321 -} -- TODO Printing infix constructors properly
322 | null tt = return$ ppr dc
323 | Just (tc,_) <- splitNewTyConApp_maybe ty
325 , Just new_dc <- maybeTyConSingleCon tc = do
326 real_value <- y 10 t{ty=repType ty}
327 return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
329 tt_docs <- mapM (y app_prec) tt
330 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
332 pprTermM y _ t = pprTermM1 y t
333 pprTermM1 _ Prim{value=words, ty=ty} =
334 return$ text$ repPrim (tyConAppTyCon ty) words
335 pprTermM1 y t@Term{} = panic "pprTermM1 - unreachable"
336 pprTermM1 _ Suspension{bound_to=Nothing} = return$ char '_'
337 pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
338 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
339 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
341 -- Takes a list of custom printers with a explicit recursion knot and a term,
342 -- and returns the output of the first succesful printer, or the default printer
343 cPprTerm :: forall m. Monad m =>
344 ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
345 cPprTerm custom = go 0 where
346 go prec t@Term{} = do
347 let default_ prec t = Just `liftM` pprTermM go prec t
348 mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
349 Just doc <- firstJustM mb_customDocs
350 return$ cparen (prec>app_prec+1) doc
351 go _ t = pprTermM1 go t
352 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
353 firstJustM [] = return Nothing
355 -- Default set of custom printers. Note that the recursion knot is explicit
356 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
359 ifTerm isTupleTy (\_ -> liftM (parens . hcat . punctuate comma)
360 . mapM (y (-1)) . subTerms)
361 , ifTerm (\t -> isTyCon listTyCon t && subTerms t `lengthIs` 2)
362 (\ p Term{subTerms=[h,t]} -> doList p h t)
363 , ifTerm (isTyCon intTyCon) (coerceShow$ \(a::Int)->a)
364 , ifTerm (isTyCon charTyCon) (coerceShow$ \(a::Char)->a)
365 -- , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
366 , ifTerm (isTyCon floatTyCon) (coerceShow$ \(a::Float)->a)
367 , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
368 , ifTerm isIntegerTy (coerceShow$ \(a::Integer)->a)
370 where ifTerm pred f p t@Term{} | pred t = liftM Just (f p t)
371 ifTerm _ _ _ _ = return Nothing
372 isIntegerTy Term{ty=ty} = fromMaybe False $ do
373 (tc,_) <- splitTyConApp_maybe ty
374 return (tyConName tc == integerTyConName)
375 isTupleTy Term{ty=ty} = fromMaybe False $ do
376 (tc,_) <- splitTyConApp_maybe ty
377 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
378 isTyCon a_tc Term{ty=ty} = fromMaybe False $ do
379 (tc,_) <- splitTyConApp_maybe ty
381 coerceShow f _ = return . text . show . f . unsafeCoerce# . val
382 --TODO pprinting of list terms is not lazy
384 let elems = h : getListTerms t
385 isConsLast = termType(last elems) /= termType h
386 print_elems <- mapM (y cons_prec) elems
387 return$ if isConsLast
388 then cparen (p >= cons_prec) . hsep . punctuate (space<>colon)
390 else brackets (hcat$ punctuate comma print_elems)
392 where Just a /= Just b = not (a `coreEqType` b)
394 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
395 getListTerms t@Term{subTerms=[]} = []
396 getListTerms t@Suspension{} = [t]
397 getListTerms t = pprPanic "getListTerms" (ppr t)
400 repPrim :: TyCon -> [Word] -> String
401 repPrim t = rep where
403 | t == charPrimTyCon = show (build x :: Char)
404 | t == intPrimTyCon = show (build x :: Int)
405 | t == wordPrimTyCon = show (build x :: Word)
406 | t == floatPrimTyCon = show (build x :: Float)
407 | t == doublePrimTyCon = show (build x :: Double)
408 | t == int32PrimTyCon = show (build x :: Int32)
409 | t == word32PrimTyCon = show (build x :: Word32)
410 | t == int64PrimTyCon = show (build x :: Int64)
411 | t == word64PrimTyCon = show (build x :: Word64)
412 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
413 | t == stablePtrPrimTyCon = "<stablePtr>"
414 | t == stableNamePrimTyCon = "<stableName>"
415 | t == statePrimTyCon = "<statethread>"
416 | t == realWorldTyCon = "<realworld>"
417 | t == threadIdPrimTyCon = "<ThreadId>"
418 | t == weakPrimTyCon = "<Weak>"
419 | t == arrayPrimTyCon = "<array>"
420 | t == byteArrayPrimTyCon = "<bytearray>"
421 | t == mutableArrayPrimTyCon = "<mutableArray>"
422 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
423 | t == mutVarPrimTyCon= "<mutVar>"
424 | t == mVarPrimTyCon = "<mVar>"
425 | t == tVarPrimTyCon = "<tVar>"
426 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
427 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
428 -- This ^^^ relies on the representation of Haskell heap values being
429 -- the same as in a C array.
431 -----------------------------------
432 -- Type Reconstruction
433 -----------------------------------
435 Type Reconstruction is type inference done on heap closures.
436 The algorithm walks the heap generating a set of equations, which
437 are solved with syntactic unification.
438 A type reconstruction equation looks like:
440 <datacon reptype> = <actual heap contents>
442 The full equation set is generated by traversing all the subterms, starting
445 The only difficult part is that newtypes are only found in the lhs of equations.
446 Right hand sides are missing them. We can either (a) drop them from the lhs, or
447 (b) reconstruct them in the rhs when possible.
449 The function congruenceNewtypes takes a shot at (b)
452 -- The Type Reconstruction monad
455 runTR :: HscEnv -> TR a -> IO a
457 mb_term <- runTR_maybe hsc_env c
459 Nothing -> panic "Can't unify"
462 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
463 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
466 trIO = liftTcM . ioToTcRn
468 liftTcM :: TcM a -> TR a
471 newVar :: Kind -> TR TcType
472 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
474 -- | Returns the instantiated type scheme ty', and the substitution sigma
475 -- such that sigma(ty') = ty
476 instScheme :: Type -> TR (TcType, TvSubst)
477 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
478 (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
479 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
481 -- Adds a constraint of the form t1 == t2
482 -- t1 is expected to come from walking the heap
483 -- t2 is expected to come from a datacon signature
484 -- Before unification, congruenceNewtypes needs to
486 addConstraint :: TcType -> TcType -> TR ()
487 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
488 >> return () -- TOMDO: what about the coercion?
489 -- we should consider family instances
491 -- Type & Term reconstruction
492 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
493 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
494 tv <- newVar argTypeKind
496 Nothing -> go bound tv tv hval >>= zonkTerm
497 Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
499 (ty',rev_subst) <- instScheme (sigmaType ty)
501 term <- go bound tv tv hval >>= zonkTerm
502 --restore original Tyvars
503 return$ mapTermType (substTy rev_subst) term
505 go bound _ _ _ | seq bound False = undefined
507 clos <- trIO $ getClosureData a
508 return (Suspension (tipe clos) (Just tv) a Nothing)
509 go bound tv ty a = do
510 let monomorphic = not(isTyVarTy tv)
511 -- This ^^^ is a convention. The ancestor tests for
512 -- monomorphism and passes a type instead of a tv
513 clos <- trIO $ getClosureData a
515 -- Thunks we may want to force
516 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
517 -- force blackholes, because it would almost certainly result in deadlock,
518 -- and showing the '_' is more useful.
519 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
520 -- We always follow indirections
521 Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
522 -- The interesting case
524 Right dcname <- dataConInfoPtrToName (infoPtr clos)
525 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
527 Nothing -> do -- This can happen for private constructors compiled -O0
528 -- where the .hi descriptor does not export them
529 -- In such case, we return a best approximation:
530 -- ignore the unpointed args, and recover the pointeds
531 -- This preserves laziness, and should be safe.
532 let tag = showSDoc (ppr dcname)
533 vars <- replicateM (length$ elems$ ptrs clos)
534 (newVar (liftedTypeKind))
535 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
536 | (i, tv) <- zip [0..] vars]
537 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
539 let extra_args = length(dataConRepArgTys dc) -
540 length(dataConOrigArgTys dc)
541 subTtypes = matchSubTypes dc ty
542 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
543 subTermTvs <- sequence
544 [ if isMonomorphic t then return t
546 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
547 -- It is vital for newtype reconstruction that the unification step
548 -- is done right here, _before_ the subterms are RTTI reconstructed
549 when (not monomorphic) $ do
550 let myType = mkFunTys (reOrderTerms subTermTvs
554 (signatureType,_) <- instScheme(dataConRepType dc)
555 addConstraint myType signatureType
556 subTermsP <- sequence $ drop extra_args
557 -- ^^^ all extra arguments are pointed
558 [ appArr (go (pred bound) tv t) (ptrs clos) i
559 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
560 let unboxeds = extractUnboxed subTtypesNP clos
561 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
562 subTerms = reOrderTerms subTermsP subTermsNP
563 (drop extra_args subTtypes)
564 return (Term tv (Right dc) a subTerms)
565 -- The otherwise case: can be a Thunk,AP,PAP,etc.
567 return (Suspension tipe_clos (Just tv) a Nothing)
569 -- matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
571 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
572 -- assumption: ^^^ looks through newtypes
573 , isVanillaDataCon dc --TODO non-vanilla case
574 = dataConInstArgTys dc ty_args
575 | otherwise = dataConRepArgTys dc
577 -- This is used to put together pointed and nonpointed subterms in the
579 reOrderTerms _ _ [] = []
580 reOrderTerms pointed unpointed (ty:tys)
581 | isPointed ty = ASSERT2(not(null pointed)
582 , ptext SLIT("reOrderTerms") $$
583 (ppr pointed $$ ppr unpointed))
584 head pointed : reOrderTerms (tail pointed) unpointed tys
585 | otherwise = ASSERT2(not(null unpointed)
586 , ptext SLIT("reOrderTerms") $$
587 (ppr pointed $$ ppr unpointed))
588 head unpointed : reOrderTerms pointed (tail unpointed) tys
592 -- Fast, breadth-first Type reconstruction
593 max_depth = 10 :: Int
594 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO (Maybe Type)
595 cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
596 tv <- newVar argTypeKind
598 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
600 (Seq.singleton (tv, hval))
602 zonkTcType tv -- TODO untested!
603 Just ty | isMonomorphic ty -> return ty
605 (ty',rev_subst) <- instScheme (sigmaType ty)
607 search (isMonomorphic `fmap` zonkTcType tv)
609 (Seq.singleton (tv, hval))
611 substTy rev_subst `fmap` zonkTcType tv
613 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
614 search stop expand l depth | Seq.null l = return ()
615 search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
616 show max_depth ++ " steps"
617 search stop expand l d | x :< xx <- viewl l = unlessM stop $ do
619 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
621 -- returns unification tasks,since we are going to want a breadth-first search
622 go :: Type -> HValue -> TR [(Type, HValue)]
624 clos <- trIO $ getClosureData a
626 Indirection _ -> go tv $! (ptrs clos ! 0)
628 Right dcname <- dataConInfoPtrToName (infoPtr clos)
629 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
632 -- TODO: Check this case
633 vars <- replicateM (length$ elems$ ptrs clos)
634 (newVar (liftedTypeKind))
635 subTerms <- sequence [ appArr (go tv) (ptrs clos) i
636 | (i, tv) <- zip [0..] vars]
637 forM [0..length (elems $ ptrs clos)] $ \i -> do
638 tv <- newVar liftedTypeKind
639 return$ appArr (\e->(tv,e)) (ptrs clos) i
642 let extra_args = length(dataConRepArgTys dc) -
643 length(dataConOrigArgTys dc)
644 subTtypes <- mapMif (not . isMonomorphic)
645 (\t -> newVar (typeKind t))
646 (dataConRepArgTys dc)
648 -- It is vital for newtype reconstruction that the unification step
649 -- is done right here, _before_ the subterms are RTTI reconstructed
650 let myType = mkFunTys subTtypes tv
651 (signatureType,_) <- instScheme(dataConRepType dc)
652 addConstraint myType signatureType
653 return $ [ appArr (\e->(t,e)) (ptrs clos) i
654 | (i,t) <- drop extra_args $
655 zip [0..] (filter isPointed subTtypes)]
656 otherwise -> return []
658 -- This helper computes the difference between a base type t and the
659 -- improved rtti_t computed by RTTI
660 -- The main difference between RTTI types and their normal counterparts
661 -- is that the former are _not_ polymorphic, thus polymorphism must
662 -- be stripped. Syntactically, forall's must be stripped
663 computeRTTIsubst ty rtti_ty =
664 -- In addition, we strip newtypes too, since the reconstructed type might
665 -- not have recovered them all
666 tcUnifyTys (const BindMe)
667 [repType' $ dropForAlls$ ty]
669 -- TODO stripping newtypes shouldn't be necessary, test
672 -- Dealing with newtypes
674 A parallel fold over two Type values,
675 compensating for missing newtypes on both sides.
676 This is necessary because newtypes are not present
677 in runtime, but since sometimes there is evidence
678 available we do our best to reconstruct them.
679 Evidence can come from DataCon signatures or
680 from compile-time type inference.
681 I am using the words congruence and rewriting
682 because what we are doing here is an approximation
683 of unification modulo a set of equations, which would
684 come from newtype definitions. These should be the
685 equality coercions seen in System Fc. Rewriting
686 is performed, taking those equations as rules,
687 before launching unification.
689 It doesn't make sense to rewrite everywhere,
690 or we would end up with all newtypes. So we rewrite
691 only in presence of evidence.
692 The lhs comes from the heap structure of ptrs,nptrs.
693 The rhs comes from a DataCon type signature.
694 Rewriting in the rhs is restricted to the result type.
696 Note that it is very tricky to make this 'rewriting'
697 work with the unification implemented by TcM, where
698 substitutions are 'inlined'. The order in which
699 constraints are unified is vital for this (or I am
702 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
703 congruenceNewtypes lhs rhs
704 -- TyVar lhs inductive case
705 | Just tv <- getTyVar_maybe lhs
706 = recoverTc (return (lhs,rhs)) $ do
707 Indirect ty_v <- readMetaTyVar tv
708 (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
710 -- FunTy inductive case
711 | Just (l1,l2) <- splitFunTy_maybe lhs
712 , Just (r1,r2) <- splitFunTy_maybe rhs
713 = do (l2',r2') <- congruenceNewtypes l2 r2
714 (l1',r1') <- congruenceNewtypes l1 r1
715 return (mkFunTy l1' l2', mkFunTy r1' r2')
716 -- TyconApp Inductive case; this is the interesting bit.
717 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
718 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
720 = return (lhs, upgrade tycon_l rhs)
722 | otherwise = return (lhs,rhs)
724 where upgrade :: TyCon -> Type -> Type
726 | not (isNewTyCon new_tycon) = ty
727 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
728 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
730 -- assumes that reptype doesn't touch tyconApp args ^^^
733 --------------------------------------------------------------------------------
734 -- Semantically different to recoverM in TcRnMonad
735 -- recoverM retains the errors in the first action,
736 -- whereas recoverTc here does not
737 recoverTc recover thing = do
738 (_,mb_res) <- tryTcErrs thing
741 Just res -> return res
743 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
744 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
746 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
747 mapMif pred f xx = sequence $ mapMif_ pred f xx
748 mapMif_ pred f [] = []
749 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
751 unlessM condM acc = condM >>= \c -> unless c acc
753 -- Strict application of f at index i
754 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
755 = ASSERT (i < length(elems a))
756 case indexArray# ptrs# i# of
759 zonkTerm :: Term -> TcM Term
760 zonkTerm = foldTerm idTermFoldM {
761 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
762 zonkTcType ty >>= \ty' ->
763 return (Term ty' dc v tt)
764 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
765 return (Suspension ct ty v b)}
768 -- Is this defined elsewhere?
769 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
770 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty