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