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