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