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