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