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 -> Bool -> Maybe Type -> HValue -> IO Term
31 #include "HsVersions.h"
33 import ByteCodeItbls ( StgInfoTable )
34 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
35 import ByteCodeLink ( HValue )
36 import HscTypes ( HscEnv )
40 import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM)
53 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
65 import GHC.Arr ( Array(..) )
66 import GHC.Ptr ( Ptr(..), castPtr )
71 import Data.Array.Base
72 import Data.List ( partition, nub )
74 import System.IO.Unsafe
76 ---------------------------------------------
77 -- * A representation of semi evaluated Terms
78 ---------------------------------------------
80 A few examples in this representation:
82 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
84 > (('a',_,_),_,('b',_,_)) =
85 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
86 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
88 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
91 data Term = Term { ty :: Type
92 , dc :: DataCon -- The heap datacon. If ty is a newtype,
93 -- this is NOT the newtype datacon
95 , subTerms :: [Term] }
100 | Suspension { ctype :: ClosureType
101 , mb_ty :: Maybe Type
103 , bound_to :: Maybe Name -- Useful for printing
106 isTerm, isSuspension, isPrim :: Term -> Bool
109 isSuspension Suspension{} = True
110 isSuspension _ = False
114 termType :: Term -> Maybe Type
115 termType t@(Suspension {}) = mb_ty t
116 termType t = Just$ ty t
118 isFullyEvaluatedTerm :: Term -> Bool
119 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
120 isFullyEvaluatedTerm Suspension {} = False
121 isFullyEvaluatedTerm Prim {} = True
123 instance Outputable (Term) where
124 ppr = head . cPprTerm cPprTermBase
126 -------------------------------------------------------------------------
127 -- Runtime Closure Datatype and functions for retrieving closure related stuff
128 -------------------------------------------------------------------------
129 data ClosureType = Constr
140 data Closure = Closure { tipe :: ClosureType
142 , infoTable :: StgInfoTable
143 , ptrs :: Array Int HValue
147 instance Outputable ClosureType where
150 #include "../includes/ClosureTypes.h"
157 getClosureData :: a -> IO Closure
159 case unpackClosure# a of
160 (# iptr, ptrs, nptrs #) -> do
161 itbl <- peek (Ptr iptr)
162 let tipe = readCType (BCI.tipe itbl)
163 elems = BCI.ptrs itbl
164 ptrsList = Array 0 (fromIntegral$ elems) ptrs
165 nptrs_data = [W# (indexWordArray# nptrs i)
166 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
168 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
170 readCType :: Integral a => a -> ClosureType
172 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
173 | i >= FUN && i <= FUN_STATIC = Fun
174 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
175 | i == THUNK_SELECTOR = ThunkSelector
176 | i == BLACKHOLE = Blackhole
177 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
178 | fromIntegral i == aP_CODE = AP
180 | fromIntegral i == pAP_CODE = PAP
181 | otherwise = Other (fromIntegral i)
183 isConstr, isIndirection, isThunk :: ClosureType -> Bool
184 isConstr Constr = True
187 isIndirection (Indirection _) = True
188 --isIndirection ThunkSelector = True
189 isIndirection _ = False
191 isThunk (Thunk _) = True
192 isThunk ThunkSelector = True
196 isFullyEvaluated :: a -> IO Bool
197 isFullyEvaluated a = do
198 closure <- getClosureData a
200 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
201 return$ and are_subs_evaluated
202 otherwise -> return False
203 where amapM f = sequence . amap' f
205 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
209 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
211 unsafeDeepSeq :: a -> b -> b
212 unsafeDeepSeq = unsafeDeepSeq1 2
213 where unsafeDeepSeq1 0 a b = seq a $! b
214 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
215 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
216 -- | unsafePerformIO (isFullyEvaluated a) = b
217 | otherwise = case unsafePerformIO (getClosureData a) of
218 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
219 where tipe = unsafePerformIO (getClosureType a)
221 isPointed :: Type -> Bool
222 isPointed t | Just (t, _) <- splitTyConApp_maybe t
223 = not$ isUnliftedTypeKind (tyConKind t)
226 extractUnboxed :: [Type] -> Closure -> [[Word]]
227 extractUnboxed tt clos = go tt (nonPtrs clos)
229 | Just (tycon,_) <- splitTyConApp_maybe t
230 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
231 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
234 | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
237 sizeofTyCon = sizeofPrimRep . tyConPrimRep
239 -----------------------------------
240 -- * Traversals for Terms
241 -----------------------------------
243 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
244 , fPrim :: Type -> [Word] -> a
245 , fSuspension :: ClosureType -> Maybe Type -> HValue
249 foldTerm :: TermFold a -> Term -> a
250 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
251 foldTerm tf (Prim ty v ) = fPrim tf ty v
252 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
254 idTermFold :: TermFold Term
255 idTermFold = TermFold {
258 fSuspension = Suspension
260 idTermFoldM :: Monad m => TermFold (m Term)
261 idTermFoldM = TermFold {
262 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
263 fPrim = (return.). Prim,
264 fSuspension = (((return.).).). Suspension
267 mapTermType :: (Type -> Type) -> Term -> Term
268 mapTermType f = foldTerm idTermFold {
269 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
270 fSuspension = \ct mb_ty hval n ->
271 Suspension ct (fmap f mb_ty) hval n }
273 termTyVars :: Term -> TyVarSet
274 termTyVars = foldTerm TermFold {
275 fTerm = \ty _ _ tt ->
276 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
277 fSuspension = \_ mb_ty _ _ ->
278 maybe emptyVarEnv tyVarsOfType mb_ty,
279 fPrim = \ _ _ -> emptyVarEnv }
280 where concatVarEnv = foldr plusVarEnv emptyVarEnv
281 ----------------------------------
282 -- Pretty printing of terms
283 ----------------------------------
285 app_prec,cons_prec ::Int
287 cons_prec = 5 -- TODO Extract this info from GHC itself
289 pprTerm y p t | Just doc <- pprTermM y p t = doc
291 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
292 pprTermM y p t@Term{dc=dc, subTerms=tt, ty=ty}
293 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
294 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
295 <+> hsep (map (pprTerm1 True) tt)
297 | null tt = return$ ppr dc
298 | Just (tc,_) <- splitNewTyConApp_maybe ty
300 , Just new_dc <- maybeTyConSingleCon tc = do
301 real_value <- y 10 t{ty=repType ty}
302 return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
304 tt_docs <- mapM (y app_prec) tt
305 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
307 pprTermM y _ t = pprTermM1 y t
309 pprTermM1 _ Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty)
311 pprTermM1 y t@Term{} = panic "pprTermM1 - unreachable"
312 pprTermM1 _ Suspension{bound_to=Nothing} = return$ char '_'
313 pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
314 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
315 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
317 -- Takes a list of custom printers with a explicit recursion knot and a term,
318 -- and returns the output of the first succesful printer, or the default printer
319 cPprTerm :: forall m. Monad m =>
320 ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
321 cPprTerm custom = go 0 where
322 go prec t@Term{} = do
323 let default_ prec t = Just `liftM` pprTermM go prec t
324 mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
325 Just doc <- firstJustM mb_customDocs
326 return$ cparen (prec>app_prec+1) doc
327 go _ t = pprTermM1 go t
328 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
329 firstJustM [] = return Nothing
331 -- Default set of custom printers. Note that the recursion knot is explicit
332 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
335 ifTerm isTupleTy (\_ -> liftM (parens . hcat . punctuate comma)
336 . mapM (y (-1)) . subTerms)
337 , ifTerm (\t -> isTyCon listTyCon t && subTerms t `lengthIs` 2)
338 (\ p Term{subTerms=[h,t]} -> doList p h t)
339 , ifTerm (isTyCon intTyCon) (coerceShow$ \(a::Int)->a)
340 , ifTerm (isTyCon charTyCon) (coerceShow$ \(a::Char)->a)
341 -- , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
342 , ifTerm (isTyCon floatTyCon) (coerceShow$ \(a::Float)->a)
343 , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
344 , ifTerm isIntegerTy (coerceShow$ \(a::Integer)->a)
346 where ifTerm pred f p t@Term{} | pred t = liftM Just (f p t)
347 | otherwise = return Nothing
348 isIntegerTy Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
349 = tyConName tc == integerTyConName
350 isTupleTy Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
351 = tc `elem` (fst.unzip.elems) boxedTupleArr
352 isTyCon a_tc Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
354 coerceShow f _ = return . text . show . f . unsafeCoerce# . val
355 --TODO pprinting of list terms is not lazy
357 let elems = h : getListTerms t
358 isConsLast = termType(last elems) /= termType h
359 print_elems <- mapM (y cons_prec) elems
360 return$ if isConsLast
361 then cparen (p >= cons_prec) . hsep . punctuate (space<>colon)
363 else brackets (hcat$ punctuate comma print_elems)
365 where Just a /= Just b = not (a `coreEqType` b)
367 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
368 getListTerms t@Term{subTerms=[]} = []
369 getListTerms t@Suspension{} = [t]
370 getListTerms t = pprPanic "getListTerms" (ppr t)
373 repPrim :: TyCon -> [Word] -> String
374 repPrim t = rep where
376 | t == charPrimTyCon = show (build x :: Char)
377 | t == intPrimTyCon = show (build x :: Int)
378 | t == wordPrimTyCon = show (build x :: Word)
379 | t == floatPrimTyCon = show (build x :: Float)
380 | t == doublePrimTyCon = show (build x :: Double)
381 | t == int32PrimTyCon = show (build x :: Int32)
382 | t == word32PrimTyCon = show (build x :: Word32)
383 | t == int64PrimTyCon = show (build x :: Int64)
384 | t == word64PrimTyCon = show (build x :: Word64)
385 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
386 | t == stablePtrPrimTyCon = "<stablePtr>"
387 | t == stableNamePrimTyCon = "<stableName>"
388 | t == statePrimTyCon = "<statethread>"
389 | t == realWorldTyCon = "<realworld>"
390 | t == threadIdPrimTyCon = "<ThreadId>"
391 | t == weakPrimTyCon = "<Weak>"
392 | t == arrayPrimTyCon = "<array>"
393 | t == byteArrayPrimTyCon = "<bytearray>"
394 | t == mutableArrayPrimTyCon = "<mutableArray>"
395 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
396 | t == mutVarPrimTyCon= "<mutVar>"
397 | t == mVarPrimTyCon = "<mVar>"
398 | t == tVarPrimTyCon = "<tVar>"
399 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
400 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
401 -- This ^^^ relies on the representation of Haskell heap values being
402 -- the same as in a C array.
404 -----------------------------------
405 -- Type Reconstruction
406 -----------------------------------
408 Type Reconstruction is type inference done on heap closures.
409 The algorithm walks the heap generating a set of equations, which
410 are solved with syntactic unification.
411 A type reconstruction equation looks like:
413 <datacon reptype> = <actual heap contents>
415 The full equation set is generated by traversing all the subterms, starting
418 The only difficult part is that newtypes are only found in the lhs of equations.
419 Right hand sides are missing them. We can either (a) drop them from the lhs, or
420 (b) reconstruct them in the rhs when possible.
422 The function congruenceNewtypes takes a shot at (b)
425 -- The Type Reconstruction monad
428 runTR :: HscEnv -> TR a -> IO a
430 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
432 Nothing -> panic "Can't unify"
436 trIO = liftTcM . ioToTcRn
438 liftTcM :: TcM a -> TR a
441 newVar :: Kind -> TR TcTyVar
442 newVar = liftTcM . newFlexiTyVar
444 -- | Returns the instantiated type scheme ty', and the substitution sigma
445 -- such that sigma(ty') = ty
446 instScheme :: Type -> TR (TcType, TvSubst)
447 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
448 (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
449 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
451 -- Adds a constraint of the form t1 == t2
452 -- t1 is expected to come from walking the heap
453 -- t2 is expected to come from a datacon signature
454 -- Before unification, congruenceNewtypes needs to
456 addConstraint :: TcType -> TcType -> TR ()
457 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
461 -- Type & Term reconstruction
462 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
463 cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
464 tv <- liftM mkTyVarTy (newVar argTypeKind)
466 Nothing -> go tv tv hval >>= zonkTerm
467 Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
469 (ty',rev_subst) <- instScheme (sigmaType ty)
471 term <- go tv tv hval >>= zonkTerm
472 --restore original Tyvars
473 return$ mapTermType (substTy rev_subst) term
476 let monomorphic = not(isTyVarTy tv)
477 -- This ^^^ is a convention. The ancestor tests for
478 -- monomorphism and passes a type instead of a tv
479 clos <- trIO $ getClosureData a
481 -- Thunks we may want to force
482 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
483 -- force blackholes, because it would almost certainly result in deadlock,
484 -- and showing the '_' is more useful.
485 t | isThunk t && force -> seq a $ go tv ty a
486 -- We always follow indirections
487 Indirection _ -> go tv ty $! (ptrs clos ! 0)
488 -- The interesting case
490 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
492 Nothing -> panic "Can't find the DataCon for a term"
494 let extra_args = length(dataConRepArgTys dc) -
495 length(dataConOrigArgTys dc)
496 subTtypes = matchSubTypes dc ty
497 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
498 subTermTvs <- sequence
499 [ if isMonomorphic t then return t
500 else (mkTyVarTy `fmap` newVar k)
501 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
502 -- It is vital for newtype reconstruction that the unification step
503 -- is done right here, _before_ the subterms are RTTI reconstructed
504 when (not monomorphic) $ do
505 let myType = mkFunTys (reOrderTerms subTermTvs
509 (signatureType,_) <- instScheme(dataConRepType dc)
510 addConstraint myType signatureType
511 subTermsP <- sequence $ drop extra_args
512 -- ^^^ all extra arguments are pointed
513 [ appArr (go tv t) (ptrs clos) i
514 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
515 let unboxeds = extractUnboxed subTtypesNP clos
516 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
517 subTerms = reOrderTerms subTermsP subTermsNP
518 (drop extra_args subTtypes)
519 return (Term tv dc a subTerms)
520 -- The otherwise case: can be a Thunk,AP,PAP,etc.
522 return (Suspension (tipe clos) (Just tv) a Nothing)
525 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
526 , isVanillaDataCon dc --TODO non-vanilla case
527 = dataConInstArgTys dc ty_args
528 -- assumes that newtypes are looked ^^^ through
529 | otherwise = dataConRepArgTys dc
531 -- This is used to put together pointed and nonpointed subterms in the
533 reOrderTerms _ _ [] = []
534 reOrderTerms pointed unpointed (ty:tys)
535 | isPointed ty = ASSERT2(not(null pointed)
536 , ptext SLIT("reOrderTerms") $$
537 (ppr pointed $$ ppr unpointed))
538 head pointed : reOrderTerms (tail pointed) unpointed tys
539 | otherwise = ASSERT2(not(null unpointed)
540 , ptext SLIT("reOrderTerms") $$
541 (ppr pointed $$ ppr unpointed))
542 head unpointed : reOrderTerms pointed (tail unpointed) tys
546 -- Fast, breadth-first Type reconstruction
547 max_depth = 10 :: Int
548 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
549 cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
550 tv <- liftM mkTyVarTy (newVar argTypeKind)
552 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
556 zonkTcType tv -- TODO untested!
557 Just ty | isMonomorphic ty -> return ty
559 (ty',rev_subst) <- instScheme (sigmaType ty)
561 search (isMonomorphic `fmap` zonkTcType tv)
565 substTy rev_subst `fmap` zonkTcType tv
567 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
568 search stop expand [] depth = return ()
569 search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
570 show max_depth ++ " steps"
571 search stop expand (x:xx) d = do
573 unlessM stop $ search stop expand (xx ++ new) $! (pred d)
575 -- returns unification tasks,since we are going to want a breadth-first search
576 go :: Type -> HValue -> TR [(Type, HValue)]
578 clos <- trIO $ getClosureData a
580 Indirection _ -> go tv $! (ptrs clos ! 0)
582 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
584 Nothing -> panic "Can't find the DataCon for a term"
586 let extra_args = length(dataConRepArgTys dc) -
587 length(dataConOrigArgTys dc)
588 subTtypes <- mapMif (not . isMonomorphic)
589 (\t -> mkTyVarTy `fmap` newVar (typeKind t))
590 (dataConRepArgTys dc)
591 -- It is vital for newtype reconstruction that the unification step
592 -- is done right here, _before_ the subterms are RTTI reconstructed
593 let myType = mkFunTys subTtypes tv
594 (signatureType,_) <- instScheme(dataConRepType dc)
595 addConstraint myType signatureType
596 return $ [ appArr (\e->(t,e)) (ptrs clos) i
597 | (i,t) <- drop extra_args $ zip [0..] subTtypes]
598 otherwise -> return []
601 -- Dealing with newtypes
603 A parallel fold over two Type values,
604 compensating for missing newtypes on both sides.
605 This is necessary because newtypes are not present
606 in runtime, but since sometimes there is evidence
607 available we do our best to reconstruct them.
608 Evidence can come from DataCon signatures or
609 from compile-time type inference.
610 I am using the words congruence and rewriting
611 because what we are doing here is an approximation
612 of unification modulo a set of equations, which would
613 come from newtype definitions. These should be the
614 equality coercions seen in System Fc. Rewriting
615 is performed, taking those equations as rules,
616 before launching unification.
618 It doesn't make sense to rewrite everywhere,
619 or we would end up with all newtypes. So we rewrite
620 only in presence of evidence.
621 The lhs comes from the heap structure of ptrs,nptrs.
622 The rhs comes from a DataCon type signature.
623 Rewriting in the rhs is restricted to the result type.
625 Note that it is very tricky to make this 'rewriting'
626 work with the unification implemented by TcM, where
627 substitutions are 'inlined'. The order in which
628 constraints are unified is vital for this (or I am
631 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
632 congruenceNewtypes lhs rhs
633 -- TyVar lhs inductive case
634 | Just tv <- getTyVar_maybe lhs
635 = recoverM (return (lhs,rhs)) $ do
636 Indirect ty_v <- readMetaTyVar tv
637 (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
639 -- FunTy inductive case
640 | Just (l1,l2) <- splitFunTy_maybe lhs
641 , Just (r1,r2) <- splitFunTy_maybe rhs
642 = do (l2',r2') <- congruenceNewtypes l2 r2
643 (l1',r1') <- congruenceNewtypes l1 r1
644 return (mkFunTy l1' l2', mkFunTy r1' r2')
645 -- TyconApp Inductive case; this is the interesting bit.
646 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
647 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
649 = return (lhs, upgrade tycon_l rhs)
651 | otherwise = return (lhs,rhs)
653 where upgrade :: TyCon -> Type -> Type
655 | not (isNewTyCon new_tycon) = ty
656 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
657 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
659 -- assumes that reptype doesn't touch tyconApp args ^^^
662 --------------------------------------------------------------------------------
664 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
665 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
667 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
668 mapMif pred f xx = sequence $ mapMif_ pred f xx
669 mapMif_ pred f [] = []
670 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
672 unlessM condM acc = condM >>= \c -> unless c acc
674 -- Strict application of f at index i
675 appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
678 zonkTerm :: Term -> TcM Term
679 zonkTerm = foldTerm idTermFoldM {
680 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
681 zonkTcType ty >>= \ty' ->
682 return (Term ty' dc v tt)
683 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
684 return (Suspension ct ty v b)}
687 -- Is this defined elsewhere?
688 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
689 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty