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