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