Merge branch 'master' of http://darcs.haskell.org/ghc
[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 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 hiding (unsafePerformIO)
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) (text dc_tag <+> pprDeeperList fsep tt_docs)
340
341 ppr_termM y p Term{dc=Right dc, subTerms=tt}
342 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
343 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
344 <+> hsep (map (ppr_term1 True) tt)
345 -} -- TODO Printing infix constructors properly
346 | null sub_terms_to_show
347 = return (ppr dc)
348 | otherwise
349 = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
350 ; return $ cparen (p >= app_prec) $
351 sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
352 where
353 sub_terms_to_show -- Don't show the dictionary arguments to
354 -- constructors unless -dppr-debug is on
355 | opt_PprStyle_Debug = tt
356 | otherwise = dropList (dataConTheta dc) tt
357
358 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
359 ppr_termM y p RefWrap{wrapped_term=t} = do
360 contents <- y app_prec t
361 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
362 -- The constructor name is wired in here ^^^ for the sake of simplicity.
363 -- I don't think mutvars are going to change in a near future.
364 -- In any case this is solely a presentation matter: MutVar# is
365 -- a datatype with no constructors, implemented by the RTS
366 -- (hence there is no way to obtain a datacon and print it).
367 ppr_termM _ _ t = ppr_termM1 t
368
369
370 ppr_termM1 :: Monad m => Term -> m SDoc
371 ppr_termM1 Prim{value=words, ty=ty} =
372 return$ text$ repPrim (tyConAppTyCon ty) words
373 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
374 return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
375 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
376 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
377 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
378 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
379 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
380 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
381
382 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
383 | Just (tc,_) <- tcSplitTyConApp_maybe ty
384 , ASSERT(isNewTyCon tc) True
385 , Just new_dc <- tyConSingleDataCon_maybe tc = do
386 real_term <- y max_prec t
387 return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
388 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
389
390 -------------------------------------------------------
391 -- Custom Term Pretty Printers
392 -------------------------------------------------------
393
394 -- We can want to customize the representation of a
395 -- term depending on its type.
396 -- However, note that custom printers have to work with
397 -- type representations, instead of directly with types.
398 -- We cannot use type classes here, unless we employ some
399 -- typerep trickery (e.g. Weirich's RepLib tricks),
400 -- which I didn't. Therefore, this code replicates a lot
401 -- of what type classes provide for free.
402
403 type CustomTermPrinter m = TermPrinterM m
404 -> [Precedence -> Term -> (m (Maybe SDoc))]
405
406 -- | Takes a list of custom printers with a explicit recursion knot and a term,
407 -- and returns the output of the first succesful printer, or the default printer
408 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
409 cPprTerm printers_ = go 0 where
410 printers = printers_ go
411 go prec t = do
412 let default_ = Just `liftM` pprTermM go prec t
413 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
414 Just doc <- firstJustM mb_customDocs
415 return$ cparen (prec>app_prec+1) doc
416
417 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
418 firstJustM [] = return Nothing
419
420 -- Default set of custom printers. Note that the recursion knot is explicit
421 cPprTermBase :: forall m. Monad m => CustomTermPrinter m
422 cPprTermBase y =
423 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
424 . mapM (y (-1))
425 . subTerms)
426 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
427 ppr_list
428 , ifTerm (isTyCon intTyCon . ty) ppr_int
429 , ifTerm (isTyCon charTyCon . ty) ppr_char
430 , ifTerm (isTyCon floatTyCon . ty) ppr_float
431 , ifTerm (isTyCon doubleTyCon . ty) ppr_double
432 , ifTerm (isIntegerTy . ty) ppr_integer
433 ]
434 where
435 ifTerm :: (Term -> Bool)
436 -> (Precedence -> Term -> m SDoc)
437 -> Precedence -> Term -> m (Maybe SDoc)
438 ifTerm pred f prec t@Term{}
439 | pred t = Just `liftM` f prec t
440 ifTerm _ _ _ _ = return Nothing
441
442 isTupleTy ty = fromMaybe False $ do
443 (tc,_) <- tcSplitTyConApp_maybe ty
444 return (isBoxedTupleTyCon tc)
445
446 isTyCon a_tc ty = fromMaybe False $ do
447 (tc,_) <- tcSplitTyConApp_maybe ty
448 return (a_tc == tc)
449
450 isIntegerTy ty = fromMaybe False $ do
451 (tc,_) <- tcSplitTyConApp_maybe ty
452 return (tyConName tc == integerTyConName)
453
454 ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
455 :: Precedence -> Term -> m SDoc
456 ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
457 ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
458 ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
459 ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
460 ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
461
462 --Note pprinting of list terms is not lazy
463 ppr_list :: Precedence -> Term -> m SDoc
464 ppr_list p (Term{subTerms=[h,t]}) = do
465 let elems = h : getListTerms t
466 isConsLast = not(termType(last elems) `eqType` termType h)
467 is_string = all (isCharTy . ty) elems
468
469 print_elems <- mapM (y cons_prec) elems
470 if is_string
471 then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
472 else if isConsLast
473 then return $ cparen (p >= cons_prec)
474 $ pprDeeperList fsep
475 $ punctuate (space<>colon) print_elems
476 else return $ brackets
477 $ pprDeeperList fcat
478 $ punctuate comma print_elems
479
480 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
481 getListTerms Term{subTerms=[]} = []
482 getListTerms t@Suspension{} = [t]
483 getListTerms t = pprPanic "getListTerms" (ppr t)
484 ppr_list _ _ = panic "doList"
485
486
487 repPrim :: TyCon -> [Word] -> String
488 repPrim t = rep where
489 rep x
490 | t == charPrimTyCon = show (build x :: Char)
491 | t == intPrimTyCon = show (build x :: Int)
492 | t == wordPrimTyCon = show (build x :: Word)
493 | t == floatPrimTyCon = show (build x :: Float)
494 | t == doublePrimTyCon = show (build x :: Double)
495 | t == int32PrimTyCon = show (build x :: Int32)
496 | t == word32PrimTyCon = show (build x :: Word32)
497 | t == int64PrimTyCon = show (build x :: Int64)
498 | t == word64PrimTyCon = show (build x :: Word64)
499 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
500 | t == stablePtrPrimTyCon = "<stablePtr>"
501 | t == stableNamePrimTyCon = "<stableName>"
502 | t == statePrimTyCon = "<statethread>"
503 | t == realWorldTyCon = "<realworld>"
504 | t == threadIdPrimTyCon = "<ThreadId>"
505 | t == weakPrimTyCon = "<Weak>"
506 | t == arrayPrimTyCon = "<array>"
507 | t == byteArrayPrimTyCon = "<bytearray>"
508 | t == mutableArrayPrimTyCon = "<mutableArray>"
509 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
510 | t == mutVarPrimTyCon= "<mutVar>"
511 | t == mVarPrimTyCon = "<mVar>"
512 | t == tVarPrimTyCon = "<tVar>"
513 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
514 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
515 -- This ^^^ relies on the representation of Haskell heap values being
516 -- the same as in a C array.
517
518 -----------------------------------
519 -- Type Reconstruction
520 -----------------------------------
521 {-
522 Type Reconstruction is type inference done on heap closures.
523 The algorithm walks the heap generating a set of equations, which
524 are solved with syntactic unification.
525 A type reconstruction equation looks like:
526
527 <datacon reptype> = <actual heap contents>
528
529 The full equation set is generated by traversing all the subterms, starting
530 from a given term.
531
532 The only difficult part is that newtypes are only found in the lhs of equations.
533 Right hand sides are missing them. We can either (a) drop them from the lhs, or
534 (b) reconstruct them in the rhs when possible.
535
536 The function congruenceNewtypes takes a shot at (b)
537 -}
538
539
540 -- A (non-mutable) tau type containing
541 -- existentially quantified tyvars.
542 -- (since GHC type language currently does not support
543 -- existentials, we leave these variables unquantified)
544 type RttiType = Type
545
546 -- An incomplete type as stored in GHCi:
547 -- no polymorphism: no quantifiers & all tyvars are skolem.
548 type GhciType = Type
549
550
551 -- The Type Reconstruction monad
552 --------------------------------
553 type TR a = TcM a
554
555 runTR :: HscEnv -> TR a -> IO a
556 runTR hsc_env thing = do
557 mb_val <- runTR_maybe hsc_env thing
558 case mb_val of
559 Nothing -> error "unable to :print the term"
560 Just x -> return x
561
562 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
563 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
564
565 traceTR :: SDoc -> TR ()
566 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
567
568
569 -- Semantically different to recoverM in TcRnMonad
570 -- recoverM retains the errors in the first action,
571 -- whereas recoverTc here does not
572 recoverTR :: TR a -> TR a -> TR a
573 recoverTR recover thing = do
574 (_,mb_res) <- tryTcErrs thing
575 case mb_res of
576 Nothing -> recover
577 Just res -> return res
578
579 trIO :: IO a -> TR a
580 trIO = liftTcM . liftIO
581
582 liftTcM :: TcM a -> TR a
583 liftTcM = id
584
585 newVar :: Kind -> TR TcType
586 newVar = liftTcM . newFlexiTyVarTy
587
588 instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
589 -- Instantiate fresh mutable type variables from some TyVars
590 -- This function preserves the print-name, which helps error messages
591 instTyVars = liftTcM . tcInstTyVars
592
593 type RttiInstantiation = [(TcTyVar, TyVar)]
594 -- Associates the typechecker-world meta type variables
595 -- (which are mutable and may be refined), to their
596 -- debugger-world RuntimeUnk counterparts.
597 -- If the TcTyVar has not been refined by the runtime type
598 -- elaboration, then we want to turn it back into the
599 -- original RuntimeUnk
600
601 -- | Returns the instantiated type scheme ty', and the
602 -- mapping from new (instantiated) -to- old (skolem) type variables
603 instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
604 instScheme (tvs, ty)
605 = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
606 ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
607 ; return (substTy subst ty, rtti_inst) }
608
609 applyRevSubst :: RttiInstantiation -> TR ()
610 -- Apply the *reverse* substitution in-place to any un-filled-in
611 -- meta tyvars. This recovers the original debugger-world variable
612 -- unless it has been refined by new information from the heap
613 applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
614 where
615 do_pair (tc_tv, rtti_tv)
616 = do { tc_ty <- zonkTcTyVar tc_tv
617 ; case tcGetTyVar_maybe tc_ty of
618 Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
619 _ -> return () }
620
621 -- Adds a constraint of the form t1 == t2
622 -- t1 is expected to come from walking the heap
623 -- t2 is expected to come from a datacon signature
624 -- Before unification, congruenceNewtypes needs to
625 -- do its magic.
626 addConstraint :: TcType -> TcType -> TR ()
627 addConstraint actual expected = do
628 traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
629 recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
630 text "with", ppr expected]) $
631 do { (ty1, ty2) <- congruenceNewtypes actual expected
632 ; _ <- captureConstraints $ unifyType ty1 ty2
633 ; return () }
634 -- TOMDO: what about the coercion?
635 -- we should consider family instances
636
637
638 -- Type & Term reconstruction
639 ------------------------------
640 cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
641 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
642 -- we quantify existential tyvars as universal,
643 -- as this is needed to be able to manipulate
644 -- them properly
645 let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
646 sigma_old_ty = mkForAllTys old_tvs old_tau
647 traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
648 term <-
649 if null old_tvs
650 then do
651 term <- go max_depth sigma_old_ty sigma_old_ty hval
652 term' <- zonkTerm term
653 return $ fixFunDictionaries $ expandNewtypes term'
654 else do
655 (old_ty', rev_subst) <- instScheme quant_old_ty
656 my_ty <- newVar argTypeKind
657 when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
658 addConstraint my_ty old_ty')
659 term <- go max_depth my_ty sigma_old_ty hval
660 new_ty <- zonkTcType (termType term)
661 if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
662 then do
663 traceTR (text "check2 passed")
664 addConstraint new_ty old_ty'
665 applyRevSubst rev_subst
666 zterm' <- zonkTerm term
667 return ((fixFunDictionaries . expandNewtypes) zterm')
668 else do
669 traceTR (text "check2 failed" <+> parens
670 (ppr term <+> text "::" <+> ppr new_ty))
671 -- we have unsound types. Replace constructor types in
672 -- subterms with tyvars
673 zterm' <- mapTermTypeM
674 (\ty -> case tcSplitTyConApp_maybe ty of
675 Just (tc, _:_) | tc /= funTyCon
676 -> newVar argTypeKind
677 _ -> return ty)
678 term
679 zonkTerm zterm'
680 traceTR (text "Term reconstruction completed." $$
681 text "Term obtained: " <> ppr term $$
682 text "Type obtained: " <> ppr (termType term))
683 return term
684 where
685
686 go :: Int -> Type -> Type -> HValue -> TcM Term
687 -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
688
689 go max_depth _ _ _ | seq max_depth False = undefined
690 go 0 my_ty _old_ty a = do
691 traceTR (text "Gave up reconstructing a term after" <>
692 int max_depth <> text " steps")
693 clos <- trIO $ getClosureData a
694 return (Suspension (tipe clos) my_ty a Nothing)
695 go max_depth my_ty old_ty a = do
696 let monomorphic = not(isTyVarTy my_ty)
697 -- This ^^^ is a convention. The ancestor tests for
698 -- monomorphism and passes a type instead of a tv
699 clos <- trIO $ getClosureData a
700 case tipe clos of
701 -- Thunks we may want to force
702 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
703 seq a (go (pred max_depth) my_ty old_ty a)
704 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
705 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
706 -- showing '_' which is what we want.
707 Blackhole -> do traceTR (text "Following a BLACKHOLE")
708 appArr (go max_depth my_ty old_ty) (ptrs clos) 0
709 -- We always follow indirections
710 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
711 go max_depth my_ty old_ty $! (ptrs clos ! 0)
712 -- We also follow references
713 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
714 -> do
715 -- Deal with the MutVar# primitive
716 -- It does not have a constructor at all,
717 -- so we simulate the following one
718 -- MutVar# :: contents_ty -> MutVar# s contents_ty
719 traceTR (text "Following a MutVar")
720 contents_tv <- newVar liftedTypeKind
721 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
722 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
723 (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
724 contents_ty (mkTyConApp tycon [world,contents_ty])
725 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
726 x <- go (pred max_depth) contents_tv contents_ty contents
727 return (RefWrap my_ty x)
728
729 -- The interesting case
730 Constr -> do
731 traceTR (text "entering a constructor " <>
732 if monomorphic
733 then parens (text "already monomorphic: " <> ppr my_ty)
734 else Ppr.empty)
735 Right dcname <- dataConInfoPtrToName (infoPtr clos)
736 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
737 case mb_dc of
738 Nothing -> do -- This can happen for private constructors compiled -O0
739 -- where the .hi descriptor does not export them
740 -- In such case, we return a best approximation:
741 -- ignore the unpointed args, and recover the pointeds
742 -- This preserves laziness, and should be safe.
743 traceTR (text "Nothing" <+> ppr dcname)
744 let tag = showSDoc (ppr dcname)
745 vars <- replicateM (length$ elems$ ptrs clos)
746 (newVar liftedTypeKind)
747 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
748 | (i, tv) <- zip [0..] vars]
749 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
750 Just dc -> do
751 traceTR (text "Just" <+> ppr dc)
752 subTtypes <- getDataConArgTys dc my_ty
753 let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
754 subTermsP <- sequence
755 [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
756 | (i,ty) <- zip [0..] subTtypesP]
757 let unboxeds = extractUnboxed subTtypesNP clos
758 subTermsNP = zipWith Prim subTtypesNP unboxeds
759 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
760 return (Term my_ty (Right dc) a subTerms)
761
762 -- The otherwise case: can be a Thunk,AP,PAP,etc.
763 tipe_clos ->
764 return (Suspension tipe_clos my_ty a Nothing)
765
766 -- put together pointed and nonpointed subterms in the
767 -- correct order.
768 reOrderTerms _ _ [] = []
769 reOrderTerms pointed unpointed (ty:tys)
770 | isPtrType ty = ASSERT2(not(null pointed)
771 , ptext (sLit "reOrderTerms") $$
772 (ppr pointed $$ ppr unpointed))
773 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
774 | otherwise = ASSERT2(not(null unpointed)
775 , ptext (sLit "reOrderTerms") $$
776 (ppr pointed $$ ppr unpointed))
777 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
778
779 -- insert NewtypeWraps around newtypes
780 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
781 worker ty dc hval tt
782 | Just (tc, args) <- tcSplitTyConApp_maybe ty
783 , isNewTyCon tc
784 , wrapped_type <- newTyConInstRhs tc args
785 , Just dc' <- tyConSingleDataCon_maybe tc
786 , t' <- worker wrapped_type dc hval tt
787 = NewtypeWrap ty (Right dc') t'
788 | otherwise = Term ty dc hval tt
789
790
791 -- Avoid returning types where predicates have been expanded to dictionaries.
792 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
793 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
794 | otherwise = Suspension ct ty hval n
795
796
797 -- Fast, breadth-first Type reconstruction
798 ------------------------------------------
799 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
800 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
801 traceTR (text "RTTI started with initial type " <> ppr old_ty)
802 let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
803 new_ty <-
804 if null old_tvs
805 then return old_ty
806 else do
807 (old_ty', rev_subst) <- instScheme sigma_old_ty
808 my_ty <- newVar argTypeKind
809 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
810 addConstraint my_ty old_ty')
811 search (isMonomorphic `fmap` zonkTcType my_ty)
812 (\(ty,a) -> go ty a)
813 (Seq.singleton (my_ty, hval))
814 max_depth
815 new_ty <- zonkTcType my_ty
816 if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
817 then do
818 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
819 addConstraint my_ty old_ty'
820 applyRevSubst rev_subst
821 zonkRttiType new_ty
822 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
823 return old_ty
824 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
825 return new_ty
826 where
827 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
828 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
829 int max_depth <> text " steps")
830 search stop expand l d =
831 case viewl l of
832 EmptyL -> return ()
833 x :< xx -> unlessM stop $ do
834 new <- expand x
835 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
836
837 -- returns unification tasks,since we are going to want a breadth-first search
838 go :: Type -> HValue -> TR [(Type, HValue)]
839 go my_ty a = do
840 traceTR (text "go" <+> ppr my_ty)
841 clos <- trIO $ getClosureData a
842 case tipe clos of
843 Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
844 Indirection _ -> go my_ty $! (ptrs clos ! 0)
845 MutVar _ -> do
846 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
847 tv' <- newVar liftedTypeKind
848 world <- newVar liftedTypeKind
849 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
850 return [(tv', contents)]
851 Constr -> do
852 Right dcname <- dataConInfoPtrToName (infoPtr clos)
853 traceTR (text "Constr1" <+> ppr dcname)
854 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
855 case mb_dc of
856 Nothing-> do
857 -- TODO: Check this case
858 forM [0..length (elems $ ptrs clos)] $ \i -> do
859 tv <- newVar liftedTypeKind
860 return$ appArr (\e->(tv,e)) (ptrs clos) i
861
862 Just dc -> do
863 arg_tys <- getDataConArgTys dc my_ty
864 traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
865 return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
866 | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
867 _ -> return []
868
869 -- Compute the difference between a base type and the type found by RTTI
870 -- improveType <base_type> <rtti_type>
871 -- The types can contain skolem type variables, which need to be treated as normal vars.
872 -- In particular, we want them to unify with things.
873 improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
874 improveRTTIType _ base_ty new_ty
875 = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
876
877 getDataConArgTys :: DataCon -> Type -> TR [Type]
878 -- Given the result type ty of a constructor application (D a b c :: ty)
879 -- return the types of the arguments. This is RTTI-land, so 'ty' might
880 -- not be fully known. Moreover, the arg types might involve existentials;
881 -- if so, make up fresh RTTI type variables for them
882 getDataConArgTys dc con_app_ty
883 = do { (_, ex_tys, _) <- instTyVars ex_tvs
884 ; let rep_con_app_ty = repType con_app_ty
885 ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
886 Just (tc, ty_args) | dataConTyCon dc == tc
887 -> ASSERT( univ_tvs `equalLength` ty_args)
888 return ty_args
889 _ -> do { (_, ty_args, subst) <- instTyVars univ_tvs
890 ; let res_ty = substTy subst (dataConOrigResTy dc)
891 ; addConstraint rep_con_app_ty res_ty
892 ; return ty_args }
893 -- It is necessary to check dataConTyCon dc == tc
894 -- because it may be the case that tc is a recursive
895 -- newtype and tcSplitTyConApp has not removed it. In
896 -- that case, we happily give up and don't match
897 ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
898 ; return (substTys subst (dataConRepArgTys dc)) }
899 where
900 univ_tvs = dataConUnivTyVars dc
901 ex_tvs = dataConExTyVars dc
902
903 isPtrType :: Type -> Bool
904 isPtrType ty = case typePrimRep ty of
905 PtrRep -> True
906 _ -> False
907
908 -- Soundness checks
909 --------------------
910 {-
911 This is not formalized anywhere, so hold to your seats!
912 RTTI in the presence of newtypes can be a tricky and unsound business.
913
914 Example:
915 ~~~~~~~~~
916 Suppose we are doing RTTI for a partially evaluated
917 closure t, the real type of which is t :: MkT Int, for
918
919 newtype MkT a = MkT [Maybe a]
920
921 The table below shows the results of RTTI and the improvement
922 calculated for different combinations of evaluatedness and :type t.
923 Regard the two first columns as input and the next two as output.
924
925 # | t | :type t | rtti(t) | improv. | result
926 ------------------------------------------------------------
927 1 | _ | t b | a | none | OK
928 2 | _ | MkT b | a | none | OK
929 3 | _ | t Int | a | none | OK
930
931 If t is not evaluated at *all*, we are safe.
932
933 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
934 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
935 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
936
937 If a is a minimal whnf, we run into trouble. Note that
938 row 5 above does newtype enrichment on the ty_rtty parameter.
939
940 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
941 | | | b = Maybe a|
942
943 8 | (Just _:_)| MkT b | MkT a | none | OK
944 9 | (Just _:_)| t Int | FAIL | none | OK
945
946 And if t is any more evaluated than whnf, we are still in trouble.
947 Because constraints are solved in top-down order, when we reach the
948 Maybe subterm what we got is already unsound. This explains why the
949 row 9 fails to complete.
950
951 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
952 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
953
954 We can undo the failure in row 9 by leaving out the constraint
955 coming from the type signature of t (i.e., the 2nd column).
956 Note that this type information is still used
957 to calculate the improvement. But we fail
958 when trying to calculate the improvement, as there is no unifier for
959 t Int = [Maybe a] or t Int = [Maybe Int].
960
961
962 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
963
964 # | t | :type t | rtti(t) | improvement | result
965 ---------------------------------------------------------------------
966 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
967 | | | | b = Maybe a |
968
969 The checks:
970 ~~~~~~~~~~~
971 Consider a function obtainType that takes a value and a type and produces
972 the Term representation and a substitution (the improvement).
973 Assume an auxiliar rtti' function which does the actual job if recovering
974 the type, but which may produce a false type.
975
976 In pseudocode:
977
978 rtti' :: a -> IO Type -- Does not use the static type information
979
980 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
981 obtainType v old_ty = do
982 rtti_ty <- rtti' v
983 if monomorphic rtti_ty || (check rtti_ty old_ty)
984 then ...
985 else return Nothing
986 where check rtti_ty old_ty = check1 rtti_ty &&
987 check2 rtti_ty old_ty
988
989 check1 :: Type -> Bool
990 check2 :: Type -> Type -> Bool
991
992 Now, if rtti' returns a monomorphic type, we are safe.
993 If that is not the case, then we consider two conditions.
994
995
996 1. To prevent the class of unsoundness displayed by
997 rows 4 and 7 in the example: no higher kind tyvars
998 accepted.
999
1000 check1 (t a) = NO
1001 check1 (t Int) = NO
1002 check1 ([] a) = YES
1003
1004 2. To prevent the class of unsoundness shown by row 6,
1005 the rtti type should be structurally more
1006 defined than the old type we are comparing it to.
1007 check2 :: NewType -> OldType -> Bool
1008 check2 a _ = True
1009 check2 [a] a = True
1010 check2 [a] (t Int) = False
1011 check2 [a] (t a) = False -- By check1 we never reach this equation
1012 check2 [Int] a = True
1013 check2 [Int] (t Int) = True
1014 check2 [Maybe a] (t Int) = False
1015 check2 [Maybe Int] (t Int) = True
1016 check2 (Maybe [a]) (m [Int]) = False
1017 check2 (Maybe [Int]) (m [Int]) = True
1018
1019 -}
1020
1021 check1 :: QuantifiedType -> Bool
1022 check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
1023 where
1024 isHigherKind = not . null . fst . splitKindFunTys
1025
1026 check2 :: QuantifiedType -> QuantifiedType -> Bool
1027 check2 (_, rtti_ty) (_, old_ty)
1028 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1029 = case () of
1030 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1031 -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
1032 _ | Just _ <- splitAppTy_maybe old_ty
1033 -> isMonomorphicOnNonPhantomArgs rtti_ty
1034 _ -> True
1035 | otherwise = True
1036
1037 -- Dealing with newtypes
1038 --------------------------
1039 {-
1040 congruenceNewtypes does a parallel fold over two Type values,
1041 compensating for missing newtypes on both sides.
1042 This is necessary because newtypes are not present
1043 in runtime, but sometimes there is evidence available.
1044 Evidence can come from DataCon signatures or
1045 from compile-time type inference.
1046 What we are doing here is an approximation
1047 of unification modulo a set of equations derived
1048 from newtype definitions. These equations should be the
1049 same as the equality coercions generated for newtypes
1050 in System Fc. The idea is to perform a sort of rewriting,
1051 taking those equations as rules, before launching unification.
1052
1053 The caller must ensure the following.
1054 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1055 The 2nd type (rhs) comes from a DataCon type signature.
1056 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1057 in both types, but in the rhs it is restricted to the result type.
1058
1059 Note that it is very tricky to make this 'rewriting'
1060 work with the unification implemented by TcM, where
1061 substitutions are operationally inlined. The order in which
1062 constraints are unified is vital as we cannot modify
1063 anything that has been touched by a previous unification step.
1064 Therefore, congruenceNewtypes is sound only if the types
1065 recovered by the RTTI mechanism are unified Top-Down.
1066 -}
1067 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1068 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1069 where
1070 go l r
1071 -- TyVar lhs inductive case
1072 | Just tv <- getTyVar_maybe l
1073 , isTcTyVar tv
1074 , isMetaTyVar tv
1075 = recoverTR (return r) $ do
1076 Indirect ty_v <- readMetaTyVar tv
1077 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1078 ppr tv, equals, ppr ty_v]
1079 go ty_v r
1080 -- FunTy inductive case
1081 | Just (l1,l2) <- splitFunTy_maybe l
1082 , Just (r1,r2) <- splitFunTy_maybe r
1083 = do r2' <- go l2 r2
1084 r1' <- go l1 r1
1085 return (mkFunTy r1' r2')
1086 -- TyconApp Inductive case; this is the interesting bit.
1087 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1088 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1089 , tycon_l /= tycon_r
1090 = upgrade tycon_l r
1091
1092 | otherwise = return r
1093
1094 where upgrade :: TyCon -> Type -> TR Type
1095 upgrade new_tycon ty
1096 | not (isNewTyCon new_tycon) = do
1097 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1098 ppr new_tycon <> text " for " <> ppr ty)
1099 return ty
1100 | otherwise = do
1101 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1102 text " in presence of newtype evidence " <> ppr new_tycon)
1103 (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
1104 let ty' = mkTyConApp new_tycon vars
1105 _ <- liftTcM (unifyType ty (repType ty'))
1106 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1107 return ty'
1108
1109
1110 zonkTerm :: Term -> TcM Term
1111 zonkTerm = foldTermM (TermFoldM
1112 { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' ->
1113 return (Term ty' dc v tt)
1114 , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty ->
1115 return (Suspension ct ty v b)
1116 , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
1117 return$ NewtypeWrap ty' dc t
1118 , fRefWrapM = \ty t -> return RefWrap `ap`
1119 zonkRttiType ty `ap` return t
1120 , fPrimM = (return.) . Prim })
1121
1122 zonkRttiType :: TcType -> TcM Type
1123 -- Zonk the type, replacing any unbound Meta tyvars
1124 -- by skolems, safely out of Meta-tyvar-land
1125 zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
1126 where
1127 zonk_unbound_meta tv
1128 = ASSERT( isTcTyVar tv )
1129 do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
1130 -- This is where RuntimeUnks are born:
1131 -- otherwise-unconstrained unification variables are
1132 -- turned into RuntimeUnks as they leave the
1133 -- typechecker's monad
1134 ; return (mkTyVarTy tv') }
1135
1136 --------------------------------------------------------------------------------
1137 -- Restore Class predicates out of a representation type
1138 dictsView :: Type -> Type
1139 -- dictsView ty = ty
1140 dictsView (FunTy (TyConApp tc_dict args) ty)
1141 | Just c <- tyConClass_maybe tc_dict
1142 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1143 dictsView ty
1144 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1145 , Just c <- tyConClass_maybe tc_dict
1146 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1147 dictsView ty = ty
1148
1149
1150 -- Use only for RTTI types
1151 isMonomorphic :: RttiType -> Bool
1152 isMonomorphic ty = noExistentials && noUniversals
1153 where (tvs, _, ty') = tcSplitSigmaTy ty
1154 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1155 noUniversals = null tvs
1156
1157 -- Use only for RTTI types
1158 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1159 isMonomorphicOnNonPhantomArgs ty
1160 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1161 , phantom_vars <- tyConPhantomTyVars tc
1162 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1163 , tyv `notElem` phantom_vars]
1164 = all isMonomorphicOnNonPhantomArgs concrete_args
1165 | Just (ty1, ty2) <- splitFunTy_maybe ty
1166 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1167 | otherwise = isMonomorphic ty
1168
1169 tyConPhantomTyVars :: TyCon -> [TyVar]
1170 tyConPhantomTyVars tc
1171 | isAlgTyCon tc
1172 , Just dcs <- tyConDataCons_maybe tc
1173 , dc_vars <- concatMap dataConUnivTyVars dcs
1174 = tyConTyVars tc \\ dc_vars
1175 tyConPhantomTyVars _ = []
1176
1177 type QuantifiedType = ([TyVar], Type) -- Make the free type variables explicit
1178
1179 quantifyType :: Type -> QuantifiedType
1180 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1181 quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
1182
1183 unlessM :: Monad m => m Bool -> m () -> m ()
1184 unlessM condM acc = condM >>= \c -> unless c acc
1185
1186
1187 -- Strict application of f at index i
1188 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1189 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1190 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1191 case indexArray# ptrs# i# of
1192 (# e #) -> f e
1193
1194 amap' :: (t -> b) -> Array Int t -> [b]
1195 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1196 where g (I# i#) = case indexArray# arr# i# of
1197 (# e #) -> f e
1198
1199 extractUnboxed :: [Type] -> Closure -> [[Word]]
1200 extractUnboxed tt clos = go tt (nonPtrs clos)
1201 where sizeofType t = primRepSizeW (typePrimRep t)
1202 go [] _ = []
1203 go (t:tt) xx
1204 | (x, rest) <- splitAt (sizeofType t) xx
1205 = x : go tt rest