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