Changes for the new IO library, mainly base-package modules moving around
[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 hiding (null, length, index, take, drop, splitAt, reverse)
78 import Foreign
79 import System.IO.Unsafe
80
81 import System.IO
82 ---------------------------------------------
83 -- * A representation of semi evaluated Terms
84 ---------------------------------------------
85
86 data Term = Term { ty :: RttiType
87 , dc :: Either String DataCon
88 -- Carries a text representation if the datacon is
89 -- not exported by the .hi file, which is the case
90 -- for private constructors in -O0 compiled libraries
91 , val :: HValue
92 , subTerms :: [Term] }
93
94 | Prim { ty :: RttiType
95 , value :: [Word] }
96
97 | Suspension { ctype :: ClosureType
98 , ty :: RttiType
99 , val :: HValue
100 , bound_to :: Maybe Name -- Useful for printing
101 }
102 | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
103 -- newtype constructors. A NewtypeWrap is just a
104 -- made-up tag saying "heads up, there used to be
105 -- a newtype constructor here".
106 ty :: RttiType
107 , dc :: Either String DataCon
108 , wrapped_term :: Term }
109 | RefWrap { -- The contents of a reference
110 ty :: RttiType
111 , wrapped_term :: Term }
112
113 isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
114 isTerm Term{} = True
115 isTerm _ = False
116 isSuspension Suspension{} = True
117 isSuspension _ = False
118 isPrim Prim{} = True
119 isPrim _ = False
120 isNewtypeWrap NewtypeWrap{} = True
121 isNewtypeWrap _ = False
122
123 isFun Suspension{ctype=Fun} = True
124 isFun _ = False
125
126 isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
127 isFunLike _ = False
128
129 termType :: Term -> RttiType
130 termType t = ty t
131
132 isFullyEvaluatedTerm :: Term -> Bool
133 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
134 isFullyEvaluatedTerm Prim {} = True
135 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
136 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
137 isFullyEvaluatedTerm _ = False
138
139 instance Outputable (Term) where
140 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
141 | otherwise = panic "Outputable Term instance"
142
143 -------------------------------------------------------------------------
144 -- Runtime Closure Datatype and functions for retrieving closure related stuff
145 -------------------------------------------------------------------------
146 data ClosureType = Constr
147 | Fun
148 | Thunk Int
149 | ThunkSelector
150 | Blackhole
151 | AP
152 | PAP
153 | Indirection Int
154 | MutVar Int
155 | MVar Int
156 | Other Int
157 deriving (Show, Eq)
158
159 data Closure = Closure { tipe :: ClosureType
160 , infoPtr :: Ptr ()
161 , infoTable :: StgInfoTable
162 , ptrs :: Array Int HValue
163 , nonPtrs :: [Word]
164 }
165
166 instance Outputable ClosureType where
167 ppr = text . show
168
169 #include "../includes/ClosureTypes.h"
170
171 aP_CODE, pAP_CODE :: Int
172 aP_CODE = AP
173 pAP_CODE = PAP
174 #undef AP
175 #undef PAP
176
177 getClosureData :: a -> IO Closure
178 getClosureData a =
179 case unpackClosure# a of
180 (# iptr, ptrs, nptrs #) -> do
181 let iptr'
182 | ghciTablesNextToCode =
183 Ptr iptr
184 | otherwise =
185 -- the info pointer we get back from unpackClosure#
186 -- is to the beginning of the standard info table,
187 -- but the Storable instance for info tables takes
188 -- into account the extra entry pointer when
189 -- !ghciTablesNextToCode, so we must adjust here:
190 Ptr iptr `plusPtr` negate wORD_SIZE
191 itbl <- peek iptr'
192 let tipe = readCType (BCI.tipe itbl)
193 elems = fromIntegral (BCI.ptrs itbl)
194 ptrsList = Array 0 (elems - 1) elems ptrs
195 nptrs_data = [W# (indexWordArray# nptrs i)
196 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
197 ASSERT(elems >= 0) return ()
198 ptrsList `seq`
199 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
200
201 readCType :: Integral a => a -> ClosureType
202 readCType i
203 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
204 | i >= FUN && i <= FUN_STATIC = Fun
205 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
206 | i == THUNK_SELECTOR = ThunkSelector
207 | i == BLACKHOLE = Blackhole
208 | i >= IND && i <= IND_STATIC = Indirection i'
209 | i' == aP_CODE = AP
210 | i == AP_STACK = AP
211 | i' == pAP_CODE = PAP
212 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
213 | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
214 | otherwise = Other i'
215 where i' = fromIntegral i
216
217 isConstr, isIndirection, isThunk :: ClosureType -> Bool
218 isConstr Constr = True
219 isConstr _ = False
220
221 isIndirection (Indirection _) = True
222 isIndirection _ = False
223
224 isThunk (Thunk _) = True
225 isThunk ThunkSelector = True
226 isThunk AP = True
227 isThunk _ = False
228
229 isFullyEvaluated :: a -> IO Bool
230 isFullyEvaluated a = do
231 closure <- getClosureData a
232 case tipe closure of
233 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
234 return$ and are_subs_evaluated
235 _ -> return False
236 where amapM f = sequence . amap' f
237
238 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
239 {-
240 unsafeDeepSeq :: a -> b -> b
241 unsafeDeepSeq = unsafeDeepSeq1 2
242 where unsafeDeepSeq1 0 a b = seq a $! b
243 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
244 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
245 -- | unsafePerformIO (isFullyEvaluated a) = b
246 | otherwise = case unsafePerformIO (getClosureData a) of
247 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
248 where tipe = unsafePerformIO (getClosureType a)
249 -}
250
251 -----------------------------------
252 -- * Traversals for Terms
253 -----------------------------------
254 type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
255
256 data TermFold a = TermFold { fTerm :: TermProcessor a a
257 , fPrim :: RttiType -> [Word] -> a
258 , fSuspension :: ClosureType -> RttiType -> HValue
259 -> Maybe Name -> a
260 , fNewtypeWrap :: RttiType -> Either String DataCon
261 -> a -> a
262 , fRefWrap :: RttiType -> a -> a
263 }
264
265
266 data TermFoldM m a =
267 TermFoldM {fTermM :: TermProcessor a (m a)
268 , fPrimM :: RttiType -> [Word] -> m a
269 , fSuspensionM :: ClosureType -> RttiType -> HValue
270 -> Maybe Name -> m a
271 , fNewtypeWrapM :: RttiType -> Either String DataCon
272 -> a -> m a
273 , fRefWrapM :: RttiType -> a -> m a
274 }
275
276 foldTerm :: TermFold a -> Term -> a
277 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
278 foldTerm tf (Prim ty v ) = fPrim tf ty v
279 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
280 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
281 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
282
283
284 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
285 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
286 foldTermM tf (Prim ty v ) = fPrimM tf ty v
287 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
288 foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
289 foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
290
291 idTermFold :: TermFold Term
292 idTermFold = TermFold {
293 fTerm = Term,
294 fPrim = Prim,
295 fSuspension = Suspension,
296 fNewtypeWrap = NewtypeWrap,
297 fRefWrap = RefWrap
298 }
299
300 mapTermType :: (RttiType -> Type) -> Term -> Term
301 mapTermType f = foldTerm idTermFold {
302 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
303 fSuspension = \ct ty hval n ->
304 Suspension ct (f ty) hval n,
305 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
306 fRefWrap = \ty t -> RefWrap (f ty) t}
307
308 mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
309 mapTermTypeM f = foldTermM TermFoldM {
310 fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
311 fPrimM = (return.) . Prim,
312 fSuspensionM = \ct ty hval n ->
313 f ty >>= \ty' -> return $ Suspension ct ty' hval n,
314 fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
315 fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
316
317 termTyVars :: Term -> TyVarSet
318 termTyVars = foldTerm TermFold {
319 fTerm = \ty _ _ tt ->
320 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
321 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
322 fPrim = \ _ _ -> emptyVarEnv,
323 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
324 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
325 where concatVarEnv = foldr plusVarEnv emptyVarEnv
326
327 ----------------------------------
328 -- Pretty printing of terms
329 ----------------------------------
330
331 type Precedence = Int
332 type TermPrinter = Precedence -> Term -> SDoc
333 type TermPrinterM m = Precedence -> Term -> m SDoc
334
335 app_prec,cons_prec, max_prec ::Int
336 max_prec = 10
337 app_prec = max_prec
338 cons_prec = 5 -- TODO Extract this info from GHC itself
339
340 pprTerm :: TermPrinter -> TermPrinter
341 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
342 pprTerm _ _ _ = panic "pprTerm"
343
344 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
345 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
346
347 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
348 tt_docs <- mapM (y app_prec) tt
349 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
350
351 ppr_termM y p Term{dc=Right dc, subTerms=tt}
352 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
353 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
354 <+> hsep (map (ppr_term1 True) tt)
355 -} -- TODO Printing infix constructors properly
356 | null tt = return$ ppr dc
357 | otherwise = do
358 tt_docs <- mapM (y app_prec) tt
359 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
360
361 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
362 ppr_termM y p RefWrap{wrapped_term=t} = do
363 contents <- y app_prec t
364 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
365 -- The constructor name is wired in here ^^^ for the sake of simplicity.
366 -- I don't think mutvars are going to change in a near future.
367 -- In any case this is solely a presentation matter: MutVar# is
368 -- a datatype with no constructors, implemented by the RTS
369 -- (hence there is no way to obtain a datacon and print it).
370 ppr_termM _ _ t = ppr_termM1 t
371
372
373 ppr_termM1 :: Monad m => Term -> m SDoc
374 ppr_termM1 Prim{value=words, ty=ty} =
375 return$ text$ repPrim (tyConAppTyCon ty) words
376 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
377 return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
378 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
379 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
380 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
381 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
382 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
383 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
384
385 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
386 | Just (tc,_) <- tcSplitTyConApp_maybe ty
387 , ASSERT(isNewTyCon tc) True
388 , Just new_dc <- tyConSingleDataCon_maybe tc = do
389 real_term <- y max_prec t
390 return$ cparen (p >= app_prec) (ppr new_dc <+> real_term)
391 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
392
393 -------------------------------------------------------
394 -- Custom Term Pretty Printers
395 -------------------------------------------------------
396
397 -- We can want to customize the representation of a
398 -- term depending on its type.
399 -- However, note that custom printers have to work with
400 -- type representations, instead of directly with types.
401 -- We cannot use type classes here, unless we employ some
402 -- typerep trickery (e.g. Weirich's RepLib tricks),
403 -- which I didn't. Therefore, this code replicates a lot
404 -- of what type classes provide for free.
405
406 type CustomTermPrinter m = TermPrinterM m
407 -> [Precedence -> Term -> (m (Maybe SDoc))]
408
409 -- | Takes a list of custom printers with a explicit recursion knot and a term,
410 -- and returns the output of the first succesful printer, or the default printer
411 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
412 cPprTerm printers_ = go 0 where
413 printers = printers_ go
414 go prec t = do
415 let default_ = Just `liftM` pprTermM go prec t
416 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
417 Just doc <- firstJustM mb_customDocs
418 return$ cparen (prec>app_prec+1) doc
419
420 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
421 firstJustM [] = return Nothing
422
423 -- Default set of custom printers. Note that the recursion knot is explicit
424 cPprTermBase :: Monad m => CustomTermPrinter m
425 cPprTermBase y =
426 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
427 . mapM (y (-1))
428 . subTerms)
429 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
430 (\ p Term{subTerms=[h,t]} -> doList p h t)
431 , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
432 , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
433 , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
434 , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
435 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
436 ]
437 where ifTerm pred f prec t@Term{}
438 | pred t = Just `liftM` f prec t
439 ifTerm _ _ _ _ = return Nothing
440
441 isIntegerTy ty = fromMaybe False $ do
442 (tc,_) <- tcSplitTyConApp_maybe ty
443 return (tyConName tc == integerTyConName)
444
445 isTupleTy ty = fromMaybe False $ do
446 (tc,_) <- tcSplitTyConApp_maybe ty
447 return (isBoxedTupleTyCon tc)
448
449 isTyCon a_tc ty = fromMaybe False $ do
450 (tc,_) <- tcSplitTyConApp_maybe ty
451 return (a_tc == tc)
452
453 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
454
455 --Note pprinting of list terms is not lazy
456 doList p h t = do
457 let elems = h : getListTerms t
458 isConsLast = not(termType(last elems) `coreEqType` termType h)
459 print_elems <- mapM (y cons_prec) elems
460 return$ if isConsLast
461 then cparen (p >= cons_prec)
462 . pprDeeperList fsep
463 . punctuate (space<>colon)
464 $ print_elems
465 else brackets (pprDeeperList fcat$
466 punctuate comma print_elems)
467
468 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
469 getListTerms Term{subTerms=[]} = []
470 getListTerms t@Suspension{} = [t]
471 getListTerms t = pprPanic "getListTerms" (ppr t)
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 . liftM mkTyVarTy . newBoxyTyVar
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 (getLIE . uncurry boxyUnify) >> 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 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
659 -- force blackholes, because it would almost certainly result in deadlock,
660 -- and showing the '_' is more useful.
661 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
662 seq a (go (pred max_depth) my_ty old_ty a)
663 -- We always follow indirections
664 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
665 go max_depth my_ty old_ty $! (ptrs clos ! 0)
666 -- We also follow references
667 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
668 -> do
669 -- Deal with the MutVar# primitive
670 -- It does not have a constructor at all,
671 -- so we simulate the following one
672 -- MutVar# :: contents_ty -> MutVar# s contents_ty
673 traceTR (text "Following a MutVar")
674 contents_tv <- newVar liftedTypeKind
675 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
676 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
677 (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
678 contents_ty (mkTyConApp tycon [world,contents_ty])
679 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
680 x <- go (pred max_depth) contents_tv contents_ty contents
681 return (RefWrap my_ty x)
682
683 -- The interesting case
684 Constr -> do
685 traceTR (text "entering a constructor " <>
686 if monomorphic
687 then parens (text "already monomorphic: " <> ppr my_ty)
688 else Outputable.empty)
689 Right dcname <- dataConInfoPtrToName (infoPtr clos)
690 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
691 case mb_dc of
692 Nothing -> do -- This can happen for private constructors compiled -O0
693 -- where the .hi descriptor does not export them
694 -- In such case, we return a best approximation:
695 -- ignore the unpointed args, and recover the pointeds
696 -- This preserves laziness, and should be safe.
697 let tag = showSDoc (ppr dcname)
698 vars <- replicateM (length$ elems$ ptrs clos)
699 (newVar (liftedTypeKind))
700 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
701 | (i, tv) <- zip [0..] vars]
702 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
703 Just dc -> do
704 let subTtypes = matchSubTypes dc old_ty
705 subTermTvs <- mapMif (not . isMonomorphic)
706 (\t -> newVar (typeKind t))
707 subTtypes
708 let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
709 || isRefType ty)
710 (zip subTtypes subTermTvs)
711 (subTtypesP, subTermTvsP ) = unzip subTermsP
712 (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
713
714 -- When we already have all the information, avoid solving
715 -- unnecessary constraints. Propagation of type information
716 -- to subterms is already being done via matching.
717 when (not monomorphic) $ do
718 let myType = mkFunTys subTermTvs my_ty
719 (signatureType,_) <- instScheme (mydataConType dc)
720 -- It is vital for newtype reconstruction that the unification step
721 -- is done right here, _before_ the subterms are RTTI reconstructed
722 addConstraint myType signatureType
723 subTermsP <- sequence
724 [ appArr (go (pred max_depth) tv t) (ptrs clos) i
725 | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
726 let unboxeds = extractUnboxed subTtypesNP clos
727 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
728 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
729 return (Term my_ty (Right dc) a subTerms)
730 -- The otherwise case: can be a Thunk,AP,PAP,etc.
731 tipe_clos ->
732 return (Suspension tipe_clos my_ty a Nothing)
733
734 matchSubTypes dc ty
735 | ty' <- repType ty -- look through newtypes
736 , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
737 , dc `elem` tyConDataCons tc
738 -- It is necessary to check that dc is actually a constructor for tycon tc,
739 -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
740 -- has not removed it. In that case, we happily give up and don't match
741 = myDataConInstArgTys dc ty_args
742 | otherwise = dataConRepArgTys dc
743
744 -- put together pointed and nonpointed subterms in the
745 -- correct order.
746 reOrderTerms _ _ [] = []
747 reOrderTerms pointed unpointed (ty:tys)
748 | isLifted ty || isRefType ty
749 = ASSERT2(not(null pointed)
750 , ptext (sLit "reOrderTerms") $$
751 (ppr pointed $$ ppr unpointed))
752 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
753 | otherwise = ASSERT2(not(null unpointed)
754 , ptext (sLit "reOrderTerms") $$
755 (ppr pointed $$ ppr unpointed))
756 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
757
758 -- insert NewtypeWraps around newtypes
759 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
760 worker ty dc hval tt
761 | Just (tc, args) <- tcSplitTyConApp_maybe ty
762 , isNewTyCon tc
763 , wrapped_type <- newTyConInstRhs tc args
764 , Just dc' <- tyConSingleDataCon_maybe tc
765 , t' <- worker wrapped_type dc hval tt
766 = NewtypeWrap ty (Right dc') t'
767 | otherwise = Term ty dc hval tt
768
769
770 -- Avoid returning types where predicates have been expanded to dictionaries.
771 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
772 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
773 | otherwise = Suspension ct ty hval n
774
775
776 -- Fast, breadth-first Type reconstruction
777 ------------------------------------------
778 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
779 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
780 traceTR (text "RTTI started with initial type " <> ppr old_ty)
781 let sigma_old_ty = sigmaType old_ty
782 new_ty <-
783 if isMonomorphic sigma_old_ty
784 then return old_ty
785 else do
786 (old_ty', rev_subst) <- instScheme sigma_old_ty
787 my_ty <- newVar argTypeKind
788 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
789 addConstraint my_ty old_ty')
790 search (isMonomorphic `fmap` zonkTcType my_ty)
791 (\(ty,a) -> go ty a)
792 (Seq.singleton (my_ty, hval))
793 max_depth
794 new_ty <- zonkTcType my_ty
795 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
796 then do
797 traceTR (text "check2 passed")
798 addConstraint my_ty old_ty'
799 new_ty' <- zonkTcType my_ty
800 return (substTy rev_subst new_ty')
801 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
802 return old_ty
803 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
804 return new_ty
805 where
806 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
807 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
808 int max_depth <> text " steps")
809 search stop expand l d =
810 case viewl l of
811 EmptyL -> return ()
812 x :< xx -> unlessM stop $ do
813 new <- expand x
814 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
815
816 -- returns unification tasks,since we are going to want a breadth-first search
817 go :: Type -> HValue -> TR [(Type, HValue)]
818 go my_ty a = do
819 clos <- trIO $ getClosureData a
820 case tipe clos of
821 Indirection _ -> go my_ty $! (ptrs clos ! 0)
822 MutVar _ -> do
823 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
824 tv' <- newVar liftedTypeKind
825 world <- newVar liftedTypeKind
826 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
827 return [(tv', contents)]
828 Constr -> do
829 Right dcname <- dataConInfoPtrToName (infoPtr clos)
830 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
831 case mb_dc of
832 Nothing-> do
833 -- TODO: Check this case
834 forM [0..length (elems $ ptrs clos)] $ \i -> do
835 tv <- newVar liftedTypeKind
836 return$ appArr (\e->(tv,e)) (ptrs clos) i
837
838 Just dc -> do
839 subTtypes <- mapMif (not . isMonomorphic)
840 (\t -> newVar (typeKind t))
841 (dataConRepArgTys dc)
842
843 -- It is vital for newtype reconstruction that the unification step
844 -- is done right here, _before_ the subterms are RTTI reconstructed
845 let myType = mkFunTys subTtypes my_ty
846 (signatureType,_) <- instScheme(mydataConType dc)
847 addConstraint myType signatureType
848 return $ [ appArr (\e->(t,e)) (ptrs clos) i
849 | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
850 _ -> return []
851
852 -- Compute the difference between a base type and the type found by RTTI
853 -- improveType <base_type> <rtti_type>
854 -- The types can contain skolem type variables, which need to be treated as normal vars.
855 -- In particular, we want them to unify with things.
856 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
857 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
858 traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty])
859 (ty_tvs, _, _) <- tcInstType return ty
860 (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
861 (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
862 getLIE(boxyUnify rtti_ty' ty')
863 tvs1_contents <- zonkTcTyVars ty_tvs'
864 let subst = (uncurry zipTopTvSubst . unzip)
865 [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
866 , getTyVar_maybe ty /= Just tv
867 --, not(isTyVarTy ty)
868 ]
869 return subst
870 where ty = sigmaType _ty
871
872 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
873 myDataConInstArgTys dc args
874 | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
875 | otherwise = dataConRepArgTys dc
876
877 mydataConType :: DataCon -> Type
878 -- ^ Custom version of DataCon.dataConUserType where we
879 -- - remove the equality constraints
880 -- - use the representation types for arguments, including dictionaries
881 -- - keep the original result type
882 mydataConType dc
883 = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
884 mkFunTys arg_tys $
885 res_ty
886 where univ_tvs = dataConUnivTyVars dc
887 ex_tvs = dataConExTyVars dc
888 eq_spec = dataConEqSpec dc
889 arg_tys = [case a of
890 PredTy p -> predTypeRep p
891 _ -> a
892 | a <- dataConRepArgTys dc]
893 res_ty = dataConOrigResTy dc
894
895 isRefType :: Type -> Bool
896 isRefType ty
897 | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
898 | otherwise = False
899 where ty'= repType ty
900
901 isRefTyCon :: TyCon -> Bool
902 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
903
904 -- Soundness checks
905 --------------------
906 {-
907 This is not formalized anywhere, so hold to your seats!
908 RTTI in the presence of newtypes can be a tricky and unsound business.
909
910 Example:
911 ~~~~~~~~~
912 Suppose we are doing RTTI for a partially evaluated
913 closure t, the real type of which is t :: MkT Int, for
914
915 newtype MkT a = MkT [Maybe a]
916
917 The table below shows the results of RTTI and the improvement
918 calculated for different combinations of evaluatedness and :type t.
919 Regard the two first columns as input and the next two as output.
920
921 # | t | :type t | rtti(t) | improv. | result
922 ------------------------------------------------------------
923 1 | _ | t b | a | none | OK
924 2 | _ | MkT b | a | none | OK
925 3 | _ | t Int | a | none | OK
926
927 If t is not evaluated at *all*, we are safe.
928
929 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
930 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
931 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
932
933 If a is a minimal whnf, we run into trouble. Note that
934 row 5 above does newtype enrichment on the ty_rtty parameter.
935
936 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
937 | | | b = Maybe a|
938
939 8 | (Just _:_)| MkT b | MkT a | none | OK
940 9 | (Just _:_)| t Int | FAIL | none | OK
941
942 And if t is any more evaluated than whnf, we are still in trouble.
943 Because constraints are solved in top-down order, when we reach the
944 Maybe subterm what we got is already unsound. This explains why the
945 row 9 fails to complete.
946
947 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
948 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
949
950 We can undo the failure in row 9 by leaving out the constraint
951 coming from the type signature of t (i.e., the 2nd column).
952 Note that this type information is still used
953 to calculate the improvement. But we fail
954 when trying to calculate the improvement, as there is no unifier for
955 t Int = [Maybe a] or t Int = [Maybe Int].
956
957
958 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
959
960 # | t | :type t | rtti(t) | improvement | result
961 ---------------------------------------------------------------------
962 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
963 | | | | b = Maybe a |
964
965 The checks:
966 ~~~~~~~~~~~
967 Consider a function obtainType that takes a value and a type and produces
968 the Term representation and a substitution (the improvement).
969 Assume an auxiliar rtti' function which does the actual job if recovering
970 the type, but which may produce a false type.
971
972 In pseudocode:
973
974 rtti' :: a -> IO Type -- Does not use the static type information
975
976 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
977 obtainType v old_ty = do
978 rtti_ty <- rtti' v
979 if monomorphic rtti_ty || (check rtti_ty old_ty)
980 then ...
981 else return Nothing
982 where check rtti_ty old_ty = check1 rtti_ty &&
983 check2 rtti_ty old_ty
984
985 check1 :: Type -> Bool
986 check2 :: Type -> Type -> Bool
987
988 Now, if rtti' returns a monomorphic type, we are safe.
989 If that is not the case, then we consider two conditions.
990
991
992 1. To prevent the class of unsoundness displayed by
993 rows 4 and 7 in the example: no higher kind tyvars
994 accepted.
995
996 check1 (t a) = NO
997 check1 (t Int) = NO
998 check1 ([] a) = YES
999
1000 2. To prevent the class of unsoundness shown by row 6,
1001 the rtti type should be structurally more
1002 defined than the old type we are comparing it to.
1003 check2 :: NewType -> OldType -> Bool
1004 check2 a _ = True
1005 check2 [a] a = True
1006 check2 [a] (t Int) = False
1007 check2 [a] (t a) = False -- By check1 we never reach this equation
1008 check2 [Int] a = True
1009 check2 [Int] (t Int) = True
1010 check2 [Maybe a] (t Int) = False
1011 check2 [Maybe Int] (t Int) = True
1012 check2 (Maybe [a]) (m [Int]) = False
1013 check2 (Maybe [Int]) (m [Int]) = True
1014
1015 -}
1016
1017 check1 :: Type -> Bool
1018 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
1019 where
1020 isHigherKind = not . null . fst . splitKindFunTys
1021
1022 check2 :: Type -> Type -> Bool
1023 check2 sigma_rtti_ty sigma_old_ty
1024 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1025 = case () of
1026 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1027 -> and$ zipWith check2 rttis olds
1028 _ | Just _ <- splitAppTy_maybe old_ty
1029 -> isMonomorphicOnNonPhantomArgs rtti_ty
1030 _ -> True
1031 | otherwise = True
1032 where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
1033 (_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty
1034
1035
1036 -- Dealing with newtypes
1037 --------------------------
1038 {-
1039 congruenceNewtypes does a parallel fold over two Type values,
1040 compensating for missing newtypes on both sides.
1041 This is necessary because newtypes are not present
1042 in runtime, but sometimes there is evidence available.
1043 Evidence can come from DataCon signatures or
1044 from compile-time type inference.
1045 What we are doing here is an approximation
1046 of unification modulo a set of equations derived
1047 from newtype definitions. These equations should be the
1048 same as the equality coercions generated for newtypes
1049 in System Fc. The idea is to perform a sort of rewriting,
1050 taking those equations as rules, before launching unification.
1051
1052 The caller must ensure the following.
1053 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1054 The 2nd type (rhs) comes from a DataCon type signature.
1055 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1056 in both types, but in the rhs it is restricted to the result type.
1057
1058 Note that it is very tricky to make this 'rewriting'
1059 work with the unification implemented by TcM, where
1060 substitutions are operationally inlined. The order in which
1061 constraints are unified is vital as we cannot modify
1062 anything that has been touched by a previous unification step.
1063 Therefore, congruenceNewtypes is sound only if the types
1064 recovered by the RTTI mechanism are unified Top-Down.
1065 -}
1066 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1067 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1068 where
1069 go l r
1070 -- TyVar lhs inductive case
1071 | Just tv <- getTyVar_maybe l
1072 = recoverTR (return r) $ do
1073 Indirect ty_v <- readMetaTyVar tv
1074 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1075 ppr tv, equals, ppr ty_v]
1076 go ty_v r
1077 -- FunTy inductive case
1078 | Just (l1,l2) <- splitFunTy_maybe l
1079 , Just (r1,r2) <- splitFunTy_maybe r
1080 = do r2' <- go l2 r2
1081 r1' <- go l1 r1
1082 return (mkFunTy r1' r2')
1083 -- TyconApp Inductive case; this is the interesting bit.
1084 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1085 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1086 , tycon_l /= tycon_r
1087 = upgrade tycon_l r
1088
1089 | otherwise = return r
1090
1091 where upgrade :: TyCon -> Type -> TR Type
1092 upgrade new_tycon ty
1093 | not (isNewTyCon new_tycon) = do
1094 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1095 ppr new_tycon <> text " for " <> ppr ty)
1096 return ty
1097 | otherwise = do
1098 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1099 text " in presence of newtype evidence " <> ppr new_tycon)
1100 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1101 let ty' = mkTyConApp new_tycon vars
1102 liftTcM (boxyUnify ty (repType ty'))
1103 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1104 return ty'
1105
1106
1107 zonkTerm :: Term -> TcM Term
1108 zonkTerm = foldTermM TermFoldM{
1109 fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' ->
1110 return (Term ty' dc v tt)
1111 ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1112 return (Suspension ct ty v b)
1113 ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1114 return$ NewtypeWrap ty' dc t
1115 ,fRefWrapM = \ty t ->
1116 return RefWrap `ap` zonkTcType ty `ap` return t
1117 ,fPrimM = (return.) . Prim
1118 }
1119
1120 --------------------------------------------------------------------------------
1121 -- Restore Class predicates out of a representation type
1122 dictsView :: Type -> Type
1123 -- dictsView ty = ty
1124 dictsView (FunTy (TyConApp tc_dict args) ty)
1125 | Just c <- tyConClass_maybe tc_dict
1126 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1127 dictsView ty
1128 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1129 , Just c <- tyConClass_maybe tc_dict
1130 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1131 dictsView ty = ty
1132
1133
1134 -- Use only for RTTI types
1135 isMonomorphic :: RttiType -> Bool
1136 isMonomorphic ty = noExistentials && noUniversals
1137 where (tvs, _, ty') = tcSplitSigmaTy ty
1138 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1139 noUniversals = null tvs
1140
1141 -- Use only for RTTI types
1142 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1143 isMonomorphicOnNonPhantomArgs ty
1144 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1145 , phantom_vars <- tyConPhantomTyVars tc
1146 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1147 , tyv `notElem` phantom_vars]
1148 = all isMonomorphicOnNonPhantomArgs concrete_args
1149 | Just (ty1, ty2) <- splitFunTy_maybe ty
1150 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1151 | otherwise = isMonomorphic ty
1152
1153 tyConPhantomTyVars :: TyCon -> [TyVar]
1154 tyConPhantomTyVars tc
1155 | isAlgTyCon tc
1156 , Just dcs <- tyConDataCons_maybe tc
1157 , dc_vars <- concatMap dataConUnivTyVars dcs
1158 = tyConTyVars tc \\ dc_vars
1159 tyConPhantomTyVars _ = []
1160
1161 -- Is this defined elsewhere?
1162 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1163 sigmaType :: Type -> Type
1164 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1165
1166
1167 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1168 mapMif pred f xx = sequence $ mapMif_ pred f xx
1169 where
1170 mapMif_ _ _ [] = []
1171 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1172
1173 unlessM :: Monad m => m Bool -> m () -> m ()
1174 unlessM condM acc = condM >>= \c -> unless c acc
1175
1176
1177 -- Strict application of f at index i
1178 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1179 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1180 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1181 case indexArray# ptrs# i# of
1182 (# e #) -> f e
1183
1184 amap' :: (t -> b) -> Array Int t -> [b]
1185 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1186 where g (I# i#) = case indexArray# arr# i# of
1187 (# e #) -> f e
1188
1189
1190 isLifted :: Type -> Bool
1191 isLifted = not . isUnLiftedType
1192
1193 extractUnboxed :: [Type] -> Closure -> [[Word]]
1194 extractUnboxed tt clos = go tt (nonPtrs clos)
1195 where sizeofType t
1196 | Just (tycon,_) <- tcSplitTyConApp_maybe t
1197 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1198 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1199 go [] _ = []
1200 go (t:tt) xx
1201 | (x, rest) <- splitAt (sizeofType t) xx
1202 = x : go tt rest
1203
1204 sizeofTyCon :: TyCon -> Int -- in *words*
1205 sizeofTyCon = primRepSizeW . tyConPrimRep
1206
1207
1208 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1209 (f |.| g) x = f x || g x