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