Clean up the debugger code
[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 cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
11 cvReconstructType,
12 improveRTTIType,
13
14 Term(..),
15 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
16 isFullyEvaluated, isFullyEvaluatedTerm,
17 termType, mapTermType, termTyVars,
18 foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
19 pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
20
21 -- unsafeDeepSeq,
22
23 Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
24 ) where
25
26 #include "HsVersions.h"
27
28 import ByteCodeItbls ( StgInfoTable )
29 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
30 import HscTypes
31 import Linker
32
33 import DataCon
34 import Type
35 import qualified Unify as U
36 import TypeRep -- I know I know, this is cheating
37 import Var
38 import TcRnMonad
39 import TcType
40 import TcMType
41 import TcUnify
42 import TcEnv
43
44 import TyCon
45 import Name
46 import VarEnv
47 import Util
48 import ListSetOps
49 import VarSet
50 import TysPrim
51 import PrelNames
52 import TysWiredIn
53 import DynFlags
54 import Outputable
55 import FastString
56 -- import Panic
57
58 import Constants ( wORD_SIZE )
59
60 import GHC.Arr ( Array(..) )
61 import GHC.Exts
62
63 #if __GLASGOW_HASKELL__ >= 611
64 import GHC.IO ( IO(..) )
65 #else
66 import GHC.IOBase ( IO(..) )
67 #endif
68
69 import Control.Monad
70 import Data.Maybe
71 import Data.Array.Base
72 import Data.Ix
73 import Data.List
74 import qualified Data.Sequence as Seq
75 import Data.Monoid
76 import Data.Sequence (viewl, ViewL(..))
77 import Foreign hiding (unsafePerformIO)
78 import System.IO.Unsafe
79
80 ---------------------------------------------
81 -- * A representation of semi evaluated Terms
82 ---------------------------------------------
83
84 data Term = Term { ty :: RttiType
85 , dc :: Either String DataCon
86 -- Carries a text representation if the datacon is
87 -- not exported by the .hi file, which is the case
88 -- for private constructors in -O0 compiled libraries
89 , val :: HValue
90 , subTerms :: [Term] }
91
92 | Prim { ty :: RttiType
93 , value :: [Word] }
94
95 | Suspension { ctype :: ClosureType
96 , ty :: RttiType
97 , val :: HValue
98 , bound_to :: Maybe Name -- Useful for printing
99 }
100 | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
101 -- newtype constructors. A NewtypeWrap is just a
102 -- made-up tag saying "heads up, there used to be
103 -- a newtype constructor here".
104 ty :: RttiType
105 , dc :: Either String DataCon
106 , wrapped_term :: Term }
107 | RefWrap { -- The contents of a reference
108 ty :: RttiType
109 , wrapped_term :: Term }
110
111 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
112 isTerm Term{} = True
113 isTerm _ = False
114 isSuspension Suspension{} = True
115 isSuspension _ = False
116 isPrim Prim{} = True
117 isPrim _ = False
118 isNewtypeWrap NewtypeWrap{} = True
119 isNewtypeWrap _ = False
120
121 isFun Suspension{ctype=Fun} = True
122 isFun _ = False
123
124 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
125 isFunLike _ = False
126
127 termType :: Term -> RttiType
128 termType t = ty t
129
130 isFullyEvaluatedTerm :: Term -> Bool
131 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
132 isFullyEvaluatedTerm Prim {} = True
133 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
134 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
135 isFullyEvaluatedTerm _ = False
136
137 instance Outputable (Term) where
138 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
139 | otherwise = panic "Outputable Term instance"
140
141 -------------------------------------------------------------------------
142 -- Runtime Closure Datatype and functions for retrieving closure related stuff
143 -------------------------------------------------------------------------
144 data ClosureType = Constr
145 | Fun
146 | Thunk Int
147 | ThunkSelector
148 | Blackhole
149 | AP
150 | PAP
151 | Indirection Int
152 | MutVar Int
153 | MVar 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/rts/storage/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 let iptr'
180 | ghciTablesNextToCode =
181 Ptr iptr
182 | otherwise =
183 -- the info pointer we get back from unpackClosure#
184 -- is to the beginning of the standard info table,
185 -- but the Storable instance for info tables takes
186 -- into account the extra entry pointer when
187 -- !ghciTablesNextToCode, so we must adjust here:
188 Ptr iptr `plusPtr` negate wORD_SIZE
189 itbl <- peek iptr'
190 let tipe = readCType (BCI.tipe itbl)
191 elems = fromIntegral (BCI.ptrs itbl)
192 ptrsList = Array 0 (elems - 1) elems ptrs
193 nptrs_data = [W# (indexWordArray# nptrs i)
194 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
195 ASSERT(elems >= 0) return ()
196 ptrsList `seq`
197 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
198
199 readCType :: Integral a => a -> ClosureType
200 readCType i
201 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
202 | i >= FUN && i <= FUN_STATIC = Fun
203 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
204 | i == THUNK_SELECTOR = ThunkSelector
205 | i == BLACKHOLE = Blackhole
206 | i >= IND && i <= IND_STATIC = Indirection i'
207 | i' == aP_CODE = AP
208 | i == AP_STACK = AP
209 | i' == pAP_CODE = PAP
210 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
211 | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
212 | otherwise = Other i'
213 where i' = fromIntegral i
214
215 isConstr, isIndirection, isThunk :: ClosureType -> Bool
216 isConstr Constr = True
217 isConstr _ = False
218
219 isIndirection (Indirection _) = True
220 isIndirection _ = False
221
222 isThunk (Thunk _) = True
223 isThunk ThunkSelector = True
224 isThunk AP = True
225 isThunk _ = False
226
227 isFullyEvaluated :: a -> IO Bool
228 isFullyEvaluated a = do
229 closure <- getClosureData a
230 case tipe closure of
231 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
232 return$ and are_subs_evaluated
233 _ -> return False
234 where amapM f = sequence . amap' f
235
236 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
237 {-
238 unsafeDeepSeq :: a -> b -> b
239 unsafeDeepSeq = unsafeDeepSeq1 2
240 where unsafeDeepSeq1 0 a b = seq a $! b
241 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
242 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
243 -- | unsafePerformIO (isFullyEvaluated a) = b
244 | otherwise = case unsafePerformIO (getClosureData a) of
245 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
246 where tipe = unsafePerformIO (getClosureType a)
247 -}
248
249 -----------------------------------
250 -- * Traversals for Terms
251 -----------------------------------
252 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
253
254 data TermFold a = TermFold { fTerm :: TermProcessor a a
255 , fPrim :: RttiType -> [Word] -> a
256 , fSuspension :: ClosureType -> RttiType -> HValue
257 -> Maybe Name -> a
258 , fNewtypeWrap :: RttiType -> Either String DataCon
259 -> a -> a
260 , fRefWrap :: RttiType -> a -> a
261 }
262
263
264 data TermFoldM m a =
265 TermFoldM {fTermM :: TermProcessor a (m a)
266 , fPrimM :: RttiType -> [Word] -> m a
267 , fSuspensionM :: ClosureType -> RttiType -> HValue
268 -> Maybe Name -> m a
269 , fNewtypeWrapM :: RttiType -> Either String DataCon
270 -> a -> m a
271 , fRefWrapM :: RttiType -> a -> m a
272 }
273
274 foldTerm :: TermFold a -> Term -> a
275 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
276 foldTerm tf (Prim ty v ) = fPrim tf ty v
277 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
278 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
279 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
280
281
282 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
283 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
284 foldTermM tf (Prim ty v ) = fPrimM tf ty v
285 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
286 foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
287 foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
288
289 idTermFold :: TermFold Term
290 idTermFold = TermFold {
291 fTerm = Term,
292 fPrim = Prim,
293 fSuspension = Suspension,
294 fNewtypeWrap = NewtypeWrap,
295 fRefWrap = RefWrap
296 }
297
298 mapTermType :: (RttiType -> Type) -> Term -> Term
299 mapTermType f = foldTerm idTermFold {
300 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
301 fSuspension = \ct ty hval n ->
302 Suspension ct (f ty) hval n,
303 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
304 fRefWrap = \ty t -> RefWrap (f ty) t}
305
306 mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
307 mapTermTypeM f = foldTermM TermFoldM {
308 fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
309 fPrimM = (return.) . Prim,
310 fSuspensionM = \ct ty hval n ->
311 f ty >>= \ty' -> return $ Suspension ct ty' hval n,
312 fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
313 fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap 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{ty=ty, bound_to=Nothing} =
375 return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
376 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
377 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
378 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
379 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
380 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
381 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
382
383 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
384 | Just (tc,_) <- tcSplitTyConApp_maybe ty
385 , ASSERT(isNewTyCon tc) True
386 , Just new_dc <- tyConSingleDataCon_maybe tc = do
387 real_term <- y max_prec t
388 return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
389 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
390
391 -------------------------------------------------------
392 -- Custom Term Pretty Printers
393 -------------------------------------------------------
394
395 -- We can want to customize the representation of a
396 -- term depending on its type.
397 -- However, note that custom printers have to work with
398 -- type representations, instead of directly with types.
399 -- We cannot use type classes here, unless we employ some
400 -- typerep trickery (e.g. Weirich's RepLib tricks),
401 -- which I didn't. Therefore, this code replicates a lot
402 -- of what type classes provide for free.
403
404 type CustomTermPrinter m = TermPrinterM m
405 -> [Precedence -> Term -> (m (Maybe SDoc))]
406
407 -- | Takes a list of custom printers with a explicit recursion knot and a term,
408 -- and returns the output of the first succesful printer, or the default printer
409 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
410 cPprTerm printers_ = go 0 where
411 printers = printers_ go
412 go prec t = do
413 let default_ = Just `liftM` pprTermM go prec t
414 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
415 Just doc <- firstJustM mb_customDocs
416 return$ cparen (prec>app_prec+1) doc
417
418 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
419 firstJustM [] = return Nothing
420
421 -- Default set of custom printers. Note that the recursion knot is explicit
422 cPprTermBase :: Monad m => CustomTermPrinter m
423 cPprTermBase y =
424 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
425 . mapM (y (-1))
426 . subTerms)
427 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
428 (\ p t -> doList p t)
429 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
430 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
431 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
432 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
433 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
434 ]
435 where ifTerm pred f prec t@Term{}
436 | pred t = Just `liftM` f prec t
437 ifTerm _ _ _ _ = return Nothing
438
439 isTupleTy ty = fromMaybe False $ do
440 (tc,_) <- tcSplitTyConApp_maybe ty
441 return (isBoxedTupleTyCon tc)
442
443 isTyCon a_tc ty = fromMaybe False $ do
444 (tc,_) <- tcSplitTyConApp_maybe ty
445 return (a_tc == tc)
446
447 isIntegerTy ty = fromMaybe False $ do
448 (tc,_) <- tcSplitTyConApp_maybe ty
449 return (tyConName tc == integerTyConName)
450
451 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
452
453 --Note pprinting of list terms is not lazy
454 doList p (Term{subTerms=[h,t]}) = do
455 let elems = h : getListTerms t
456 isConsLast = not(termType(last elems) `coreEqType` termType h)
457 print_elems <- mapM (y cons_prec) elems
458 return$ if isConsLast
459 then cparen (p >= cons_prec)
460 . pprDeeperList fsep
461 . punctuate (space<>colon)
462 $ print_elems
463 else brackets (pprDeeperList fcat$
464 punctuate comma print_elems)
465
466 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
467 getListTerms Term{subTerms=[]} = []
468 getListTerms t@Suspension{} = [t]
469 getListTerms t = pprPanic "getListTerms" (ppr t)
470 doList _ _ = panic "doList"
471
472
473 repPrim :: TyCon -> [Word] -> String
474 repPrim t = rep where
475 rep x
476 | t == charPrimTyCon = show (build x :: Char)
477 | t == intPrimTyCon = show (build x :: Int)
478 | t == wordPrimTyCon = show (build x :: Word)
479 | t == floatPrimTyCon = show (build x :: Float)
480 | t == doublePrimTyCon = show (build x :: Double)
481 | t == int32PrimTyCon = show (build x :: Int32)
482 | t == word32PrimTyCon = show (build x :: Word32)
483 | t == int64PrimTyCon = show (build x :: Int64)
484 | t == word64PrimTyCon = show (build x :: Word64)
485 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
486 | t == stablePtrPrimTyCon = "<stablePtr>"
487 | t == stableNamePrimTyCon = "<stableName>"
488 | t == statePrimTyCon = "<statethread>"
489 | t == realWorldTyCon = "<realworld>"
490 | t == threadIdPrimTyCon = "<ThreadId>"
491 | t == weakPrimTyCon = "<Weak>"
492 | t == arrayPrimTyCon = "<array>"
493 | t == byteArrayPrimTyCon = "<bytearray>"
494 | t == mutableArrayPrimTyCon = "<mutableArray>"
495 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
496 | t == mutVarPrimTyCon= "<mutVar>"
497 | t == mVarPrimTyCon = "<mVar>"
498 | t == tVarPrimTyCon = "<tVar>"
499 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
500 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
501 -- This ^^^ relies on the representation of Haskell heap values being
502 -- the same as in a C array.
503
504 -----------------------------------
505 -- Type Reconstruction
506 -----------------------------------
507 {-
508 Type Reconstruction is type inference done on heap closures.
509 The algorithm walks the heap generating a set of equations, which
510 are solved with syntactic unification.
511 A type reconstruction equation looks like:
512
513 <datacon reptype> = <actual heap contents>
514
515 The full equation set is generated by traversing all the subterms, starting
516 from a given term.
517
518 The only difficult part is that newtypes are only found in the lhs of equations.
519 Right hand sides are missing them. We can either (a) drop them from the lhs, or
520 (b) reconstruct them in the rhs when possible.
521
522 The function congruenceNewtypes takes a shot at (b)
523 -}
524
525
526 -- A (non-mutable) tau type containing
527 -- existentially quantified tyvars.
528 -- (since GHC type language currently does not support
529 -- existentials, we leave these variables unquantified)
530 type RttiType = Type
531
532 -- An incomplete type as stored in GHCi:
533 -- no polymorphism: no quantifiers & all tyvars are skolem.
534 type GhciType = Type
535
536
537 -- The Type Reconstruction monad
538 --------------------------------
539 type TR a = TcM a
540
541 runTR :: HscEnv -> TR a -> IO a
542 runTR hsc_env thing = do
543 mb_val <- runTR_maybe hsc_env thing
544 case mb_val of
545 Nothing -> error "unable to :print the term"
546 Just x -> return x
547
548 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
549 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
550
551 traceTR :: SDoc -> TR ()
552 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
553
554
555 -- Semantically different to recoverM in TcRnMonad
556 -- recoverM retains the errors in the first action,
557 -- whereas recoverTc here does not
558 recoverTR :: TR a -> TR a -> TR a
559 recoverTR recover thing = do
560 (_,mb_res) <- tryTcErrs thing
561 case mb_res of
562 Nothing -> recover
563 Just res -> return res
564
565 trIO :: IO a -> TR a
566 trIO = liftTcM . liftIO
567
568 liftTcM :: TcM a -> TR a
569 liftTcM = id
570
571 newVar :: Kind -> TR TcType
572 newVar = liftTcM . newFlexiTyVarTy
573
574 type RttiInstantiation = [(TyVar, TcTyVar)]
575 -- Assoicates the debugger-world type variables (which are skolems)
576 -- to typechecker-world meta type variables (which are mutable,
577 -- and may be refined)
578
579 -- | Returns the instantiated type scheme ty', and the
580 -- mapping from old to new (instantiated) type variables
581 instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
582 instScheme (tvs, ty)
583 = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
584 ; return (substTy subst ty, tvs `zip` tvs') }
585
586 applyRevSubst :: RttiInstantiation -> TR ()
587 -- Apply the *reverse* substitution in-place to any un-filled-in
588 -- meta tyvars. This recovers the original debugger-world variable
589 -- unless it has been refined by new information from the heap
590 applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
591 where
592 do_pair (rtti_tv, tc_tv)
593 = do { tc_ty <- zonkTcTyVar tc_tv
594 ; case tcGetTyVar_maybe tc_ty of
595 Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
596 _ -> return () }
597
598 -- Adds a constraint of the form t1 == t2
599 -- t1 is expected to come from walking the heap
600 -- t2 is expected to come from a datacon signature
601 -- Before unification, congruenceNewtypes needs to
602 -- do its magic.
603 addConstraint :: TcType -> TcType -> TR ()
604 addConstraint actual expected = do
605 traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
606 recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
607 text "with", ppr expected]) $
608 do { (ty1, ty2) <- congruenceNewtypes actual expected
609 ; _ <- captureConstraints $ unifyType ty1 ty2
610 ; return () }
611 -- TOMDO: what about the coercion?
612 -- we should consider family instances
613
614
615 -- Type & Term reconstruction
616 ------------------------------
617 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
618 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
619 -- we quantify existential tyvars as universal,
620 -- as this is needed to be able to manipulate
621 -- them properly
622 let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
623 sigma_old_ty = mkForAllTys old_tvs old_tau
624 traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
625 term <-
626 if null old_tvs
627 then do
628 term <- go max_depth sigma_old_ty sigma_old_ty hval
629 term' <- zonkTerm term
630 return $ fixFunDictionaries $ expandNewtypes term'
631 else do
632 (old_ty', rev_subst) <- instScheme quant_old_ty
633 my_ty <- newVar argTypeKind
634 when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
635 addConstraint my_ty old_ty')
636 term <- go max_depth my_ty sigma_old_ty hval
637 new_ty <- zonkTcType (termType term)
638 if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
639 then do
640 traceTR (text "check2 passed")
641 addConstraint new_ty old_ty'
642 applyRevSubst rev_subst
643 zterm' <- zonkTerm term
644 return ((fixFunDictionaries . expandNewtypes) zterm')
645 else do
646 traceTR (text "check2 failed" <+> parens
647 (ppr term <+> text "::" <+> ppr new_ty))
648 -- we have unsound types. Replace constructor types in
649 -- subterms with tyvars
650 zterm' <- mapTermTypeM
651 (\ty -> case tcSplitTyConApp_maybe ty of
652 Just (tc, _:_) | tc /= funTyCon
653 -> newVar argTypeKind
654 _ -> return ty)
655 term
656 zonkTerm zterm'
657 traceTR (text "Term reconstruction completed." $$
658 text "Term obtained: " <> ppr term $$
659 text "Type obtained: " <> ppr (termType term))
660 return term
661 where
662 go :: Int -> Type -> Type -> HValue -> TcM Term
663 go max_depth _ _ _ | seq max_depth False = undefined
664 go 0 my_ty _old_ty a = do
665 traceTR (text "Gave up reconstructing a term after" <>
666 int max_depth <> text " steps")
667 clos <- trIO $ getClosureData a
668 return (Suspension (tipe clos) my_ty a Nothing)
669 go max_depth my_ty old_ty a = do
670 let monomorphic = not(isTyVarTy my_ty)
671 -- This ^^^ is a convention. The ancestor tests for
672 -- monomorphism and passes a type instead of a tv
673 clos <- trIO $ getClosureData a
674 case tipe clos of
675 -- Thunks we may want to force
676 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
677 seq a (go (pred max_depth) my_ty old_ty a)
678 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
679 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
680 -- showing '_' which is what we want.
681 Blackhole -> do traceTR (text "Following a BLACKHOLE")
682 appArr (go max_depth my_ty old_ty) (ptrs clos) 0
683 -- We always follow indirections
684 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
685 go max_depth my_ty old_ty $! (ptrs clos ! 0)
686 -- We also follow references
687 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
688 -> do
689 -- Deal with the MutVar# primitive
690 -- It does not have a constructor at all,
691 -- so we simulate the following one
692 -- MutVar# :: contents_ty -> MutVar# s contents_ty
693 traceTR (text "Following a MutVar")
694 contents_tv <- newVar liftedTypeKind
695 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
696 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
697 (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
698 contents_ty (mkTyConApp tycon [world,contents_ty])
699 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
700 x <- go (pred max_depth) contents_tv contents_ty contents
701 return (RefWrap my_ty x)
702
703 -- The interesting case
704 Constr -> do
705 traceTR (text "entering a constructor " <>
706 if monomorphic
707 then parens (text "already monomorphic: " <> ppr my_ty)
708 else Outputable.empty)
709 Right dcname <- dataConInfoPtrToName (infoPtr clos)
710 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
711 case mb_dc of
712 Nothing -> do -- This can happen for private constructors compiled -O0
713 -- where the .hi descriptor does not export them
714 -- In such case, we return a best approximation:
715 -- ignore the unpointed args, and recover the pointeds
716 -- This preserves laziness, and should be safe.
717 let tag = showSDoc (ppr dcname)
718 vars <- replicateM (length$ elems$ ptrs clos)
719 (newVar (liftedTypeKind))
720 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
721 | (i, tv) <- zip [0..] vars]
722 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
723 Just dc -> do
724 let subTtypes = matchSubTypes dc old_ty
725 subTermTvs <- mapMif (not . isMonomorphic)
726 (\t -> newVar (typeKind t))
727 subTtypes
728 let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
729 || isRefType ty)
730 (zip subTtypes subTermTvs)
731 (subTtypesP, subTermTvsP ) = unzip subTermsP
732 (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
733
734 -- When we already have all the information, avoid solving
735 -- unnecessary constraints. Propagation of type information
736 -- to subterms is already being done via matching.
737 when (not monomorphic) $ do
738 let myType = mkFunTys subTermTvs my_ty
739 (signatureType,_) <- instScheme (mydataConType dc)
740 -- It is vital for newtype reconstruction that the unification step
741 -- is done right here, _before_ the subterms are RTTI reconstructed
742 addConstraint myType signatureType
743 subTermsP <- sequence
744 [ appArr (go (pred max_depth) tv t) (ptrs clos) i
745 | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
746 let unboxeds = extractUnboxed subTtypesNP clos
747 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
748 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
749 return (Term my_ty (Right dc) a subTerms)
750 -- The otherwise case: can be a Thunk,AP,PAP,etc.
751 tipe_clos ->
752 return (Suspension tipe_clos my_ty a Nothing)
753
754 matchSubTypes dc ty
755 | ty' <- repType ty -- look through newtypes
756 , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
757 , dc `elem` tyConDataCons tc
758 -- It is necessary to check that dc is actually a constructor for tycon tc,
759 -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
760 -- has not removed it. In that case, we happily give up and don't match
761 = myDataConInstArgTys dc ty_args
762 | otherwise = dataConRepArgTys dc
763
764 -- put together pointed and nonpointed subterms in the
765 -- correct order.
766 reOrderTerms _ _ [] = []
767 reOrderTerms pointed unpointed (ty:tys)
768 | isLifted ty || isRefType ty
769 = ASSERT2(not(null pointed)
770 , ptext (sLit "reOrderTerms") $$
771 (ppr pointed $$ ppr unpointed))
772 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
773 | otherwise = ASSERT2(not(null unpointed)
774 , ptext (sLit "reOrderTerms") $$
775 (ppr pointed $$ ppr unpointed))
776 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
777
778 -- insert NewtypeWraps around newtypes
779 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
780 worker ty dc hval tt
781 | Just (tc, args) <- tcSplitTyConApp_maybe ty
782 , isNewTyCon tc
783 , wrapped_type <- newTyConInstRhs tc args
784 , Just dc' <- tyConSingleDataCon_maybe tc
785 , t' <- worker wrapped_type dc hval tt
786 = NewtypeWrap ty (Right dc') t'
787 | otherwise = Term ty dc hval tt
788
789
790 -- Avoid returning types where predicates have been expanded to dictionaries.
791 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
792 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
793 | otherwise = Suspension ct ty hval n
794
795
796 -- Fast, breadth-first Type reconstruction
797 ------------------------------------------
798 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
799 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
800 traceTR (text "RTTI started with initial type " <> ppr old_ty)
801 let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
802 new_ty <-
803 if null old_tvs
804 then return old_ty
805 else do
806 (old_ty', rev_subst) <- instScheme sigma_old_ty
807 my_ty <- newVar argTypeKind
808 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
809 addConstraint my_ty old_ty')
810 search (isMonomorphic `fmap` zonkTcType my_ty)
811 (\(ty,a) -> go ty a)
812 (Seq.singleton (my_ty, hval))
813 max_depth
814 new_ty <- zonkTcType my_ty
815 if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
816 then do
817 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
818 addConstraint my_ty old_ty'
819 applyRevSubst rev_subst
820 zonkRttiType new_ty
821 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
822 return old_ty
823 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
824 return new_ty
825 where
826 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
827 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
828 int max_depth <> text " steps")
829 search stop expand l d =
830 case viewl l of
831 EmptyL -> return ()
832 x :< xx -> unlessM stop $ do
833 new <- expand x
834 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
835
836 -- returns unification tasks,since we are going to want a breadth-first search
837 go :: Type -> HValue -> TR [(Type, HValue)]
838 go my_ty a = do
839 clos <- trIO $ getClosureData a
840 case tipe clos of
841 Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
842 Indirection _ -> go my_ty $! (ptrs clos ! 0)
843 MutVar _ -> do
844 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
845 tv' <- newVar liftedTypeKind
846 world <- newVar liftedTypeKind
847 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
848 return [(tv', contents)]
849 Constr -> do
850 Right dcname <- dataConInfoPtrToName (infoPtr clos)
851 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
852 case mb_dc of
853 Nothing-> do
854 -- TODO: Check this case
855 forM [0..length (elems $ ptrs clos)] $ \i -> do
856 tv <- newVar liftedTypeKind
857 return$ appArr (\e->(tv,e)) (ptrs clos) i
858
859 Just dc -> do
860 subTtypes <- mapMif (not . isMonomorphic)
861 (\t -> newVar (typeKind t))
862 (dataConRepArgTys dc)
863
864 -- It is vital for newtype reconstruction that the unification step
865 -- is done right here, _before_ the subterms are RTTI reconstructed
866 let myType = mkFunTys subTtypes my_ty
867 (signatureType,_) <- instScheme (mydataConType dc)
868 addConstraint myType signatureType
869 return $ [ appArr (\e->(t,e)) (ptrs clos) i
870 | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
871 _ -> return []
872
873 -- Compute the difference between a base type and the type found by RTTI
874 -- improveType <base_type> <rtti_type>
875 -- The types can contain skolem type variables, which need to be treated as normal vars.
876 -- In particular, we want them to unify with things.
877 improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
878 improveRTTIType _ base_ty new_ty
879 = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
880
881 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
882 myDataConInstArgTys dc args
883 | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
884 | otherwise = dataConRepArgTys dc
885
886 mydataConType :: DataCon -> QuantifiedType
887 -- ^ Custom version of DataCon.dataConUserType where we
888 -- - remove the equality constraints
889 -- - use the representation types for arguments, including dictionaries
890 -- - keep the original result type
891 mydataConType dc
892 = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
893 , mkFunTys arg_tys res_ty )
894 where univ_tvs = dataConUnivTyVars dc
895 ex_tvs = dataConExTyVars dc
896 eq_spec = dataConEqSpec dc
897 arg_tys = [case a of
898 PredTy p -> predTypeRep p
899 _ -> a
900 | a <- dataConRepArgTys dc]
901 res_ty = dataConOrigResTy dc
902
903 isRefType :: Type -> Bool
904 isRefType ty
905 | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
906 | otherwise = False
907 where ty'= repType ty
908
909 isRefTyCon :: TyCon -> Bool
910 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
911
912 -- Soundness checks
913 --------------------
914 {-
915 This is not formalized anywhere, so hold to your seats!
916 RTTI in the presence of newtypes can be a tricky and unsound business.
917
918 Example:
919 ~~~~~~~~~
920 Suppose we are doing RTTI for a partially evaluated
921 closure t, the real type of which is t :: MkT Int, for
922
923 newtype MkT a = MkT [Maybe a]
924
925 The table below shows the results of RTTI and the improvement
926 calculated for different combinations of evaluatedness and :type t.
927 Regard the two first columns as input and the next two as output.
928
929 # | t | :type t | rtti(t) | improv. | result
930 ------------------------------------------------------------
931 1 | _ | t b | a | none | OK
932 2 | _ | MkT b | a | none | OK
933 3 | _ | t Int | a | none | OK
934
935 If t is not evaluated at *all*, we are safe.
936
937 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
938 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
939 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
940
941 If a is a minimal whnf, we run into trouble. Note that
942 row 5 above does newtype enrichment on the ty_rtty parameter.
943
944 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
945 | | | b = Maybe a|
946
947 8 | (Just _:_)| MkT b | MkT a | none | OK
948 9 | (Just _:_)| t Int | FAIL | none | OK
949
950 And if t is any more evaluated than whnf, we are still in trouble.
951 Because constraints are solved in top-down order, when we reach the
952 Maybe subterm what we got is already unsound. This explains why the
953 row 9 fails to complete.
954
955 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
956 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
957
958 We can undo the failure in row 9 by leaving out the constraint
959 coming from the type signature of t (i.e., the 2nd column).
960 Note that this type information is still used
961 to calculate the improvement. But we fail
962 when trying to calculate the improvement, as there is no unifier for
963 t Int = [Maybe a] or t Int = [Maybe Int].
964
965
966 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
967
968 # | t | :type t | rtti(t) | improvement | result
969 ---------------------------------------------------------------------
970 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
971 | | | | b = Maybe a |
972
973 The checks:
974 ~~~~~~~~~~~
975 Consider a function obtainType that takes a value and a type and produces
976 the Term representation and a substitution (the improvement).
977 Assume an auxiliar rtti' function which does the actual job if recovering
978 the type, but which may produce a false type.
979
980 In pseudocode:
981
982 rtti' :: a -> IO Type -- Does not use the static type information
983
984 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
985 obtainType v old_ty = do
986 rtti_ty <- rtti' v
987 if monomorphic rtti_ty || (check rtti_ty old_ty)
988 then ...
989 else return Nothing
990 where check rtti_ty old_ty = check1 rtti_ty &&
991 check2 rtti_ty old_ty
992
993 check1 :: Type -> Bool
994 check2 :: Type -> Type -> Bool
995
996 Now, if rtti' returns a monomorphic type, we are safe.
997 If that is not the case, then we consider two conditions.
998
999
1000 1. To prevent the class of unsoundness displayed by
1001 rows 4 and 7 in the example: no higher kind tyvars
1002 accepted.
1003
1004 check1 (t a) = NO
1005 check1 (t Int) = NO
1006 check1 ([] a) = YES
1007
1008 2. To prevent the class of unsoundness shown by row 6,
1009 the rtti type should be structurally more
1010 defined than the old type we are comparing it to.
1011 check2 :: NewType -> OldType -> Bool
1012 check2 a _ = True
1013 check2 [a] a = True
1014 check2 [a] (t Int) = False
1015 check2 [a] (t a) = False -- By check1 we never reach this equation
1016 check2 [Int] a = True
1017 check2 [Int] (t Int) = True
1018 check2 [Maybe a] (t Int) = False
1019 check2 [Maybe Int] (t Int) = True
1020 check2 (Maybe [a]) (m [Int]) = False
1021 check2 (Maybe [Int]) (m [Int]) = True
1022
1023 -}
1024
1025 check1 :: QuantifiedType -> Bool
1026 check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
1027 where
1028 isHigherKind = not . null . fst . splitKindFunTys
1029
1030 check2 :: QuantifiedType -> QuantifiedType -> Bool
1031 check2 (_, rtti_ty) (_, old_ty)
1032 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1033 = case () of
1034 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1035 -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
1036 _ | Just _ <- splitAppTy_maybe old_ty
1037 -> isMonomorphicOnNonPhantomArgs rtti_ty
1038 _ -> True
1039 | otherwise = True
1040
1041 -- Dealing with newtypes
1042 --------------------------
1043 {-
1044 congruenceNewtypes does a parallel fold over two Type values,
1045 compensating for missing newtypes on both sides.
1046 This is necessary because newtypes are not present
1047 in runtime, but sometimes there is evidence available.
1048 Evidence can come from DataCon signatures or
1049 from compile-time type inference.
1050 What we are doing here is an approximation
1051 of unification modulo a set of equations derived
1052 from newtype definitions. These equations should be the
1053 same as the equality coercions generated for newtypes
1054 in System Fc. The idea is to perform a sort of rewriting,
1055 taking those equations as rules, before launching unification.
1056
1057 The caller must ensure the following.
1058 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1059 The 2nd type (rhs) comes from a DataCon type signature.
1060 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1061 in both types, but in the rhs it is restricted to the result type.
1062
1063 Note that it is very tricky to make this 'rewriting'
1064 work with the unification implemented by TcM, where
1065 substitutions are operationally inlined. The order in which
1066 constraints are unified is vital as we cannot modify
1067 anything that has been touched by a previous unification step.
1068 Therefore, congruenceNewtypes is sound only if the types
1069 recovered by the RTTI mechanism are unified Top-Down.
1070 -}
1071 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1072 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1073 where
1074 go l r
1075 -- TyVar lhs inductive case
1076 | Just tv <- getTyVar_maybe l
1077 , isTcTyVar tv
1078 , isMetaTyVar tv
1079 = recoverTR (return r) $ do
1080 Indirect ty_v <- readMetaTyVar tv
1081 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1082 ppr tv, equals, ppr ty_v]
1083 go ty_v r
1084 -- FunTy inductive case
1085 | Just (l1,l2) <- splitFunTy_maybe l
1086 , Just (r1,r2) <- splitFunTy_maybe r
1087 = do r2' <- go l2 r2
1088 r1' <- go l1 r1
1089 return (mkFunTy r1' r2')
1090 -- TyconApp Inductive case; this is the interesting bit.
1091 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1092 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1093 , tycon_l /= tycon_r
1094 = upgrade tycon_l r
1095
1096 | otherwise = return r
1097
1098 where upgrade :: TyCon -> Type -> TR Type
1099 upgrade new_tycon ty
1100 | not (isNewTyCon new_tycon) = do
1101 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1102 ppr new_tycon <> text " for " <> ppr ty)
1103 return ty
1104 | otherwise = do
1105 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1106 text " in presence of newtype evidence " <> ppr new_tycon)
1107 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1108 let ty' = mkTyConApp new_tycon vars
1109 _ <- liftTcM (unifyType ty (repType ty'))
1110 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1111 return ty'
1112
1113
1114 zonkTerm :: Term -> TcM Term
1115 zonkTerm = foldTermM (TermFoldM
1116 { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' ->
1117 return (Term ty' dc v tt)
1118 , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty ->
1119 return (Suspension ct ty v b)
1120 , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
1121 return$ NewtypeWrap ty' dc t
1122 , fRefWrapM = \ty t -> return RefWrap `ap`
1123 zonkRttiType ty `ap` return t
1124 , fPrimM = (return.) . Prim })
1125
1126 zonkRttiType :: TcType -> TcM Type
1127 -- Zonk the type, replacing any unbound Meta tyvars
1128 -- by skolems, safely out of Meta-tyvar-land
1129 zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
1130 where
1131 zonk_unbound_meta tv
1132 = ASSERT( isTcTyVar tv )
1133 do { tv' <- skolemiseUnboundMetaTyVar RuntimeUnkSkol tv
1134 ; return (mkTyVarTy tv') }
1135
1136 --------------------------------------------------------------------------------
1137 -- Restore Class predicates out of a representation type
1138 dictsView :: Type -> Type
1139 -- dictsView ty = ty
1140 dictsView (FunTy (TyConApp tc_dict args) ty)
1141 | Just c <- tyConClass_maybe tc_dict
1142 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1143 dictsView ty
1144 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1145 , Just c <- tyConClass_maybe tc_dict
1146 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1147 dictsView ty = ty
1148
1149
1150 -- Use only for RTTI types
1151 isMonomorphic :: RttiType -> Bool
1152 isMonomorphic ty = noExistentials && noUniversals
1153 where (tvs, _, ty') = tcSplitSigmaTy ty
1154 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1155 noUniversals = null tvs
1156
1157 -- Use only for RTTI types
1158 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1159 isMonomorphicOnNonPhantomArgs ty
1160 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1161 , phantom_vars <- tyConPhantomTyVars tc
1162 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1163 , tyv `notElem` phantom_vars]
1164 = all isMonomorphicOnNonPhantomArgs concrete_args
1165 | Just (ty1, ty2) <- splitFunTy_maybe ty
1166 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1167 | otherwise = isMonomorphic ty
1168
1169 tyConPhantomTyVars :: TyCon -> [TyVar]
1170 tyConPhantomTyVars tc
1171 | isAlgTyCon tc
1172 , Just dcs <- tyConDataCons_maybe tc
1173 , dc_vars <- concatMap dataConUnivTyVars dcs
1174 = tyConTyVars tc \\ dc_vars
1175 tyConPhantomTyVars _ = []
1176
1177 type QuantifiedType = ([TyVar], Type) -- Make the free type variables explicit
1178
1179 quantifyType :: Type -> QuantifiedType
1180 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1181 quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
1182
1183 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1184 mapMif pred f xx = sequence $ mapMif_ pred f xx
1185 where
1186 mapMif_ _ _ [] = []
1187 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1188
1189 unlessM :: Monad m => m Bool -> m () -> m ()
1190 unlessM condM acc = condM >>= \c -> unless c acc
1191
1192
1193 -- Strict application of f at index i
1194 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1195 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1196 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1197 case indexArray# ptrs# i# of
1198 (# e #) -> f e
1199
1200 amap' :: (t -> b) -> Array Int t -> [b]
1201 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1202 where g (I# i#) = case indexArray# arr# i# of
1203 (# e #) -> f e
1204
1205
1206 isLifted :: Type -> Bool
1207 isLifted = not . isUnLiftedType
1208
1209 extractUnboxed :: [Type] -> Closure -> [[Word]]
1210 extractUnboxed tt clos = go tt (nonPtrs clos)
1211 where sizeofType t
1212 | Just (tycon,_) <- tcSplitTyConApp_maybe t
1213 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1214 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1215 go [] _ = []
1216 go (t:tt) xx
1217 | (x, rest) <- splitAt (sizeofType t) xx
1218 = x : go tt rest
1219
1220 sizeofTyCon :: TyCon -> Int -- in *words*
1221 sizeofTyCon = primRepSizeW . tyConPrimRep
1222
1223
1224 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1225 (f |.| g) x = f x || g x