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