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
108 isSuspension Suspension{} = True
109 isSuspension _ = False
113 termType t@(Suspension {}) = mb_ty t
114 termType t = Just$ ty t
116 isFullyEvaluatedTerm :: Term -> Bool
117 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
118 isFullyEvaluatedTerm Suspension {} = False
119 isFullyEvaluatedTerm Prim {} = True
121 instance Outputable (Term) where
122 ppr = head . cPprTerm cPprTermBase
124 -------------------------------------------------------------------------
125 -- Runtime Closure Datatype and functions for retrieving closure related stuff
126 -------------------------------------------------------------------------
127 data ClosureType = Constr
138 data Closure = Closure { tipe :: ClosureType
140 , infoTable :: StgInfoTable
141 , ptrs :: Array Int HValue
145 instance Outputable ClosureType where
148 #include "../includes/ClosureTypes.h"
155 getClosureData :: a -> IO Closure
157 case unpackClosure# a of
158 (# iptr, ptrs, nptrs #) -> do
159 itbl <- peek (Ptr iptr)
160 let tipe = readCType (BCI.tipe itbl)
161 elems = BCI.ptrs itbl
162 ptrsList = Array 0 (fromIntegral$ elems) ptrs
163 nptrs_data = [W# (indexWordArray# nptrs i)
164 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
166 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
168 readCType :: Integral a => a -> ClosureType
170 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
171 | i >= FUN && i <= FUN_STATIC = Fun
172 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
173 | i == THUNK_SELECTOR = ThunkSelector
174 | i == BLACKHOLE = Blackhole
175 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
176 | fromIntegral i == aP_CODE = AP
178 | fromIntegral i == pAP_CODE = PAP
179 | otherwise = Other (fromIntegral i)
181 isConstr, isIndirection :: ClosureType -> Bool
182 isConstr Constr = True
185 isIndirection (Indirection _) = True
186 --isIndirection ThunkSelector = True
187 isIndirection _ = False
189 isThunk (Thunk _) = True
190 isThunk ThunkSelector = True
194 isFullyEvaluated :: a -> IO Bool
195 isFullyEvaluated a = do
196 closure <- getClosureData a
198 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
199 return$ and are_subs_evaluated
200 otherwise -> return False
201 where amapM f = sequence . amap' f
203 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
207 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
209 unsafeDeepSeq :: a -> b -> b
210 unsafeDeepSeq = unsafeDeepSeq1 2
211 where unsafeDeepSeq1 0 a b = seq a $! b
212 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
213 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
214 -- | unsafePerformIO (isFullyEvaluated a) = b
215 | otherwise = case unsafePerformIO (getClosureData a) of
216 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
217 where tipe = unsafePerformIO (getClosureType a)
219 isPointed :: Type -> Bool
220 isPointed t | Just (t, _) <- splitTyConApp_maybe t
221 = not$ isUnliftedTypeKind (tyConKind t)
224 extractUnboxed :: [Type] -> Closure -> [[Word]]
225 extractUnboxed tt clos = go tt (nonPtrs clos)
227 | Just (tycon,_) <- splitTyConApp_maybe t
228 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
229 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
232 | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
235 sizeofTyCon = sizeofPrimRep . tyConPrimRep
237 -----------------------------------
238 -- * Traversals for Terms
239 -----------------------------------
241 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
242 , fPrim :: Type -> [Word] -> a
243 , fSuspension :: ClosureType -> Maybe Type -> HValue
247 foldTerm :: TermFold a -> Term -> a
248 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
249 foldTerm tf (Prim ty v ) = fPrim tf ty v
250 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
252 idTermFold :: TermFold Term
253 idTermFold = TermFold {
256 fSuspension = Suspension
258 idTermFoldM :: Monad m => TermFold (m Term)
259 idTermFoldM = TermFold {
260 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
261 fPrim = (return.). Prim,
262 fSuspension = (((return.).).). Suspension
265 mapTermType f = foldTerm idTermFold {
266 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
267 fSuspension = \ct mb_ty hval n ->
268 Suspension ct (fmap f mb_ty) hval n }
270 termTyVars = foldTerm TermFold {
271 fTerm = \ty _ _ tt ->
272 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
273 fSuspension = \_ mb_ty _ _ ->
274 maybe emptyVarEnv tyVarsOfType mb_ty,
275 fPrim = \ _ _ -> emptyVarEnv }
276 where concatVarEnv = foldr plusVarEnv emptyVarEnv
277 ----------------------------------
278 -- Pretty printing of terms
279 ----------------------------------
281 app_prec,cons_prec ::Int
283 cons_prec = 5 -- TODO Extract this info from GHC itself
285 pprTerm y p t | Just doc <- pprTermM y p t = doc
287 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
288 pprTermM y p t@Term{dc=dc, subTerms=tt, ty=ty}
289 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
290 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
291 <+> hsep (map (pprTerm1 True) tt)
293 | null tt = return$ ppr dc
294 | Just (tc,_) <- splitNewTyConApp_maybe ty
296 , Just new_dc <- maybeTyConSingleCon tc = do
297 real_value <- y 10 t{ty=repType ty}
298 return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
300 tt_docs <- mapM (y app_prec) tt
301 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
303 pprTermM y _ t = pprTermM1 y t
305 pprTermM1 _ Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty)
307 pprTermM1 y t@Term{} = panic "pprTermM1 - unreachable"
308 pprTermM1 _ Suspension{bound_to=Nothing} = return$ char '_'
309 pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
310 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
311 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
313 -- Takes a list of custom printers with a explicit recursion knot and a term,
314 -- and returns the output of the first succesful printer, or the default printer
315 cPprTerm :: forall m. Monad m =>
316 ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
317 cPprTerm custom = go 0 where
318 go prec t@Term{subTerms=tt, dc=dc} = do
319 let default_ prec t = Just `liftM` pprTermM go prec t
320 mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
321 Just doc <- firstJustM mb_customDocs
322 return$ cparen (prec>app_prec+1) doc
323 go _ t = pprTermM1 go t
324 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
325 firstJustM [] = return Nothing
327 -- Default set of custom printers. Note that the recursion knot is explicit
328 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
331 ifTerm isTupleTy (\_ -> liftM (parens . hcat . punctuate comma)
332 . mapM (y (-1)) . subTerms)
333 , ifTerm (\t -> isTyCon listTyCon t && subTerms t `lengthIs` 2)
334 (\ p Term{subTerms=[h,t]} -> doList p h t)
335 , ifTerm (isTyCon intTyCon) (coerceShow$ \(a::Int)->a)
336 , ifTerm (isTyCon charTyCon) (coerceShow$ \(a::Char)->a)
337 -- , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
338 , ifTerm (isTyCon floatTyCon) (coerceShow$ \(a::Float)->a)
339 , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
340 , ifTerm isIntegerTy (coerceShow$ \(a::Integer)->a)
342 where ifTerm pred f p t@Term{} | pred t = liftM Just (f p t)
343 | otherwise = return Nothing
344 isIntegerTy Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
345 = tyConName tc == integerTyConName
346 isTupleTy Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
347 = tc `elem` (fst.unzip.elems) boxedTupleArr
348 isTyCon a_tc Term{ty=ty} | Just (tc,_) <- splitTyConApp_maybe ty
350 coerceShow f _ = return . text . show . f . unsafeCoerce# . val
351 --TODO pprinting of list terms is not lazy
353 let elems = h : getListTerms t
354 isConsLast = termType(last elems) /= termType h
355 print_elems <- mapM (y cons_prec) elems
356 return$ if isConsLast
357 then cparen (p >= cons_prec) . hsep . punctuate (space<>colon)
359 else brackets (hcat$ punctuate comma print_elems)
361 where Just a /= Just b = not (a `coreEqType` b)
363 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
364 getListTerms t@Term{subTerms=[]} = []
365 getListTerms t@Suspension{} = [t]
366 getListTerms t = pprPanic "getListTerms" (ppr t)
369 repPrim :: TyCon -> [Word] -> String
370 repPrim t = rep where
372 | t == charPrimTyCon = show (build x :: Char)
373 | t == intPrimTyCon = show (build x :: Int)
374 | t == wordPrimTyCon = show (build x :: Word)
375 | t == floatPrimTyCon = show (build x :: Float)
376 | t == doublePrimTyCon = show (build x :: Double)
377 | t == int32PrimTyCon = show (build x :: Int32)
378 | t == word32PrimTyCon = show (build x :: Word32)
379 | t == int64PrimTyCon = show (build x :: Int64)
380 | t == word64PrimTyCon = show (build x :: Word64)
381 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
382 | t == stablePtrPrimTyCon = "<stablePtr>"
383 | t == stableNamePrimTyCon = "<stableName>"
384 | t == statePrimTyCon = "<statethread>"
385 | t == realWorldTyCon = "<realworld>"
386 | t == threadIdPrimTyCon = "<ThreadId>"
387 | t == weakPrimTyCon = "<Weak>"
388 | t == arrayPrimTyCon = "<array>"
389 | t == byteArrayPrimTyCon = "<bytearray>"
390 | t == mutableArrayPrimTyCon = "<mutableArray>"
391 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
392 | t == mutVarPrimTyCon= "<mutVar>"
393 | t == mVarPrimTyCon = "<mVar>"
394 | t == tVarPrimTyCon = "<tVar>"
395 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
396 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
397 -- This ^^^ relies on the representation of Haskell heap values being
398 -- the same as in a C array.
400 -----------------------------------
401 -- Type Reconstruction
402 -----------------------------------
404 Type Reconstruction is type inference done on heap closures.
405 The algorithm walks the heap generating a set of equations, which
406 are solved with syntactic unification.
407 A type reconstruction equation looks like:
409 <datacon reptype> = <actual heap contents>
411 The full equation set is generated by traversing all the subterms, starting
414 The only difficult part is that newtypes are only found in the lhs of equations.
415 Right hand sides are missing them. We can either (a) drop them from the lhs, or
416 (b) reconstruct them in the rhs when possible.
418 The function congruenceNewtypes takes a shot at (b)
421 -- The Type Reconstruction monad
424 runTR :: HscEnv -> TR a -> IO a
426 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
428 Nothing -> panic "Can't unify"
432 trIO = liftTcM . ioToTcRn
436 newVar :: Kind -> TR TcTyVar
437 newVar = liftTcM . newFlexiTyVar
439 -- | Returns the instantiated type scheme ty', and the substitution sigma
440 -- such that sigma(ty') = ty
441 instScheme :: Type -> TR (TcType, TvSubst)
442 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
443 (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
444 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
446 -- Adds a constraint of the form t1 == t2
447 -- t1 is expected to come from walking the heap
448 -- t2 is expected to come from a datacon signature
449 -- Before unification, congruenceNewtypes needs to
451 addConstraint :: TcType -> TcType -> TR ()
452 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
456 -- Type & Term reconstruction
457 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
458 cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
459 tv <- liftM mkTyVarTy (newVar argTypeKind)
461 Nothing -> go tv tv hval >>= zonkTerm
462 Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
464 (ty',rev_subst) <- instScheme (sigmaType ty)
466 term <- go tv tv hval >>= zonkTerm
467 --restore original Tyvars
468 return$ mapTermType (substTy rev_subst) term
471 let monomorphic = not(isTyVarTy tv)
472 -- This ^^^ is a convention. The ancestor tests for
473 -- monomorphism and passes a type instead of a tv
474 clos <- trIO $ getClosureData a
476 -- Thunks we may want to force
477 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
478 -- force blackholes, because it would almost certainly result in deadlock,
479 -- and showing the '_' is more useful.
480 t | isThunk t && force -> seq a $ go tv ty a
481 -- We always follow indirections
482 Indirection _ -> go tv ty $! (ptrs clos ! 0)
483 -- The interesting case
485 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
487 Nothing -> panic "Can't find the DataCon for a term"
489 let extra_args = length(dataConRepArgTys dc) -
490 length(dataConOrigArgTys dc)
491 subTtypes = matchSubTypes dc ty
492 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
493 subTermTvs <- sequence
494 [ if isMonomorphic t then return t
495 else (mkTyVarTy `fmap` newVar k)
496 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
497 -- It is vital for newtype reconstruction that the unification step
498 -- is done right here, _before_ the subterms are RTTI reconstructed
499 when (not monomorphic) $ do
500 let myType = mkFunTys (reOrderTerms subTermTvs
504 (signatureType,_) <- instScheme(dataConRepType dc)
505 addConstraint myType signatureType
506 subTermsP <- sequence $ drop extra_args
507 -- ^^^ all extra arguments are pointed
508 [ appArr (go tv t) (ptrs clos) i
509 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
510 let unboxeds = extractUnboxed subTtypesNP clos
511 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
512 subTerms = reOrderTerms subTermsP subTermsNP
513 (drop extra_args subTtypes)
514 return (Term tv dc a subTerms)
515 -- The otherwise case: can be a Thunk,AP,PAP,etc.
517 return (Suspension (tipe clos) (Just tv) a Nothing)
520 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
521 , isVanillaDataCon dc --TODO non-vanilla case
522 = dataConInstArgTys dc ty_args
523 -- assumes that newtypes are looked ^^^ through
524 | otherwise = dataConRepArgTys dc
526 -- This is used to put together pointed and nonpointed subterms in the
528 reOrderTerms _ _ [] = []
529 reOrderTerms pointed unpointed (ty:tys)
530 | isPointed ty = ASSERT2(not(null pointed)
531 , ptext SLIT("reOrderTerms") $$
532 (ppr pointed $$ ppr unpointed))
533 head pointed : reOrderTerms (tail pointed) unpointed tys
534 | otherwise = ASSERT2(not(null unpointed)
535 , ptext SLIT("reOrderTerms") $$
536 (ppr pointed $$ ppr unpointed))
537 head unpointed : reOrderTerms pointed (tail unpointed) tys
541 -- Fast, breadth-first Type reconstruction
543 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
544 cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
545 tv <- liftM mkTyVarTy (newVar argTypeKind)
547 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
550 zonkTcType tv -- TODO untested!
551 Just ty | isMonomorphic ty -> return ty
553 (ty',rev_subst) <- instScheme (sigmaType ty)
555 search (isMonomorphic `fmap` zonkTcType tv)
558 substTy rev_subst `fmap` zonkTcType tv
560 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
561 search stop expand [] = return ()
562 search stop expand (x:xx) = do new <- expand x
563 unlessM stop $ search stop expand (xx ++ new)
565 -- returns unification tasks,since we are going to want a breadth-first search
566 go :: Type -> HValue -> TR [(Type, HValue)]
568 clos <- trIO $ getClosureData a
570 Indirection _ -> go tv $! (ptrs clos ! 0)
572 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
574 Nothing -> panic "Can't find the DataCon for a term"
576 let extra_args = length(dataConRepArgTys dc) -
577 length(dataConOrigArgTys dc)
578 subTtypes <- mapMif (not . isMonomorphic)
579 (\t -> mkTyVarTy `fmap` newVar (typeKind t))
580 (dataConRepArgTys dc)
581 -- It is vital for newtype reconstruction that the unification step
582 -- is done right here, _before_ the subterms are RTTI reconstructed
583 let myType = mkFunTys subTtypes tv
584 (signatureType,_) <- instScheme(dataConRepType dc)
585 addConstraint myType signatureType
586 return $ map (\(I# i#,t) -> case ptrs clos of
587 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
589 (drop extra_args $ zip [0..] subTtypes)
590 otherwise -> return []
593 -- Dealing with newtypes
595 A parallel fold over two Type values,
596 compensating for missing newtypes on both sides.
597 This is necessary because newtypes are not present
598 in runtime, but since sometimes there is evidence
599 available we do our best to reconstruct them.
600 Evidence can come from DataCon signatures or
601 from compile-time type inference.
602 I am using the words congruence and rewriting
603 because what we are doing here is an approximation
604 of unification modulo a set of equations, which would
605 come from newtype definitions. These should be the
606 equality coercions seen in System Fc. Rewriting
607 is performed, taking those equations as rules,
608 before launching unification.
610 It doesn't make sense to rewrite everywhere,
611 or we would end up with all newtypes. So we rewrite
612 only in presence of evidence.
613 The lhs comes from the heap structure of ptrs,nptrs.
614 The rhs comes from a DataCon type signature.
615 Rewriting in the rhs is restricted to the result type.
617 Note that it is very tricky to make this 'rewriting'
618 work with the unification implemented by TcM, where
619 substitutions are 'inlined'. The order in which
620 constraints are unified is vital for this (or I am
623 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
624 congruenceNewtypes lhs rhs
625 -- TyVar lhs inductive case
626 | Just tv <- getTyVar_maybe lhs
627 = recoverM (return (lhs,rhs)) $ do
628 Indirect ty_v <- readMetaTyVar tv
629 (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
631 -- FunTy inductive case
632 | Just (l1,l2) <- splitFunTy_maybe lhs
633 , Just (r1,r2) <- splitFunTy_maybe rhs
634 = do (l2',r2') <- congruenceNewtypes l2 r2
635 (l1',r1') <- congruenceNewtypes l1 r1
636 return (mkFunTy l1' l2', mkFunTy r1' r2')
637 -- TyconApp Inductive case; this is the interesting bit.
638 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
639 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
641 = return (lhs, upgrade tycon_l rhs)
643 | otherwise = return (lhs,rhs)
645 where upgrade :: TyCon -> Type -> Type
647 | not (isNewTyCon new_tycon) = ty
648 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
649 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
651 -- assumes that reptype doesn't touch tyconApp args ^^^
654 --------------------------------------------------------------------------------
656 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
657 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
659 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
660 mapMif pred f xx = sequence $ mapMif_ pred f xx
661 mapMif_ pred f [] = []
662 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
664 unlessM condM acc = condM >>= \c -> unless c acc
666 -- Strict application of f at index i
667 appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
670 zonkTerm :: Term -> TcM Term
671 zonkTerm = foldTerm idTermFoldM {
672 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
673 zonkTcType ty >>= \ty' ->
674 return (Term ty' dc v tt)
675 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
676 return (Suspension ct ty v b)}
679 -- Is this defined elsewhere?
680 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
681 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty