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