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