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