Add a max depth bound to the bfs implementation in cvReconstructType,
[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 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 Term{} = True
107 isTerm _ = False
108 isSuspension Suspension{} = True
109 isSuspension _ = False
110 isPrim Prim{} = True
111 isPrim _ = False
112
113 termType t@(Suspension {}) = mb_ty t
114 termType t = Just$ ty t
115
116 isFullyEvaluatedTerm :: Term -> Bool
117 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
118 isFullyEvaluatedTerm Suspension {} = False
119 isFullyEvaluatedTerm Prim {} = True
120
121 instance Outputable (Term) where
122 ppr = head . cPprTerm cPprTermBase
123
124 -------------------------------------------------------------------------
125 -- Runtime Closure Datatype and functions for retrieving closure related stuff
126 -------------------------------------------------------------------------
127 data ClosureType = Constr
128 | Fun
129 | Thunk Int
130 | ThunkSelector
131 | Blackhole
132 | AP
133 | PAP
134 | Indirection Int
135 | Other Int
136 deriving (Show, Eq)
137
138 data Closure = Closure { tipe :: ClosureType
139 , infoPtr :: Ptr ()
140 , infoTable :: StgInfoTable
141 , ptrs :: Array Int HValue
142 , nonPtrs :: [Word]
143 }
144
145 instance Outputable ClosureType where
146 ppr = text . show
147
148 #include "../includes/ClosureTypes.h"
149
150 aP_CODE = AP
151 pAP_CODE = PAP
152 #undef AP
153 #undef PAP
154
155 getClosureData :: a -> IO Closure
156 getClosureData a =
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)] ]
165 ptrsList `seq`
166 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
167
168 readCType :: Integral a => a -> ClosureType
169 readCType i
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
177 | i == AP_STACK = AP
178 | fromIntegral i == pAP_CODE = PAP
179 | otherwise = Other (fromIntegral i)
180
181 isConstr, isIndirection :: ClosureType -> Bool
182 isConstr Constr = True
183 isConstr _ = False
184
185 isIndirection (Indirection _) = True
186 --isIndirection ThunkSelector = True
187 isIndirection _ = False
188
189 isThunk (Thunk _) = True
190 isThunk ThunkSelector = True
191 isThunk AP = True
192 isThunk _ = False
193
194 isFullyEvaluated :: a -> IO Bool
195 isFullyEvaluated a = do
196 closure <- getClosureData a
197 case tipe closure of
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
202
203 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
204 (# e #) -> f e)
205 [0 .. i - i0]
206
207 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
208 {-
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)
218 -}
219 isPointed :: Type -> Bool
220 isPointed t | Just (t, _) <- splitTyConApp_maybe t
221 = not$ isUnliftedTypeKind (tyConKind t)
222 isPointed _ = True
223
224 extractUnboxed :: [Type] -> Closure -> [[Word]]
225 extractUnboxed tt clos = go tt (nonPtrs clos)
226 where sizeofType t
227 | Just (tycon,_) <- splitTyConApp_maybe t
228 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
229 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
230 go [] _ = []
231 go (t:tt) xx
232 | (x, rest) <- splitAt (sizeofType t `div` wORD_SIZE) xx
233 = x : go tt rest
234
235 sizeofTyCon = sizeofPrimRep . tyConPrimRep
236
237 -----------------------------------
238 -- * Traversals for Terms
239 -----------------------------------
240
241 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
242 , fPrim :: Type -> [Word] -> a
243 , fSuspension :: ClosureType -> Maybe Type -> HValue
244 -> Maybe Name -> a
245 }
246
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
251
252 idTermFold :: TermFold Term
253 idTermFold = TermFold {
254 fTerm = Term,
255 fPrim = Prim,
256 fSuspension = Suspension
257 }
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
263 }
264
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 }
269
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 ----------------------------------
280
281 app_prec,cons_prec ::Int
282 app_prec = 10
283 cons_prec = 5 -- TODO Extract this info from GHC itself
284
285 pprTerm y p t | Just doc <- pprTermM y p t = doc
286
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)
292 -}
293 | null tt = return$ ppr dc
294 | Just (tc,_) <- splitNewTyConApp_maybe ty
295 , isNewTyCon tc
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)
299 | otherwise = do
300 tt_docs <- mapM (y app_prec) tt
301 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
302
303 pprTermM y _ t = pprTermM1 y t
304
305 pprTermM1 _ Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty)
306 words
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
312
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
326
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)]
329 cPprTermBase y =
330 [
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)
341 ]
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
349 = a_tc == tc
350 coerceShow f _ = return . text . show . f . unsafeCoerce# . val
351 --TODO pprinting of list terms is not lazy
352 doList p h t = do
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)
358 $ print_elems
359 else brackets (hcat$ punctuate comma print_elems)
360
361 where Just a /= Just b = not (a `coreEqType` b)
362 _ /= _ = True
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)
367
368
369 repPrim :: TyCon -> [Word] -> String
370 repPrim t = rep where
371 rep x
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.
399
400 -----------------------------------
401 -- Type Reconstruction
402 -----------------------------------
403 {-
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:
408
409 <datacon reptype> = <actual heap contents>
410
411 The full equation set is generated by traversing all the subterms, starting
412 from a given term.
413
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.
417
418 The function congruenceNewtypes takes a shot at (b)
419 -}
420
421 -- The Type Reconstruction monad
422 type TR a = TcM a
423
424 runTR :: HscEnv -> TR a -> IO a
425 runTR hsc_env c = do
426 mb_term <- initTcPrintErrors hsc_env iNTERACTIVE c
427 case mb_term of
428 Nothing -> panic "Can't unify"
429 Just x -> return x
430
431 trIO :: IO a -> TR a
432 trIO = liftTcM . ioToTcRn
433
434 liftTcM = id
435
436 newVar :: Kind -> TR TcTyVar
437 newVar = liftTcM . newFlexiTyVar
438
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))
445
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
450 -- do its magic.
451 addConstraint :: TcType -> TcType -> TR ()
452 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
453
454
455
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)
460 case mb_ty of
461 Nothing -> go tv tv hval >>= zonkTerm
462 Just ty | isMonomorphic ty -> go ty ty hval >>= zonkTerm
463 Just ty -> do
464 (ty',rev_subst) <- instScheme (sigmaType ty)
465 addConstraint tv ty'
466 term <- go tv tv hval >>= zonkTerm
467 --restore original Tyvars
468 return$ mapTermType (substTy rev_subst) term
469 where
470 go tv ty a = do
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
475 case tipe clos of
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
484 Constr -> do
485 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
486 case m_dc of
487 Nothing -> panic "Can't find the DataCon for a term"
488 Just dc -> do
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
501 subTtypesNP
502 subTtypes)
503 tv
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.
516 otherwise ->
517 return (Suspension (tipe clos) (Just tv) a Nothing)
518
519 matchSubTypes dc ty
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
525
526 -- This is used to put together pointed and nonpointed subterms in the
527 -- correct order.
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
538
539
540
541 -- Fast, breadth-first Type reconstruction
542 max_depth = 10 :: Int
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)
546 case mb_ty of
547 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
548 (uncurry go)
549 [(tv, hval)]
550 max_depth
551 zonkTcType tv -- TODO untested!
552 Just ty | isMonomorphic ty -> return ty
553 Just ty -> do
554 (ty',rev_subst) <- instScheme (sigmaType ty)
555 addConstraint tv ty'
556 search (isMonomorphic `fmap` zonkTcType tv)
557 (uncurry go)
558 [(tv, hval)]
559 max_depth
560 substTy rev_subst `fmap` zonkTcType tv
561 where
562 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
563 search stop expand [] depth = return ()
564 search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
565 show max_depth ++ " steps"
566 search stop expand (x:xx) d = do
567 new <- expand x
568 unlessM stop $ search stop expand (xx ++ new) $! (pred d)
569
570 -- returns unification tasks,since we are going to want a breadth-first search
571 go :: Type -> HValue -> TR [(Type, HValue)]
572 go tv a = do
573 clos <- trIO $ getClosureData a
574 case tipe clos of
575 Indirection _ -> go tv $! (ptrs clos ! 0)
576 Constr -> do
577 m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
578 case m_dc of
579 Nothing -> panic "Can't find the DataCon for a term"
580 Just dc -> do
581 let extra_args = length(dataConRepArgTys dc) -
582 length(dataConOrigArgTys dc)
583 subTtypes <- mapMif (not . isMonomorphic)
584 (\t -> mkTyVarTy `fmap` newVar (typeKind t))
585 (dataConRepArgTys dc)
586 -- It is vital for newtype reconstruction that the unification step
587 -- is done right here, _before_ the subterms are RTTI reconstructed
588 let myType = mkFunTys subTtypes tv
589 (signatureType,_) <- instScheme(dataConRepType dc)
590 addConstraint myType signatureType
591 return $ [ appArr (\e->(t,e)) (ptrs clos) i
592 | (i,t) <- drop extra_args $ zip [0..] subTtypes]
593 otherwise -> return []
594
595
596 -- Dealing with newtypes
597 {-
598 A parallel fold over two Type values,
599 compensating for missing newtypes on both sides.
600 This is necessary because newtypes are not present
601 in runtime, but since sometimes there is evidence
602 available we do our best to reconstruct them.
603 Evidence can come from DataCon signatures or
604 from compile-time type inference.
605 I am using the words congruence and rewriting
606 because what we are doing here is an approximation
607 of unification modulo a set of equations, which would
608 come from newtype definitions. These should be the
609 equality coercions seen in System Fc. Rewriting
610 is performed, taking those equations as rules,
611 before launching unification.
612
613 It doesn't make sense to rewrite everywhere,
614 or we would end up with all newtypes. So we rewrite
615 only in presence of evidence.
616 The lhs comes from the heap structure of ptrs,nptrs.
617 The rhs comes from a DataCon type signature.
618 Rewriting in the rhs is restricted to the result type.
619
620 Note that it is very tricky to make this 'rewriting'
621 work with the unification implemented by TcM, where
622 substitutions are 'inlined'. The order in which
623 constraints are unified is vital for this (or I am
624 using TcM wrongly).
625 -}
626 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
627 congruenceNewtypes lhs rhs
628 -- TyVar lhs inductive case
629 | Just tv <- getTyVar_maybe lhs
630 = recoverM (return (lhs,rhs)) $ do
631 Indirect ty_v <- readMetaTyVar tv
632 (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
633 return (lhs, rhs1)
634 -- FunTy inductive case
635 | Just (l1,l2) <- splitFunTy_maybe lhs
636 , Just (r1,r2) <- splitFunTy_maybe rhs
637 = do (l2',r2') <- congruenceNewtypes l2 r2
638 (l1',r1') <- congruenceNewtypes l1 r1
639 return (mkFunTy l1' l2', mkFunTy r1' r2')
640 -- TyconApp Inductive case; this is the interesting bit.
641 | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
642 , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs
643 , tycon_l /= tycon_r
644 = return (lhs, upgrade tycon_l rhs)
645
646 | otherwise = return (lhs,rhs)
647
648 where upgrade :: TyCon -> Type -> Type
649 upgrade new_tycon ty
650 | not (isNewTyCon new_tycon) = ty
651 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
652 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
653 = substTy subst ty'
654 -- assumes that reptype doesn't touch tyconApp args ^^^
655
656
657 --------------------------------------------------------------------------------
658
659 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
660 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
661
662 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
663 mapMif pred f xx = sequence $ mapMif_ pred f xx
664 mapMif_ pred f [] = []
665 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
666
667 unlessM condM acc = condM >>= \c -> unless c acc
668
669 -- Strict application of f at index i
670 appArr f (Array _ _ ptrs#) (I# i#) = case indexArray# ptrs# i# of
671 (# e #) -> f e
672
673 zonkTerm :: Term -> TcM Term
674 zonkTerm = foldTerm idTermFoldM {
675 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
676 zonkTcType ty >>= \ty' ->
677 return (Term ty' dc v tt)
678 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
679 return (Suspension ct ty v b)}
680
681
682 -- Is this defined elsewhere?
683 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
684 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
685
686