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