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