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