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