Teach :print to follow references (STRefs and IORefs)
[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} = braces `liftM` y p t
373 ppr_termM _ _ t = ppr_termM1 t
374
375
376 ppr_termM1 :: Monad m => Term -> m SDoc
377 ppr_termM1 Prim{value=words, ty=ty} =
378 return$ text$ repPrim (tyConAppTyCon ty) words
379 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
380 ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
381 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
382 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
383 ppr_termM1 Suspension{} = panic "ppr_termM1 - Suspension"
384 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
385 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
386 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
387
388 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
389 | Just (tc,_) <- splitNewTyConApp_maybe ty
390 , ASSERT(isNewTyCon tc) True
391 , Just new_dc <- maybeTyConSingleCon tc = do
392 real_term <- y max_prec t
393 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
394 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
395
396 -------------------------------------------------------
397 -- Custom Term Pretty Printers
398 -------------------------------------------------------
399
400 -- We can want to customize the representation of a
401 -- term depending on its type.
402 -- However, note that custom printers have to work with
403 -- type representations, instead of directly with types.
404 -- We cannot use type classes here, unless we employ some
405 -- typerep trickery (e.g. Weirich's RepLib tricks),
406 -- which I didn't. Therefore, this code replicates a lot
407 -- of what type classes provide for free.
408
409 type CustomTermPrinter m = TermPrinterM m
410 -> [Precedence -> Term -> (m (Maybe SDoc))]
411
412 -- | Takes a list of custom printers with a explicit recursion knot and a term,
413 -- and returns the output of the first succesful printer, or the default printer
414 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
415 cPprTerm printers_ = go 0 where
416 printers = printers_ go
417 go prec t = do
418 let default_ = Just `liftM` pprTermM go prec t
419 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
420 Just doc <- firstJustM mb_customDocs
421 return$ cparen (prec>app_prec+1) doc
422
423 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
424 firstJustM [] = return Nothing
425
426 -- Default set of custom printers. Note that the recursion knot is explicit
427 cPprTermBase :: Monad m => CustomTermPrinter m
428 cPprTermBase y =
429 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
430 . mapM (y (-1))
431 . subTerms)
432 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
433 (\ p Term{subTerms=[h,t]} -> doList p h t)
434 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
435 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
436 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
437 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
438 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
439 ]
440 where ifTerm pred f prec t@Term{}
441 | pred t = Just `liftM` f prec t
442 ifTerm _ _ _ _ = return Nothing
443
444 isIntegerTy ty = fromMaybe False $ do
445 (tc,_) <- splitTyConApp_maybe ty
446 return (tyConName tc == integerTyConName)
447
448 isTupleTy ty = fromMaybe False $ do
449 (tc,_) <- splitTyConApp_maybe ty
450 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
451
452 isTyCon a_tc ty = fromMaybe False $ do
453 (tc,_) <- splitTyConApp_maybe ty
454 return (a_tc == tc)
455
456 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
457
458 --Note pprinting of list terms is not lazy
459 doList p h t = do
460 let elems = h : getListTerms t
461 isConsLast = termType(last elems) /= termType h
462 print_elems <- mapM (y cons_prec) elems
463 return$ if isConsLast
464 then cparen (p >= cons_prec)
465 . pprDeeperList fsep
466 . punctuate (space<>colon)
467 $ print_elems
468 else brackets (pprDeeperList fcat$
469 punctuate comma print_elems)
470
471 where Just a /= Just b = not (a `coreEqType` b)
472 _ /= _ = True
473 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
474 getListTerms Term{subTerms=[]} = []
475 getListTerms t@Suspension{} = [t]
476 getListTerms t = pprPanic "getListTerms" (ppr t)
477
478
479 repPrim :: TyCon -> [Word] -> String
480 repPrim t = rep where
481 rep x
482 | t == charPrimTyCon = show (build x :: Char)
483 | t == intPrimTyCon = show (build x :: Int)
484 | t == wordPrimTyCon = show (build x :: Word)
485 | t == floatPrimTyCon = show (build x :: Float)
486 | t == doublePrimTyCon = show (build x :: Double)
487 | t == int32PrimTyCon = show (build x :: Int32)
488 | t == word32PrimTyCon = show (build x :: Word32)
489 | t == int64PrimTyCon = show (build x :: Int64)
490 | t == word64PrimTyCon = show (build x :: Word64)
491 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
492 | t == stablePtrPrimTyCon = "<stablePtr>"
493 | t == stableNamePrimTyCon = "<stableName>"
494 | t == statePrimTyCon = "<statethread>"
495 | t == realWorldTyCon = "<realworld>"
496 | t == threadIdPrimTyCon = "<ThreadId>"
497 | t == weakPrimTyCon = "<Weak>"
498 | t == arrayPrimTyCon = "<array>"
499 | t == byteArrayPrimTyCon = "<bytearray>"
500 | t == mutableArrayPrimTyCon = "<mutableArray>"
501 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
502 | t == mutVarPrimTyCon= "<mutVar>"
503 | t == mVarPrimTyCon = "<mVar>"
504 | t == tVarPrimTyCon = "<tVar>"
505 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
506 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
507 -- This ^^^ relies on the representation of Haskell heap values being
508 -- the same as in a C array.
509
510 -----------------------------------
511 -- Type Reconstruction
512 -----------------------------------
513 {-
514 Type Reconstruction is type inference done on heap closures.
515 The algorithm walks the heap generating a set of equations, which
516 are solved with syntactic unification.
517 A type reconstruction equation looks like:
518
519 <datacon reptype> = <actual heap contents>
520
521 The full equation set is generated by traversing all the subterms, starting
522 from a given term.
523
524 The only difficult part is that newtypes are only found in the lhs of equations.
525 Right hand sides are missing them. We can either (a) drop them from the lhs, or
526 (b) reconstruct them in the rhs when possible.
527
528 The function congruenceNewtypes takes a shot at (b)
529 -}
530
531 -- The Type Reconstruction monad
532 type TR a = TcM a
533
534 runTR :: HscEnv -> TR a -> IO a
535 runTR hsc_env c = do
536 mb_term <- runTR_maybe hsc_env c
537 case mb_term of
538 Nothing -> panic "Can't unify"
539 Just x -> return x
540
541 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
542 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
543
544 traceTR :: SDoc -> TR ()
545 traceTR = liftTcM . traceTc
546
547 trIO :: IO a -> TR a
548 trIO = liftTcM . ioToTcRn
549
550 liftTcM :: TcM a -> TR a
551 liftTcM = id
552
553 newVar :: Kind -> TR TcType
554 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
555
556 -- | Returns the instantiated type scheme ty', and the substitution sigma
557 -- such that sigma(ty') = ty
558 instScheme :: Type -> TR (TcType, TvSubst)
559 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
560 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
561 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
562
563 -- Adds a constraint of the form t1 == t2
564 -- t1 is expected to come from walking the heap
565 -- t2 is expected to come from a datacon signature
566 -- Before unification, congruenceNewtypes needs to
567 -- do its magic.
568 addConstraint :: TcType -> TcType -> TR ()
569 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
570 >> return () -- TOMDO: what about the coercion?
571 -- we should consider family instances
572
573 -- Type & Term reconstruction
574 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
575 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
576 tv <- newVar argTypeKind
577 case mb_ty of
578 Nothing -> go bound tv tv hval
579 >>= zonkTerm
580 >>= return . expandNewtypes
581 Just ty | isMonomorphic ty -> go bound ty ty hval
582 >>= zonkTerm
583 >>= return . expandNewtypes
584 Just ty -> do
585 (ty',rev_subst) <- instScheme (sigmaType ty)
586 addConstraint tv ty'
587 term <- go bound tv tv hval >>= zonkTerm
588 --restore original Tyvars
589 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
590 where
591 go bound _ _ _ | seq bound False = undefined
592 go 0 tv _ty a = do
593 clos <- trIO $ getClosureData a
594 return (Suspension (tipe clos) (Just tv) a Nothing)
595 go bound tv ty a = do
596 let monomorphic = not(isTyVarTy tv)
597 -- This ^^^ is a convention. The ancestor tests for
598 -- monomorphism and passes a type instead of a tv
599 clos <- trIO $ getClosureData a
600 case tipe clos of
601 -- Thunks we may want to force
602 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
603 -- force blackholes, because it would almost certainly result in deadlock,
604 -- and showing the '_' is more useful.
605 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
606 -- We always follow indirections
607 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
608 -- We also follow references
609 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
610 -- , tycon == mutVarPrimTyCon
611 -> do
612 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
613 tv' <- newVar liftedTypeKind
614 addConstraint tv (mkTyConApp tycon [world,tv'])
615 x <- go bound tv' ty_contents contents
616 return (RefWrap ty x)
617
618 -- The interesting case
619 Constr -> do
620 Right dcname <- dataConInfoPtrToName (infoPtr clos)
621 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
622 case mb_dc of
623 Nothing -> do -- This can happen for private constructors compiled -O0
624 -- where the .hi descriptor does not export them
625 -- In such case, we return a best approximation:
626 -- ignore the unpointed args, and recover the pointeds
627 -- This preserves laziness, and should be safe.
628 let tag = showSDoc (ppr dcname)
629 vars <- replicateM (length$ elems$ ptrs clos)
630 (newVar (liftedTypeKind))
631 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
632 | (i, tv) <- zip [0..] vars]
633 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
634 Just dc -> do
635 let extra_args = length(dataConRepArgTys dc) -
636 length(dataConOrigArgTys dc)
637 subTtypes = matchSubTypes dc ty
638 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
639 subTermTvs <- sequence
640 [ if isMonomorphic t then return t
641 else (newVar k)
642 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
643 -- It is vital for newtype reconstruction that the unification step
644 -- is done right here, _before_ the subterms are RTTI reconstructed
645 when (not monomorphic) $ do
646 let myType = mkFunTys (reOrderTerms subTermTvs
647 subTtypesNP
648 subTtypes)
649 tv
650 (signatureType,_) <- instScheme(dataConRepType dc)
651 addConstraint myType signatureType
652 subTermsP <- sequence $ drop extra_args
653 -- ^^^ all extra arguments are pointed
654 [ appArr (go (pred bound) tv t) (ptrs clos) i
655 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
656 let unboxeds = extractUnboxed subTtypesNP clos
657 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
658 subTerms = reOrderTerms subTermsP subTermsNP
659 (drop extra_args subTtypes)
660 return (Term tv (Right dc) a subTerms)
661 -- The otherwise case: can be a Thunk,AP,PAP,etc.
662 tipe_clos ->
663 return (Suspension tipe_clos (Just tv) a Nothing)
664
665 matchSubTypes dc ty
666 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
667 -- assumption: ^^^ looks through newtypes
668 , isVanillaDataCon dc --TODO non-vanilla case
669 = dataConInstArgTys dc ty_args
670 | otherwise = dataConRepArgTys dc
671
672 -- This is used to put together pointed and nonpointed subterms in the
673 -- correct order.
674 reOrderTerms _ _ [] = []
675 reOrderTerms pointed unpointed (ty:tys)
676 | isPointed ty = ASSERT2(not(null pointed)
677 , ptext SLIT("reOrderTerms") $$
678 (ppr pointed $$ ppr unpointed))
679 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
680 | otherwise = ASSERT2(not(null unpointed)
681 , ptext SLIT("reOrderTerms") $$
682 (ppr pointed $$ ppr unpointed))
683 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
684
685 expandNewtypes t@Term{ ty=ty, subTerms=tt }
686 | Just (tc, args) <- splitNewTyConApp_maybe ty
687 , isNewTyCon tc
688 , wrapped_type <- newTyConInstRhs tc args
689 , Just dc <- maybeTyConSingleCon tc
690 , t' <- expandNewtypes t{ ty = wrapped_type
691 , subTerms = map expandNewtypes tt }
692 = NewtypeWrap ty (Right dc) t'
693
694 | otherwise = t{ subTerms = map expandNewtypes tt }
695
696 expandNewtypes t = t
697
698
699 -- Fast, breadth-first Type reconstruction
700 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
701 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
702 tv <- newVar argTypeKind
703 case mb_ty of
704 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
705 (uncurry go)
706 (Seq.singleton (tv, hval))
707 max_depth
708 zonkTcType tv -- TODO untested!
709 Just ty | isMonomorphic ty -> return ty
710 Just ty -> do
711 (ty',rev_subst) <- instScheme (sigmaType ty)
712 addConstraint tv ty'
713 search (isMonomorphic `fmap` zonkTcType tv)
714 (\(ty,a) -> go ty a)
715 (Seq.singleton (tv, hval))
716 max_depth
717 substTy rev_subst `fmap` zonkTcType tv
718 where
719 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
720 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
721 int max_depth <> text " steps")
722 search stop expand l d =
723 case viewl l of
724 EmptyL -> return ()
725 x :< xx -> unlessM stop $ do
726 new <- expand x
727 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
728
729 -- returns unification tasks,since we are going to want a breadth-first search
730 go :: Type -> HValue -> TR [(Type, HValue)]
731 go tv a = do
732 clos <- trIO $ getClosureData a
733 case tipe clos of
734 Indirection _ -> go tv $! (ptrs clos ! 0)
735 MutVar _ -> do
736 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
737 tv' <- newVar liftedTypeKind
738 world <- newVar liftedTypeKind
739 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
740 -- x <- go tv' ty_contents contents
741 return [(tv', contents)]
742 Constr -> do
743 Right dcname <- dataConInfoPtrToName (infoPtr clos)
744 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
745 case mb_dc of
746 Nothing-> do
747 -- TODO: Check this case
748 forM [0..length (elems $ ptrs clos)] $ \i -> do
749 tv <- newVar liftedTypeKind
750 return$ appArr (\e->(tv,e)) (ptrs clos) i
751
752 Just dc -> do
753 let extra_args = length(dataConRepArgTys dc) -
754 length(dataConOrigArgTys dc)
755 subTtypes <- mapMif (not . isMonomorphic)
756 (\t -> newVar (typeKind t))
757 (dataConRepArgTys dc)
758
759 -- It is vital for newtype reconstruction that the unification step
760 -- is done right here, _before_ the subterms are RTTI reconstructed
761 let myType = mkFunTys subTtypes tv
762 (signatureType,_) <- instScheme(dataConRepType dc)
763 addConstraint myType signatureType
764 return $ [ appArr (\e->(t,e)) (ptrs clos) i
765 | (i,t) <- drop extra_args $
766 zip [0..] (filter isPointed subTtypes)]
767 _ -> return []
768
769 -- This helper computes the difference between a base type t and the
770 -- improved rtti_t computed by RTTI
771 -- The main difference between RTTI types and their normal counterparts
772 -- is that the former are _not_ polymorphic, thus polymorphism must
773 -- be stripped. Syntactically, forall's must be stripped.
774 -- We also remove predicates.
775 unifyRTTI :: Type -> Type -> TvSubst
776 unifyRTTI ty rtti_ty =
777 case mb_subst of
778 Just subst -> subst
779 Nothing -> pprPanic "Failed to compute a RTTI substitution"
780 (ppr (ty, rtti_ty))
781 -- In addition, we strip newtypes too, since the reconstructed type might
782 -- not have recovered them all
783 -- TODO stripping newtypes shouldn't be necessary, test
784 where mb_subst = tcUnifyTys (const BindMe)
785 [rttiView ty]
786 [rttiView rtti_ty]
787
788 -- Dealing with newtypes
789 {-
790 A parallel fold over two Type values,
791 compensating for missing newtypes on both sides.
792 This is necessary because newtypes are not present
793 in runtime, but since sometimes there is evidence
794 available we do our best to reconstruct them.
795 Evidence can come from DataCon signatures or
796 from compile-time type inference.
797 I am using the words congruence and rewriting
798 because what we are doing here is an approximation
799 of unification modulo a set of equations, which would
800 come from newtype definitions. These should be the
801 equality coercions seen in System Fc. Rewriting
802 is performed, taking those equations as rules,
803 before launching unification.
804
805 It doesn't make sense to rewrite everywhere,
806 or we would end up with all newtypes. So we rewrite
807 only in presence of evidence.
808 The lhs comes from the heap structure of ptrs,nptrs.
809 The rhs comes from a DataCon type signature.
810 Rewriting in the rhs is restricted to the result type.
811
812 Note that it is very tricky to make this 'rewriting'
813 work with the unification implemented by TcM, where
814 substitutions are 'inlined'. The order in which
815 constraints are unified is vital for this.
816 This is a simple form of residuation, the technique of
817 delaying unification steps until enough information
818 is available.
819 -}
820 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
821 congruenceNewtypes lhs rhs
822 -- TyVar lhs inductive case
823 | Just tv <- getTyVar_maybe lhs
824 = recoverTc (return (lhs,rhs)) $ do
825 Indirect ty_v <- readMetaTyVar tv
826 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
827 return (lhs, rhs1)
828 -- FunTy inductive case
829 | Just (l1,l2) <- splitFunTy_maybe lhs
830 , Just (r1,r2) <- splitFunTy_maybe rhs
831 = do (l2',r2') <- congruenceNewtypes l2 r2
832 (l1',r1') <- congruenceNewtypes l1 r1
833 return (mkFunTy l1' l2', mkFunTy r1' r2')
834 -- TyconApp Inductive case; this is the interesting bit.
835 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
836 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
837 , tycon_l /= tycon_r
838 = do rhs' <- upgrade tycon_l rhs
839 return (lhs, rhs')
840
841 | otherwise = return (lhs,rhs)
842
843 where upgrade :: TyCon -> Type -> TR Type
844 upgrade new_tycon ty
845 | not (isNewTyCon new_tycon) = return ty
846 | otherwise = do
847 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
848 let ty' = mkTyConApp new_tycon vars
849 liftTcM (unifyType ty (repType ty'))
850 -- assumes that reptype doesn't ^^^^ touch tyconApp args
851 return ty'
852
853
854 --------------------------------------------------------------------------------
855 -- Semantically different to recoverM in TcRnMonad
856 -- recoverM retains the errors in the first action,
857 -- whereas recoverTc here does not
858 recoverTc :: TcM a -> TcM a -> TcM a
859 recoverTc recover thing = do
860 (_,mb_res) <- tryTcErrs thing
861 case mb_res of
862 Nothing -> recover
863 Just res -> return res
864
865 isMonomorphic :: Type -> Bool
866 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
867 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
868
869 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
870 mapMif pred f xx = sequence $ mapMif_ pred f xx
871 where
872 mapMif_ _ _ [] = []
873 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
874
875 unlessM :: Monad m => m Bool -> m () -> m ()
876 unlessM condM acc = condM >>= \c -> unless c acc
877
878 -- Strict application of f at index i
879 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
880 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
881 = ASSERT (i < length(elems a))
882 case indexArray# ptrs# i# of
883 (# e #) -> f e
884
885 zonkTerm :: Term -> TcM Term
886 zonkTerm = foldTerm idTermFoldM {
887 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
888 zonkTcType ty >>= \ty' ->
889 return (Term ty' dc v tt)
890 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
891 return (Suspension ct ty v b)
892 ,fNewtypeWrap= \ty dc t ->
893 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
894
895
896 -- Is this defined elsewhere?
897 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
898 sigmaType :: Type -> Type
899 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
900
901