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
52 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
64 import GHC.Arr ( Array(..) )
65 import GHC.Ptr ( Ptr(..), castPtr )
70 import Data.Array.Base
71 import Data.List ( partition, nub )
73 import System.IO.Unsafe
75 ---------------------------------------------
76 -- * A representation of semi evaluated Terms
77 ---------------------------------------------
79 A few examples in this representation:
81 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
83 > (('a',_,_),_,('b',_,_)) =
84 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
85 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
87 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
90 data Term = Term { ty :: Type
93 , subTerms :: [Term] }
98 | Suspension { ctype :: ClosureType
101 , bound_to :: Maybe Name -- Useful for printing
106 isSuspension Suspension{} = True
107 isSuspension _ = False
111 termType t@(Suspension {}) = mb_ty t
112 termType t = Just$ ty t
114 isFullyEvaluatedTerm :: Term -> Bool
115 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
116 isFullyEvaluatedTerm Suspension {} = False
117 isFullyEvaluatedTerm Prim {} = True
119 instance Outputable (Term) where
120 ppr = head . cPprTerm cPprTermBase
122 -------------------------------------------------------------------------
123 -- Runtime Closure Datatype and functions for retrieving closure related stuff
124 -------------------------------------------------------------------------
125 data ClosureType = Constr
136 data Closure = Closure { tipe :: ClosureType
138 , infoTable :: StgInfoTable
139 , ptrs :: Array Int HValue
143 instance Outputable ClosureType where
146 #include "../includes/ClosureTypes.h"
153 getClosureData :: a -> IO Closure
155 case unpackClosure# a of
156 (# iptr, ptrs, nptrs #) -> do
157 itbl <- peek (Ptr iptr)
158 let tipe = readCType (BCI.tipe itbl)
159 elems = BCI.ptrs itbl
160 ptrsList = Array 0 (fromIntegral$ elems) ptrs
161 nptrs_data = [W# (indexWordArray# nptrs i)
162 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
164 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
166 readCType :: Integral a => a -> ClosureType
168 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
169 | i >= FUN && i <= FUN_STATIC = Fun
170 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
171 | i == THUNK_SELECTOR = ThunkSelector
172 | i == BLACKHOLE = Blackhole
173 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
174 | fromIntegral i == aP_CODE = AP
176 | fromIntegral i == pAP_CODE = PAP
177 | otherwise = Other (fromIntegral i)
179 isConstr, isIndirection :: ClosureType -> Bool
180 isConstr Constr = True
183 isIndirection (Indirection _) = True
184 --isIndirection ThunkSelector = True
185 isIndirection _ = False
187 isThunk (Thunk _) = True
188 isThunk ThunkSelector = True
192 isFullyEvaluated :: a -> IO Bool
193 isFullyEvaluated a = do
194 closure <- getClosureData a
196 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
197 return$ and are_subs_evaluated
198 otherwise -> return False
199 where amapM f = sequence . amap' f
201 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
205 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
207 unsafeDeepSeq :: a -> b -> b
208 unsafeDeepSeq = unsafeDeepSeq1 2
209 where unsafeDeepSeq1 0 a b = seq a $! b
210 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
211 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
212 -- | unsafePerformIO (isFullyEvaluated a) = b
213 | otherwise = case unsafePerformIO (getClosureData a) of
214 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
215 where tipe = unsafePerformIO (getClosureType a)
217 isPointed :: Type -> Bool
218 isPointed t | Just (t, _) <- splitTyConApp_maybe t
219 = not$ isUnliftedTypeKind (tyConKind t)
222 extractUnboxed :: [Type] -> Closure -> [[Word]]
223 extractUnboxed tt clos = go tt (nonPtrs clos)
225 | Just (tycon,_) <- splitTyConApp_maybe t
226 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
227 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
230 | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
233 sizeofTyCon = sizeofPrimRep . tyConPrimRep
235 -----------------------------------
236 -- * Traversals for Terms
237 -----------------------------------
239 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
240 , fPrim :: Type -> [Word] -> a
241 , fSuspension :: ClosureType -> Maybe Type -> HValue
245 foldTerm :: TermFold a -> Term -> a
246 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
247 foldTerm tf (Prim ty v ) = fPrim tf ty v
248 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
250 idTermFold :: TermFold Term
251 idTermFold = TermFold {
254 fSuspension = Suspension
256 idTermFoldM :: Monad m => TermFold (m Term)
257 idTermFoldM = TermFold {
258 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
259 fPrim = (return.). Prim,
260 fSuspension = (((return.).).). Suspension
263 mapTermType f = foldTerm idTermFold {
264 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
265 fSuspension = \ct mb_ty hval n ->
266 Suspension ct (fmap f mb_ty) hval n }
268 termTyVars = foldTerm TermFold {
269 fTerm = \ty _ _ tt ->
270 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
271 fSuspension = \_ mb_ty _ _ ->
272 maybe emptyVarEnv tyVarsOfType mb_ty,
273 fPrim = \ _ _ -> emptyVarEnv }
274 where concatVarEnv = foldr plusVarEnv emptyVarEnv
275 ----------------------------------
276 -- Pretty printing of terms
277 ----------------------------------
282 pprTerm :: Int -> Term -> SDoc
283 pprTerm p Term{dc=dc, subTerms=tt}
284 {- | dataConIsInfix dc, (t1:t2:tt') <- tt
285 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
286 <+> hsep (map (pprTerm1 True) tt)
289 | otherwise = cparen (p >= app_prec)
290 (ppr dc <+> sep (map (pprTerm app_prec) tt))
292 where fixity = undefined
294 pprTerm _ t = pprTerm1 t
296 pprTerm1 Prim{value=words, ty=ty} = text$ repPrim (tyConAppTyCon ty) words
297 pprTerm1 t@Term{} = pprTerm 0 t
298 pprTerm1 Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
299 pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n}
300 | Just _ <- splitFunTy_maybe ty = ptext SLIT("<function>")
301 | otherwise = parens$ ppr n <> text "::" <> ppr ty
304 cPprTerm :: forall m. Monad m =>
305 ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
306 cPprTerm custom = go 0 where
307 go prec t@Term{subTerms=tt, dc=dc} = do
308 let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)]
309 first_success <- firstJustM mb_customDocs
310 case first_success of
311 Just doc -> return$ cparen (prec>app_prec+1) doc
312 -- | dataConIsInfix dc, (t1:t2:tt') <- tt =
313 Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
314 return$ cparen (prec >= app_prec)
315 (ppr dc <+> sep pprSubterms)
316 go _ t = return$ pprTerm1 t
317 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
318 firstJustM [] = return Nothing
320 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
323 ifTerm isTupleDC (\_ -> liftM (parens . hcat . punctuate comma)
324 . mapM (pprP (-1)) . subTerms)
325 , ifTerm (isDC consDataCon) (\ p Term{subTerms=[h,t]} -> doList p h t)
326 , ifTerm (isDC intDataCon) (coerceShow$ \(a::Int)->a)
327 , ifTerm (isDC charDataCon) (coerceShow$ \(a::Char)->a)
328 -- , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
329 , ifTerm (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
330 , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
331 , ifTerm isIntegerDC (coerceShow$ \(a::Integer)->a)
333 where ifTerm pred f p t = if pred t then liftM Just (f p t)
335 isIntegerDC Term{dc=dc} =
336 dataConName dc `elem` [ smallIntegerDataConName
337 , largeIntegerDataConName]
338 isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
339 isDC a_dc Term{dc=dc} = a_dc == dc
340 coerceShow f _ = return . text . show . f . unsafeCoerce# . val
341 --TODO pprinting of list terms is not lazy
343 let elems = h : getListTerms t
344 isConsLast = termType(last elems) /= termType h
345 print_elems <- mapM (pprP 5) elems
346 return$ if isConsLast
347 then cparen (p >= 5) . hsep . punctuate (space<>colon)
349 else brackets (hcat$ punctuate comma print_elems)
351 where Just a /= Just b = not (a `coreEqType` b)
353 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
354 getListTerms t@Term{subTerms=[]} = []
355 getListTerms t@Suspension{} = [t]
356 getListTerms t = pprPanic "getListTerms" (ppr t)
358 repPrim :: TyCon -> [Word] -> String
359 repPrim t = rep where
361 | t == charPrimTyCon = show (build x :: Char)
362 | t == intPrimTyCon = show (build x :: Int)
363 | t == wordPrimTyCon = show (build x :: Word)
364 | t == floatPrimTyCon = show (build x :: Float)
365 | t == doublePrimTyCon = show (build x :: Double)
366 | t == int32PrimTyCon = show (build x :: Int32)
367 | t == word32PrimTyCon = show (build x :: Word32)
368 | t == int64PrimTyCon = show (build x :: Int64)
369 | t == word64PrimTyCon = show (build x :: Word64)
370 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
371 | t == stablePtrPrimTyCon = "<stablePtr>"
372 | t == stableNamePrimTyCon = "<stableName>"
373 | t == statePrimTyCon = "<statethread>"
374 | t == realWorldTyCon = "<realworld>"
375 | t == threadIdPrimTyCon = "<ThreadId>"
376 | t == weakPrimTyCon = "<Weak>"
377 | t == arrayPrimTyCon = "<array>"
378 | t == byteArrayPrimTyCon = "<bytearray>"
379 | t == mutableArrayPrimTyCon = "<mutableArray>"
380 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
381 | t == mutVarPrimTyCon= "<mutVar>"
382 | t == mVarPrimTyCon = "<mVar>"
383 | t == tVarPrimTyCon = "<tVar>"
384 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
385 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
386 -- This ^^^ relies on the representation of Haskell heap values being
387 -- the same as in a C array.
389 -----------------------------------
390 -- Type Reconstruction
391 -----------------------------------
393 Type Reconstruction is type inference done on heap closures.
394 The algorithm walks the heap generating a set of equations, which
395 are solved with syntactic unification.
396 A type reconstruction equation looks like:
398 <datacon reptype> = <actual heap contents>
400 The full equation set is generated by traversing all the subterms, starting
403 The only difficult part is that newtypes are only found in the lhs of equations.
404 Right hand sides are missing them. We can either (a) drop them from the lhs, or
405 (b) reconstruct them in the rhs when possible.
407 The function congruenceNewtypes takes a shot at (b)
410 -- The Type Reconstruction monad
413 runTR :: HscEnv -> TR a -> IO a
415 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
417 Nothing -> panic "Can't unify"
421 trIO = liftTcM . ioToTcRn
425 newVar :: Kind -> TR TcTyVar
426 newVar = liftTcM . newFlexiTyVar
428 -- | Returns the instantiated type scheme ty', and the substitution sigma
429 -- such that sigma(ty') = ty
430 instScheme :: Type -> TR (TcType, TvSubst)
431 instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
432 (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
433 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
435 -- Adds a constraint of the form t1 == t2
436 -- t1 is expected to come from walking the heap
437 -- t2 is expected to come from a datacon signature
438 -- Before unification, congruenceNewtypes needs to
440 addConstraint :: TcType -> TcType -> TR ()
441 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
445 -- Type & Term reconstruction
446 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
447 cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
448 tv <- liftM mkTyVarTy (newVar argTypeKind)
450 Nothing -> go tv tv hval >>= zonkTerm
451 Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
453 (ty',rev_subst) <- instScheme (sigmaType ty)
455 term <- go tv tv hval >>= zonkTerm
456 --restore original Tyvars
457 return$ mapTermType (substTy rev_subst) term
460 let monomorphic = not(isTyVarTy tv)
461 -- This ^^^ is a convention. The ancestor tests for
462 -- monomorphism and passes a type instead of a tv
463 clos <- trIO $ getClosureData a
465 -- Thunks we may want to force
466 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
467 -- force blackholes, because it would almost certainly result in deadlock,
468 -- and showing the '_' is more useful.
469 t | isThunk t && force -> seq a $ go tv ty a
470 -- We always follow indirections
471 Indirection _ -> go tv ty $! (ptrs clos ! 0)
472 -- The interesting case
474 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
476 Nothing -> panic "Can't find the DataCon for a term"
478 let extra_args = length(dataConRepArgTys dc) -
479 length(dataConOrigArgTys dc)
480 subTtypes = matchSubTypes dc ty
481 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
482 subTermTvs <- sequence
483 [ if isMonomorphic t then return t
484 else (mkTyVarTy `fmap` newVar k)
485 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
486 -- It is vital for newtype reconstruction that the unification step
487 -- is done right here, _before_ the subterms are RTTI reconstructed
488 when (not monomorphic) $ do
489 let myType = mkFunTys (reOrderTerms subTermTvs
493 (signatureType,_) <- instScheme(dataConRepType dc)
494 addConstraint myType signatureType
495 subTermsP <- sequence $ drop extra_args
496 -- ^^^ all extra arguments are pointed
497 [ appArr (go tv t) (ptrs clos) i
498 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
499 let unboxeds = extractUnboxed subTtypesNP clos
500 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
501 subTerms = reOrderTerms subTermsP subTermsNP
502 (drop extra_args subTtypes)
503 return (Term tv dc a subTerms)
504 -- The otherwise case: can be a Thunk,AP,PAP,etc.
506 return (Suspension (tipe clos) (Just tv) a Nothing)
509 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
510 , null (dataConExTyVars dc) --TODO case of extra existential tyvars
511 = dataConInstArgTys dc ty_args
513 | otherwise = dataConRepArgTys dc
515 -- This is used to put together pointed and nonpointed subterms in the
517 reOrderTerms _ _ [] = []
518 reOrderTerms pointed unpointed (ty:tys)
519 | isPointed ty = ASSERT2(not(null pointed)
520 , ptext SLIT("reOrderTerms") $$
521 (ppr pointed $$ ppr unpointed))
522 head pointed : reOrderTerms (tail pointed) unpointed tys
523 | otherwise = ASSERT2(not(null unpointed)
524 , ptext SLIT("reOrderTerms") $$
525 (ppr pointed $$ ppr unpointed))
526 head unpointed : reOrderTerms pointed (tail unpointed) tys
530 -- Fast, breadth-first Type reconstruction
532 cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Type
533 cvReconstructType hsc_env force mb_ty hval = runTR hsc_env $ do
534 tv <- liftM mkTyVarTy (newVar argTypeKind)
536 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
539 zonkTcType tv -- TODO untested!
540 Just ty | isMonomorphic ty -> return ty
542 (ty',rev_subst) <- instScheme (sigmaType ty)
544 search (isMonomorphic `fmap` zonkTcType tv)
547 substTy rev_subst `fmap` zonkTcType tv
549 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
550 search stop expand [] = return ()
551 search stop expand (x:xx) = do new <- expand x
552 unlessM stop $ search stop expand (xx ++ new)
554 -- returns unification tasks,since we are going to want a breadth-first search
555 go :: Type -> HValue -> TR [(Type, HValue)]
557 clos <- trIO $ getClosureData a
559 Indirection _ -> go tv $! (ptrs clos ! 0)
561 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
563 Nothing -> panic "Can't find the DataCon for a term"
565 let extra_args = length(dataConRepArgTys dc) -
566 length(dataConOrigArgTys dc)
567 subTtypes <- mapMif (not . isMonomorphic)
568 (\t -> mkTyVarTy `fmap` newVar (typeKind t))
569 (dataConRepArgTys dc)
570 -- It is vital for newtype reconstruction that the unification step
571 -- is done right here, _before_ the subterms are RTTI reconstructed
572 let myType = mkFunTys subTtypes tv
573 (signatureType,_) <- instScheme(dataConRepType dc)
574 addConstraint myType signatureType
575 return $ map (\(I# i#,t) -> case ptrs clos of
576 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of
578 (drop extra_args $ zip [0..] subTtypes)
579 otherwise -> return []
582 -- Dealing with newtypes
584 A parallel fold over two Type values,
585 compensating for missing newtypes on both sides.
586 This is necessary because newtypes are not present
587 in runtime, but since sometimes there is evidence
588 available we do our best to reconstruct them.
589 Evidence can come from DataCon signatures or
590 from compile-time type inference.
591 I am using the words congruence and rewriting
592 because what we are doing here is an approximation
593 of unification modulo a set of equations, which would
594 come from newtype definitions. These should be the
595 equality coercions seen in System Fc. Rewriting
596 is performed, taking those equations as rules,
597 before launching unification.
599 It doesn't make sense to rewrite everywhere,
600 or we would end up with all newtypes. So we rewrite
601 only in presence of evidence.
602 The lhs comes from the heap structure of ptrs,nptrs.
603 The rhs comes from a DataCon type signature.
604 Rewriting in the rhs is restricted to the result type.
606 Note that it is very tricky to make this 'rewriting'
607 work with the unification implemented by TcM, where
608 substitutions are 'inlined'. The order in which
609 constraints are unified is vital for this (or I am
612 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
613 congruenceNewtypes = go True
615 go rewriteRHS lhs rhs
616 -- TyVar lhs inductive case
617 | Just tv <- getTyVar_maybe lhs
618 = recoverM (return (lhs,rhs)) $ do
619 Indirect ty_v <- readMetaTyVar tv
620 (lhs', rhs') <- go rewriteRHS ty_v rhs
621 writeMutVar (metaTvRef tv) (Indirect lhs')
623 -- TyVar rhs inductive case
624 | Just tv <- getTyVar_maybe rhs
625 = recoverM (return (lhs,rhs)) $ do
626 Indirect ty_v <- readMetaTyVar tv
627 (lhs', rhs') <- go rewriteRHS lhs ty_v
628 writeMutVar (metaTvRef tv) (Indirect rhs')
630 -- FunTy inductive case
631 | Just (l1,l2) <- splitFunTy_maybe lhs
632 , Just (r1,r2) <- splitFunTy_maybe rhs
633 = do (l2',r2') <- go True l2 r2
634 (l1',r1') <- go False l1 r1
635 return (mkFunTy l1' l2', mkFunTy r1' r2')
636 -- TyconApp Inductive case; this is the interesting bit.
637 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
638 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do
640 let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
641 then (tycon_r, rewrite tycon_r lhs)
642 else (tycon_l, args_l)
643 (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l &&
644 not(isNewTyCon tycon_r)
645 then (tycon_l, rewrite tycon_l rhs)
646 else (tycon_r, args_r)
647 (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS)
650 return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
652 | otherwise = return (lhs,rhs)
654 where rewrite newtyped_tc lame_tipe
655 | (tvs, tipe) <- newTyConRep newtyped_tc
656 = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
657 Just subst -> substTys subst (map mkTyVarTy tvs)
658 otherwise -> panic "congruenceNewtypes: Can't unify a newtype"
661 --------------------------------------------------------------------------------
663 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
664 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
666 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
667 mapMif pred f xx = sequence $ mapMif_ pred f xx
668 mapMif_ pred f [] = []
669 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
671 unlessM condM acc = condM >>= \c -> unless c acc
673 -- Strict application of f at index i
674 appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
677 zonkTerm :: Term -> TcM Term
678 zonkTerm = foldTerm idTermFoldM {
679 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
680 zonkTcType ty >>= \ty' ->
681 return (Term ty' dc v tt)
682 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
683 return (Suspension ct ty v b)}
686 -- Is this defined elsewhere?
687 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
688 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty