add final newlines
[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 $ fsep [text "add constraint:", 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. Term obtained: " <> ppr term)
634 return term
635 where
636 go :: Int -> Type -> Type -> HValue -> TcM Term
637 go max_depth _ _ _ | seq max_depth False = undefined
638 go 0 my_ty _old_ty a = do
639 clos <- trIO $ getClosureData a
640 return (Suspension (tipe clos) my_ty a Nothing)
641 go max_depth my_ty old_ty a = do
642 let monomorphic = not(isTyVarTy my_ty)
643 -- This ^^^ is a convention. The ancestor tests for
644 -- monomorphism and passes a type instead of a tv
645 clos <- trIO $ getClosureData a
646 case tipe clos of
647 -- Thunks we may want to force
648 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
649 -- force blackholes, because it would almost certainly result in deadlock,
650 -- and showing the '_' is more useful.
651 t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
652 seq a (go (pred max_depth) my_ty old_ty a)
653 -- We always follow indirections
654 Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
655 go max_depth my_ty old_ty $! (ptrs clos ! 0)
656 -- We also follow references
657 MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
658 -> do
659 -- Deal with the MutVar# primitive
660 -- It does not have a constructor at all,
661 -- so we simulate the following one
662 -- MutVar# :: contents_ty -> MutVar# s contents_ty
663 traceTR (text "Following a MutVar")
664 contents_tv <- newVar liftedTypeKind
665 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
666 ASSERT(isUnliftedTypeKind $ typeKind my_ty) return ()
667 (mutvar_ty,_) <- instScheme $ sigmaType $ mkFunTy
668 contents_ty (mkTyConApp tycon [world,contents_ty])
669 addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
670 x <- go (pred max_depth) contents_tv contents_ty contents
671 return (RefWrap my_ty x)
672
673 -- The interesting case
674 Constr -> do
675 traceTR (text "entering a constructor")
676 Right dcname <- dataConInfoPtrToName (infoPtr clos)
677 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
678 case mb_dc of
679 Nothing -> do -- This can happen for private constructors compiled -O0
680 -- where the .hi descriptor does not export them
681 -- In such case, we return a best approximation:
682 -- ignore the unpointed args, and recover the pointeds
683 -- This preserves laziness, and should be safe.
684 let tag = showSDoc (ppr dcname)
685 vars <- replicateM (length$ elems$ ptrs clos)
686 (newVar (liftedTypeKind))
687 subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
688 | (i, tv) <- zip [0..] vars]
689 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
690 Just dc -> do
691 let subTtypes = matchSubTypes dc old_ty
692 (subTtypesP, subTtypesNP) = partition (isLifted |.| isRefType) subTtypes
693 subTermTvs <- mapMif (not . isMonomorphic)
694 (\t -> newVar (typeKind t))
695 subTtypes
696 -- It is vital for newtype reconstruction that the unification step
697 -- is done right here, _before_ the subterms are RTTI reconstructed
698 when (not monomorphic) $ do
699
700 -- When we already have all the information, avoid solving
701 -- unnecessary constraints. Propagation of type information
702 -- to subterms is already being done via matching.
703 let myType = mkFunTys subTermTvs my_ty
704 (signatureType,_) <- instScheme (rttiView $ dataConUserType dc)
705 addConstraint myType signatureType
706 subTermsP <- sequence
707 [ appArr (go (pred max_depth) tv t) (ptrs clos) i
708 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
709 let unboxeds = extractUnboxed subTtypesNP clos
710 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
711 subTerms = reOrderTerms subTermsP subTermsNP subTtypes
712 return (Term my_ty (Right dc) a subTerms)
713 -- The otherwise case: can be a Thunk,AP,PAP,etc.
714 tipe_clos ->
715 return (Suspension tipe_clos my_ty a Nothing)
716
717 matchSubTypes dc ty
718 | ty' <- repType ty -- look through newtypes
719 , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
720 , dc `elem` tyConDataCons tc
721 -- It is necessary to check that dc is actually a constructor for tycon tc,
722 -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
723 -- has not removed it. In that case, we happily give up and don't match
724 = myDataConInstArgTys dc ty_args
725 | otherwise = dataConRepArgTys dc
726
727 -- put together pointed and nonpointed subterms in the
728 -- correct order.
729 reOrderTerms _ _ [] = []
730 reOrderTerms pointed unpointed (ty:tys)
731 | isLifted ty || isRefType ty
732 = ASSERT2(not(null pointed)
733 , ptext (sLit "reOrderTerms") $$
734 (ppr pointed $$ ppr unpointed))
735 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
736 | otherwise = ASSERT2(not(null unpointed)
737 , ptext (sLit "Reorderterms") $$
738 (ppr pointed $$ ppr unpointed))
739 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
740
741 -- insert NewtypeWraps around newtypes
742 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
743 worker ty dc hval tt
744 | Just (tc, args) <- tcSplitTyConApp_maybe ty
745 , isNewTyCon tc
746 , wrapped_type <- newTyConInstRhs tc args
747 , Just dc' <- tyConSingleDataCon_maybe tc
748 , t' <- worker wrapped_type dc hval tt
749 = NewtypeWrap ty (Right dc') t'
750 | otherwise = Term ty dc hval tt
751
752
753 -- Avoid returning types where predicates have been expanded to dictionaries.
754 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
755 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
756 | otherwise = Suspension ct ty hval n
757
758
759 -- Fast, breadth-first Type reconstruction
760 ------------------------------------------
761 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
762 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
763 traceTR (text "RTTI started with initial type " <> ppr old_ty)
764 let sigma_old_ty = sigmaType old_ty
765 new_ty <-
766 if isMonomorphic sigma_old_ty
767 then return old_ty
768 else do
769 (old_ty', rev_subst) <- instScheme sigma_old_ty
770 my_ty <- newVar argTypeKind
771 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
772 addConstraint my_ty old_ty')
773 search (isMonomorphic `fmap` zonkTcType my_ty)
774 (\(ty,a) -> go ty a)
775 (Seq.singleton (my_ty, hval))
776 max_depth
777 new_ty <- zonkTcType my_ty
778 if isMonomorphic new_ty || check2 (sigmaType new_ty) sigma_old_ty
779 then do
780 traceTR (text "check2 passed")
781 addConstraint my_ty old_ty'
782 new_ty' <- zonkTcType my_ty
783 return (substTy rev_subst new_ty')
784 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
785 return old_ty
786 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
787 return new_ty
788 where
789 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
790 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
791 int max_depth <> text " steps")
792 search stop expand l d =
793 case viewl l of
794 EmptyL -> return ()
795 x :< xx -> unlessM stop $ do
796 new <- expand x
797 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
798
799 -- returns unification tasks,since we are going to want a breadth-first search
800 go :: Type -> HValue -> TR [(Type, HValue)]
801 go my_ty a = do
802 clos <- trIO $ getClosureData a
803 case tipe clos of
804 Indirection _ -> go my_ty $! (ptrs clos ! 0)
805 MutVar _ -> do
806 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
807 tv' <- newVar liftedTypeKind
808 world <- newVar liftedTypeKind
809 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
810 return [(tv', contents)]
811 Constr -> do
812 Right dcname <- dataConInfoPtrToName (infoPtr clos)
813 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
814 case mb_dc of
815 Nothing-> do
816 -- TODO: Check this case
817 forM [0..length (elems $ ptrs clos)] $ \i -> do
818 tv <- newVar liftedTypeKind
819 return$ appArr (\e->(tv,e)) (ptrs clos) i
820
821 Just dc -> do
822 subTtypes <- mapMif (not . isMonomorphic)
823 (\t -> newVar (typeKind t))
824 (dataConRepArgTys dc)
825
826 -- It is vital for newtype reconstruction that the unification step
827 -- is done right here, _before_ the subterms are RTTI reconstructed
828 let myType = mkFunTys subTtypes my_ty
829 (signatureType,_) <- instScheme(rttiView $ dataConUserType dc)
830 addConstraint myType signatureType
831 return $ [ appArr (\e->(t,e)) (ptrs clos) i
832 | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
833 _ -> return []
834
835 -- Compute the difference between a base type and the type found by RTTI
836 -- improveType <base_type> <rtti_type>
837 -- The types can contain skolem type variables, which need to be treated as normal vars.
838 -- In particular, we want them to unify with things.
839 improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst)
840 improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
841 traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty]
842 (ty_tvs, _, _) <- tcInstType return ty
843 (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
844 (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
845 getLIE(boxyUnify rtti_ty' ty')
846 tvs1_contents <- zonkTcTyVars ty_tvs'
847 let subst = (uncurry zipTopTvSubst . unzip)
848 [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
849 , getTyVar_maybe ty /= Just tv
850 --, not(isTyVarTy ty)
851 ]
852 return subst
853 where ty = sigmaType _ty
854
855 myDataConInstArgTys :: DataCon -> [Type] -> [Type]
856 myDataConInstArgTys dc args
857 | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
858 | otherwise = dataConRepArgTys dc
859
860 isRefType :: Type -> Bool
861 isRefType ty
862 | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
863 | otherwise = False
864 where ty'= repType ty
865
866 isRefTyCon :: TyCon -> Bool
867 isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
868
869 -- Soundness checks
870 --------------------
871 {-
872 This is not formalized anywhere, so hold to your seats!
873 RTTI in the presence of newtypes can be a tricky and unsound business.
874
875 Example:
876 ~~~~~~~~~
877 Suppose we are doing RTTI for a partially evaluated
878 closure t, the real type of which is t :: MkT Int, for
879
880 newtype MkT a = MkT [Maybe a]
881
882 The table below shows the results of RTTI and the improvement
883 calculated for different combinations of evaluatedness and :type t.
884 Regard the two first columns as input and the next two as output.
885
886 # | t | :type t | rtti(t) | improv. | result
887 ------------------------------------------------------------
888 1 | _ | t b | a | none | OK
889 2 | _ | MkT b | a | none | OK
890 3 | _ | t Int | a | none | OK
891
892 If t is not evaluated at *all*, we are safe.
893
894 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
895 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
896 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
897
898 If a is a minimal whnf, we run into trouble. Note that
899 row 5 above does newtype enrichment on the ty_rtty parameter.
900
901 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
902 | | | b = Maybe a|
903
904 8 | (Just _:_)| MkT b | MkT a | none | OK
905 9 | (Just _:_)| t Int | FAIL | none | OK
906
907 And if t is any more evaluated than whnf, we are still in trouble.
908 Because constraints are solved in top-down order, when we reach the
909 Maybe subterm what we got is already unsound. This explains why the
910 row 9 fails to complete.
911
912 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
913 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
914
915 We can undo the failure in row 9 by leaving out the constraint
916 coming from the type signature of t (i.e., the 2nd column).
917 Note that this type information is still used
918 to calculate the improvement. But we fail
919 when trying to calculate the improvement, as there is no unifier for
920 t Int = [Maybe a] or t Int = [Maybe Int].
921
922
923 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
924
925 # | t | :type t | rtti(t) | improvement | result
926 ---------------------------------------------------------------------
927 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
928 | | | | b = Maybe a |
929
930 The checks:
931 ~~~~~~~~~~~
932 Consider a function obtainType that takes a value and a type and produces
933 the Term representation and a substitution (the improvement).
934 Assume an auxiliar rtti' function which does the actual job if recovering
935 the type, but which may produce a false type.
936
937 In pseudocode:
938
939 rtti' :: a -> IO Type -- Does not use the static type information
940
941 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
942 obtainType v old_ty = do
943 rtti_ty <- rtti' v
944 if monomorphic rtti_ty || (check rtti_ty old_ty)
945 then ...
946 else return Nothing
947 where check rtti_ty old_ty = check1 rtti_ty &&
948 check2 rtti_ty old_ty
949
950 check1 :: Type -> Bool
951 check2 :: Type -> Type -> Bool
952
953 Now, if rtti' returns a monomorphic type, we are safe.
954 If that is not the case, then we consider two conditions.
955
956
957 1. To prevent the class of unsoundness displayed by
958 rows 4 and 7 in the example: no higher kind tyvars
959 accepted.
960
961 check1 (t a) = NO
962 check1 (t Int) = NO
963 check1 ([] a) = YES
964
965 2. To prevent the class of unsoundness shown by row 6,
966 the rtti type should be structurally more
967 defined than the old type we are comparing it to.
968 check2 :: OldType -> NewTy pe -> Bool
969 check2 a _ = True
970 check2 [a] a = True
971 check2 [a] (t Int) = False
972 check2 [a] (t a) = False -- By check1 we never reach this equation
973 check2 [Int] a = True
974 check2 [Int] (t Int) = True
975 check2 [Maybe a] (t Int) = False
976 check2 [Maybe Int] (t Int) = True
977 check2 (Maybe [a]) (m [Int]) = False
978 check2 (Maybe [Int]) (m [Int]) = True
979
980 -}
981
982 check1 :: Type -> Bool
983 check1 ty | (tvs, _, _) <- tcSplitSigmaTy ty = not $ any isHigherKind (map tyVarKind tvs)
984 where
985 isHigherKind = not . null . fst . splitKindFunTys
986
987 check2 :: Type -> Type -> Bool
988 check2 sigma_rtti_ty sigma_old_ty
989 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
990 = case () of
991 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
992 -> and$ zipWith check2 rttis olds
993 _ | Just _ <- splitAppTy_maybe old_ty
994 -> isMonomorphicOnNonPhantomArgs rtti_ty
995 _ -> True
996 | otherwise = True
997 where (_, _ , rtti_ty) = tcSplitSigmaTy sigma_rtti_ty
998 (_, _ , old_ty) = tcSplitSigmaTy sigma_old_ty
999
1000
1001 -- Dealing with newtypes
1002 --------------------------
1003 {-
1004 congruenceNewtypes does a parallel fold over two Type values,
1005 compensating for missing newtypes on both sides.
1006 This is necessary because newtypes are not present
1007 in runtime, but sometimes there is evidence available.
1008 Evidence can come from DataCon signatures or
1009 from compile-time type inference.
1010 What we are doing here is an approximation
1011 of unification modulo a set of equations derived
1012 from newtype definitions. These equations should be the
1013 same as the equality coercions generated for newtypes
1014 in System Fc. The idea is to perform a sort of rewriting,
1015 taking those equations as rules, before launching unification.
1016
1017 The caller must ensure the following.
1018 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1019 The 2nd type (rhs) comes from a DataCon type signature.
1020 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1021 in both types, but in the rhs it is restricted to the result type.
1022
1023 Note that it is very tricky to make this 'rewriting'
1024 work with the unification implemented by TcM, where
1025 substitutions are operationally inlined. The order in which
1026 constraints are unified is vital as we cannot modify
1027 anything that has been touched by a previous unification step.
1028 Therefore, congruenceNewtypes is sound only if the types
1029 recovered by the RTTI mechanism are unified Top-Down.
1030 -}
1031 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1032 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1033 where
1034 go l r
1035 -- TyVar lhs inductive case
1036 | Just tv <- getTyVar_maybe l
1037 = recoverTR (return r) $ do
1038 Indirect ty_v <- readMetaTyVar tv
1039 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1040 ppr tv, equals, ppr ty_v]
1041 go ty_v r
1042 -- FunTy inductive case
1043 | Just (l1,l2) <- splitFunTy_maybe l
1044 , Just (r1,r2) <- splitFunTy_maybe r
1045 = do r2' <- go l2 r2
1046 r1' <- go l1 r1
1047 return (mkFunTy r1' r2')
1048 -- TyconApp Inductive case; this is the interesting bit.
1049 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1050 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1051 , tycon_l /= tycon_r
1052 = upgrade tycon_l r
1053
1054 | otherwise = return r
1055
1056 where upgrade :: TyCon -> Type -> TR Type
1057 upgrade new_tycon ty
1058 | not (isNewTyCon new_tycon) = do
1059 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1060 ppr new_tycon <> text " for " <> ppr ty)
1061 return ty
1062 | otherwise = do
1063 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1064 text " in presence of newtype evidence " <> ppr new_tycon)
1065 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
1066 let ty' = mkTyConApp new_tycon vars
1067 liftTcM (boxyUnify ty (repType ty'))
1068 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1069 return ty'
1070
1071
1072 zonkTerm :: Term -> TcM Term
1073 zonkTerm = foldTermM TermFoldM{
1074 fTermM = \ty dc v tt -> zonkTcType ty >>= \ty' ->
1075 return (Term ty' dc v tt)
1076 ,fSuspensionM = \ct ty v b -> zonkTcType ty >>= \ty ->
1077 return (Suspension ct ty v b)
1078 ,fNewtypeWrapM= \ty dc t -> zonkTcType ty >>= \ty' ->
1079 return$ NewtypeWrap ty' dc t
1080 ,fRefWrapM = \ty t ->
1081 return RefWrap `ap` zonkTcType ty `ap` return t
1082 ,fPrimM = (return.) . Prim
1083 }
1084
1085 --------------------------------------------------------------------------------
1086 -- representation types for thetas
1087 rttiView :: Type -> Type
1088 rttiView ty | Just ty' <- coreView ty = rttiView ty'
1089 rttiView ty
1090 | (tvs, theta, tau) <- tcSplitSigmaTy ty
1091 = mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau)
1092
1093 -- Restore Class predicates out of a representation type
1094 dictsView :: Type -> Type
1095 -- dictsView ty = ty
1096 dictsView (FunTy (TyConApp tc_dict args) ty)
1097 | Just c <- tyConClass_maybe tc_dict
1098 = FunTy (PredTy (ClassP c args)) (dictsView ty)
1099 dictsView ty
1100 | Just (tc_fun, [TyConApp tc_dict args, ty2]) <- tcSplitTyConApp_maybe ty
1101 , Just c <- tyConClass_maybe tc_dict
1102 = mkTyConApp tc_fun [PredTy (ClassP c args), dictsView ty2]
1103 dictsView ty = ty
1104
1105
1106 -- Use only for RTTI types
1107 isMonomorphic :: RttiType -> Bool
1108 isMonomorphic ty = noExistentials && noUniversals
1109 where (tvs, _, ty') = tcSplitSigmaTy ty
1110 noExistentials = isEmptyVarSet (tyVarsOfType ty')
1111 noUniversals = null tvs
1112
1113 -- Use only for RTTI types
1114 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1115 isMonomorphicOnNonPhantomArgs ty
1116 | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
1117 , phantom_vars <- tyConPhantomTyVars tc
1118 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1119 , tyv `notElem` phantom_vars]
1120 = all isMonomorphicOnNonPhantomArgs concrete_args
1121 | Just (ty1, ty2) <- splitFunTy_maybe ty
1122 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1123 | otherwise = isMonomorphic ty
1124
1125 tyConPhantomTyVars :: TyCon -> [TyVar]
1126 tyConPhantomTyVars tc
1127 | isAlgTyCon tc
1128 , Just dcs <- tyConDataCons_maybe tc
1129 , dc_vars <- concatMap dataConUnivTyVars dcs
1130 = tyConTyVars tc \\ dc_vars
1131 tyConPhantomTyVars _ = []
1132
1133 -- Is this defined elsewhere?
1134 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
1135 sigmaType :: Type -> Type
1136 sigmaType ty = mkSigmaTy (varSetElems$ tyVarsOfType ty) [] ty
1137
1138
1139 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
1140 mapMif pred f xx = sequence $ mapMif_ pred f xx
1141 where
1142 mapMif_ _ _ [] = []
1143 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
1144
1145 unlessM :: Monad m => m Bool -> m () -> m ()
1146 unlessM condM acc = condM >>= \c -> unless c acc
1147
1148
1149 -- Strict application of f at index i
1150 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
1151 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
1152 = ASSERT2 (i < length(elems a), ppr(length$ elems a, i))
1153 case indexArray# ptrs# i# of
1154 (# e #) -> f e
1155
1156 amap' :: (t -> b) -> Array Int t -> [b]
1157 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
1158 where g (I# i#) = case indexArray# arr# i# of
1159 (# e #) -> f e
1160
1161
1162 isLifted :: Type -> Bool
1163 isLifted = not . isUnLiftedType
1164
1165 extractUnboxed :: [Type] -> Closure -> [[Word]]
1166 extractUnboxed tt clos = go tt (nonPtrs clos)
1167 where sizeofType t
1168 | Just (tycon,_) <- tcSplitTyConApp_maybe t
1169 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
1170 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
1171 go [] _ = []
1172 go (t:tt) xx
1173 | (x, rest) <- splitAt (sizeofType t) xx
1174 = x : go tt rest
1175
1176 sizeofTyCon :: TyCon -> Int -- in *words*
1177 sizeofTyCon = primRepSizeW . tyConPrimRep
1178
1179
1180 (|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
1181 (f |.| g) x = f x || g x