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