Clean up for code conventions & add some comment
[ghc.git] / compiler / ghci / RtClosureInspect.hs
1 -----------------------------------------------------------------------------
2 --
3 -- GHC Interactive support for inspecting arbitrary closures at runtime
4 --
5 -- Pepe Iborra (supported by Google SoC) 2006
6 --
7 -----------------------------------------------------------------------------
8
9 module RtClosureInspect(
10
11 cvObtainTerm, -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
12
13 Term(..),
14 pprTerm,
15 cPprTerm,
16 cPprTermBase,
17 termType,
18 foldTerm,
19 TermFold(..),
20 idTermFold,
21 idTermFoldM,
22 isFullyEvaluated,
23 isPointed,
24 isFullyEvaluatedTerm,
25 mapTermType,
26 termTyVars,
27 -- unsafeDeepSeq,
28 cvReconstructType
29 ) where
30
31 #include "HsVersions.h"
32
33 import ByteCodeItbls ( StgInfoTable )
34 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
35 import ByteCodeLink ( HValue )
36 import HscTypes ( HscEnv )
37
38 import DataCon
39 import Type
40 import TcRnMonad ( TcM, initTcPrintErrors, ioToTcRn, recoverM
41 , writeMutVar )
42 import TcType
43 import TcMType
44 import TcUnify
45 import TcGadt
46 import TyCon
47 import Var
48 import Name
49 import VarEnv
50 import OccName
51 import VarSet
52 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
53
54 import TysPrim
55 import PrelNames
56 import TysWiredIn
57
58 import Constants
59 import Outputable
60 import Maybes
61 import Panic
62 import FiniteMap
63
64 import GHC.Arr ( Array(..) )
65 import GHC.Ptr ( Ptr(..), castPtr )
66 import GHC.Exts
67
68 import Control.Monad
69 import Data.Maybe
70 import Data.Array.Base
71 import Data.List ( partition, nub )
72 import Foreign
73 import System.IO.Unsafe
74
75 ---------------------------------------------
76 -- * A representation of semi evaluated Terms
77 ---------------------------------------------
78 {-
79 A few examples in this representation:
80
81 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
82
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]
86 , Suspension
87 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
88 -}
89
90 data Term = Term { ty :: Type
91 , dc :: DataCon
92 , val :: HValue
93 , subTerms :: [Term] }
94
95 | Prim { ty :: Type
96 , value :: [Word] }
97
98 | Suspension { ctype :: ClosureType
99 , mb_ty :: Maybe Type
100 , val :: HValue
101 , bound_to :: Maybe Name -- Useful for printing
102 }
103
104 isTerm Term{} = True
105 isTerm _ = False
106 isSuspension Suspension{} = True
107 isSuspension _ = False
108 isPrim Prim{} = True
109 isPrim _ = False
110
111 termType t@(Suspension {}) = mb_ty t
112 termType t = Just$ ty t
113
114 isFullyEvaluatedTerm :: Term -> Bool
115 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
116 isFullyEvaluatedTerm Suspension {} = False
117 isFullyEvaluatedTerm Prim {} = True
118
119 instance Outputable (Term) where
120 ppr = head . cPprTerm cPprTermBase
121
122 -------------------------------------------------------------------------
123 -- Runtime Closure Datatype and functions for retrieving closure related stuff
124 -------------------------------------------------------------------------
125 data ClosureType = Constr
126 | Fun
127 | Thunk Int
128 | ThunkSelector
129 | Blackhole
130 | AP
131 | PAP
132 | Indirection Int
133 | Other Int
134 deriving (Show, Eq)
135
136 data Closure = Closure { tipe :: ClosureType
137 , infoPtr :: Ptr ()
138 , infoTable :: StgInfoTable
139 , ptrs :: Array Int HValue
140 , nonPtrs :: [Word]
141 }
142
143 instance Outputable ClosureType where
144 ppr = text . show
145
146 #include "../includes/ClosureTypes.h"
147
148 aP_CODE = AP
149 pAP_CODE = PAP
150 #undef AP
151 #undef PAP
152
153 getClosureData :: a -> IO Closure
154 getClosureData a =
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)] ]
163 ptrsList `seq`
164 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
165
166 readCType :: Integral a => a -> ClosureType
167 readCType i
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
175 | i == AP_STACK = AP
176 | fromIntegral i == pAP_CODE = PAP
177 | otherwise = Other (fromIntegral i)
178
179 isConstr, isIndirection :: ClosureType -> Bool
180 isConstr Constr = True
181 isConstr _ = False
182
183 isIndirection (Indirection _) = True
184 --isIndirection ThunkSelector = True
185 isIndirection _ = False
186
187 isThunk (Thunk _) = True
188 isThunk ThunkSelector = True
189 isThunk AP = True
190 isThunk _ = False
191
192 isFullyEvaluated :: a -> IO Bool
193 isFullyEvaluated a = do
194 closure <- getClosureData a
195 case tipe closure of
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
200
201 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
202 (# e #) -> f e)
203 [0 .. i - i0]
204
205 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
206 {-
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)
216 -}
217 isPointed :: Type -> Bool
218 isPointed t | Just (t, _) <- splitTyConApp_maybe t
219 = not$ isUnliftedTypeKind (tyConKind t)
220 isPointed _ = True
221
222 extractUnboxed :: [Type] -> Closure -> [[Word]]
223 extractUnboxed tt clos = go tt (nonPtrs clos)
224 where sizeofType t
225 | Just (tycon,_) <- splitTyConApp_maybe t
226 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
227 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
228 go [] _ = []
229 go (t:tt) xx
230 | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
231 = x : go tt rest
232
233 sizeofTyCon = sizeofPrimRep . tyConPrimRep
234
235 -----------------------------------
236 -- * Traversals for Terms
237 -----------------------------------
238
239 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
240 , fPrim :: Type -> [Word] -> a
241 , fSuspension :: ClosureType -> Maybe Type -> HValue
242 -> Maybe Name -> a
243 }
244
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
249
250 idTermFold :: TermFold Term
251 idTermFold = TermFold {
252 fTerm = Term,
253 fPrim = Prim,
254 fSuspension = Suspension
255 }
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
261 }
262
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 }
267
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 ----------------------------------
278
279 app_prec::Int
280 app_prec = 10
281
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)
287 -}
288 | null tt = ppr dc
289 | otherwise = cparen (p >= app_prec)
290 (ppr dc <+> sep (map (pprTerm app_prec) tt))
291
292 where fixity = undefined
293
294 pprTerm _ t = pprTerm1 t
295
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
302
303
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
319
320 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
321 cPprTermBase pprP =
322 [
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)
332 ]
333 where ifTerm pred f p t = if pred t then liftM Just (f p t)
334 else return Nothing
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
342 doList p h t = do
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)
348 $ print_elems
349 else brackets (hcat$ punctuate comma print_elems)
350
351 where Just a /= Just b = not (a `coreEqType` b)
352 _ /= _ = True
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)
357
358 repPrim :: TyCon -> [Word] -> String
359 repPrim t = rep where
360 rep x
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.
388
389 -----------------------------------
390 -- Type Reconstruction
391 -----------------------------------
392 {-
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:
397
398 <datacon reptype> = <actual heap contents>
399
400 The full equation set is generated by traversing all the subterms, starting
401 from a given term.
402
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.
406
407 The function congruenceNewtypes takes a shot at (b)
408 -}
409
410 -- The Type Reconstruction monad
411 type TR a = TcM a
412
413 runTR :: HscEnv -> TR a -> IO a
414 runTR hsc_env c = do
415 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
416 case mb_term of
417 Nothing -> panic "Can't unify"
418 Just x -> return x
419
420 trIO :: IO a -> TR a
421 trIO = liftTcM . ioToTcRn
422
423 liftTcM = id
424
425 newVar :: Kind -> TR TcTyVar
426 newVar = liftTcM . newFlexiTyVar
427
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))
434
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
439 -- do its magic.
440 addConstraint :: TcType -> TcType -> TR ()
441 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
442
443
444
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)
449 case mb_ty of
450 Nothing -> go tv tv hval >>= zonkTerm
451 Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
452 Just ty -> do
453 (ty',rev_subst) <- instScheme (sigmaType ty)
454 addConstraint tv ty'
455 term <- go tv tv hval >>= zonkTerm
456 --restore original Tyvars
457 return$ mapTermType (substTy rev_subst) term
458 where
459 go tv ty a = do
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
464 case tipe clos of
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
473 Constr -> do
474 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
475 case m_dc of
476 Nothing -> panic "Can't find the DataCon for a term"
477 Just dc -> do
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
490 subTtypesNP
491 subTtypes)
492 tv
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.
505 otherwise ->
506 return (Suspension (tipe clos) (Just tv) a Nothing)
507
508 matchSubTypes dc ty
509 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
510 , null (dataConExTyVars dc) --TODO case of extra existential tyvars
511 = dataConInstArgTys dc ty_args
512
513 | otherwise = dataConRepArgTys dc
514
515 -- This is used to put together pointed and nonpointed subterms in the
516 -- correct order.
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
527
528
529
530 -- Fast, breadth-first Type reconstruction
531
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)
535 case mb_ty of
536 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
537 (uncurry go)
538 [(tv, hval)]
539 zonkTcType tv -- TODO untested!
540 Just ty | isMonomorphic ty -> return ty
541 Just ty -> do
542 (ty',rev_subst) <- instScheme (sigmaType ty)
543 addConstraint tv ty'
544 search (isMonomorphic `fmap` zonkTcType tv)
545 (uncurry go)
546 [(tv, hval)]
547 substTy rev_subst `fmap` zonkTcType tv
548 where
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)
553
554 -- returns unification tasks,since we are going to want a breadth-first search
555 go :: Type -> HValue -> TR [(Type, HValue)]
556 go tv a = do
557 clos <- trIO $ getClosureData a
558 case tipe clos of
559 Indirection _ -> go tv $! (ptrs clos ! 0)
560 Constr -> do
561 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
562 case m_dc of
563 Nothing -> panic "Can't find the DataCon for a term"
564 Just dc -> do
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
577 (# e #) -> (t,e))
578 (drop extra_args $ zip [0..] subTtypes)
579 otherwise -> return []
580
581
582 -- Dealing with newtypes
583 {-
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.
598
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.
605
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
610 using TcM wrongly).
611 -}
612 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
613 congruenceNewtypes = go True
614 where
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')
622 return (lhs, rhs')
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')
629 return (lhs', 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
639
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)
648 args_l'
649 args_r'
650 return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'')
651
652 | otherwise = return (lhs,rhs)
653
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"
659
660
661 --------------------------------------------------------------------------------
662
663 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
664 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
665
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
670
671 unlessM condM acc = condM >>= \c -> unless c acc
672
673 -- Strict application of f at index i
674 appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
675 (# e #) -> f e
676
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)}
684
685
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
689
690