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