Rename maybeTyConSingleCon to tyConSingleDataCon_maybe
[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
11 cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
12
13 Term(..),
14 isTerm,
15 isSuspension,
16 isPrim,
17 isNewtypeWrap,
18 pprTerm,
19 cPprTerm,
20 cPprTermBase,
21 CustomTermPrinter,
22 termType,
23 foldTerm,
24 TermFold(..),
25 idTermFold,
26 idTermFoldM,
27 isFullyEvaluated,
28 isPointed,
29 isFullyEvaluatedTerm,
30 mapTermType,
31 termTyVars,
32 -- unsafeDeepSeq,
33 cvReconstructType,
34 improveRTTIType,
35 sigmaType,
36 Closure(..),
37 getClosureData,
38 ClosureType(..),
39 isConstr,
40 isIndirection
41 ) where
42
43 #include "HsVersions.h"
44
45 import ByteCodeItbls ( StgInfoTable )
46 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
47 import HscTypes ( HscEnv )
48 import Linker
49
50 import DataCon
51 import Type
52 import Var
53 import TcRnMonad
54 import TcType
55 import TcMType
56 import TcUnify
57 import TcEnv
58 import DriverPhases
59 import TyCon
60 import Name
61 import VarEnv
62 import Util
63 import VarSet
64
65 import TysPrim
66 import PrelNames
67 import TysWiredIn
68
69 import Outputable
70 import FastString
71 import Panic
72
73 import Constants ( wORD_SIZE )
74
75 import GHC.Arr ( Array(..) )
76 import GHC.Exts
77 import GHC.IOBase ( IO(IO) )
78
79 import Control.Monad
80 import Data.Maybe
81 import Data.Array.Base
82 import Data.Ix
83 import Data.List ( partition )
84 import qualified Data.Sequence as Seq
85 import Data.Monoid
86 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
87 import Foreign
88 import System.IO.Unsafe
89
90 import System.IO
91 ---------------------------------------------
92 -- * A representation of semi evaluated Terms
93 ---------------------------------------------
94 {-
95
96 -}
97
98 data Term = Term { ty :: Type
99 , dc :: Either String DataCon
100 -- Carries a text representation if the datacon is
101 -- not exported by the .hi file, which is the case
102 -- for private constructors in -O0 compiled libraries
103 , val :: HValue
104 , subTerms :: [Term] }
105
106 | Prim { ty :: Type
107 , value :: [Word] }
108
109 | Suspension { ctype :: ClosureType
110 , ty :: Type
111 , val :: HValue
112 , bound_to :: Maybe Name -- Useful for printing
113 }
114 | NewtypeWrap{ ty :: Type
115 , dc :: Either String DataCon
116 , wrapped_term :: Term }
117 | RefWrap { ty :: Type
118 , wrapped_term :: Term }
119
120 isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool
121 isTerm Term{} = True
122 isTerm _ = False
123 isSuspension Suspension{} = True
124 isSuspension _ = False
125 isPrim Prim{} = True
126 isPrim _ = False
127 isNewtypeWrap NewtypeWrap{} = True
128 isNewtypeWrap _ = False
129
130 termType :: Term -> Type
131 termType t = ty t
132
133 isFullyEvaluatedTerm :: Term -> Bool
134 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
135 isFullyEvaluatedTerm Prim {} = True
136 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
137 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
138 isFullyEvaluatedTerm _ = False
139
140 instance Outputable (Term) where
141 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
142 | otherwise = panic "Outputable Term instance"
143
144 -------------------------------------------------------------------------
145 -- Runtime Closure Datatype and functions for retrieving closure related stuff
146 -------------------------------------------------------------------------
147 data ClosureType = Constr
148 | Fun
149 | Thunk Int
150 | ThunkSelector
151 | Blackhole
152 | AP
153 | PAP
154 | Indirection Int
155 | MutVar Int
156 | Other Int
157 deriving (Show, Eq)
158
159 data Closure = Closure { tipe :: ClosureType
160 , infoPtr :: Ptr ()
161 , infoTable :: StgInfoTable
162 , ptrs :: Array Int HValue
163 , nonPtrs :: [Word]
164 }
165
166 instance Outputable ClosureType where
167 ppr = text . show
168
169 #include "../includes/ClosureTypes.h"
170
171 aP_CODE, pAP_CODE :: Int
172 aP_CODE = AP
173 pAP_CODE = PAP
174 #undef AP
175 #undef PAP
176
177 getClosureData :: a -> IO Closure
178 getClosureData a =
179 case unpackClosure# a of
180 (# iptr, ptrs, nptrs #) -> do
181 let iptr'
182 | ghciTablesNextToCode =
183 Ptr iptr
184 | otherwise =
185 -- the info pointer we get back from unpackClosure#
186 -- is to the beginning of the standard info table,
187 -- but the Storable instance for info tables takes
188 -- into account the extra entry pointer when
189 -- !ghciTablesNextToCode, so we must adjust here:
190 Ptr iptr `plusPtr` negate wORD_SIZE
191 itbl <- peek iptr'
192 let tipe = readCType (BCI.tipe itbl)
193 elems = fromIntegral (BCI.ptrs itbl)
194 ptrsList = Array 0 (elems - 1) elems ptrs
195 nptrs_data = [W# (indexWordArray# nptrs i)
196 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
197 ASSERT(elems >= 0) return ()
198 ptrsList `seq`
199 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
200
201 readCType :: Integral a => a -> ClosureType
202 readCType i
203 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
204 | i >= FUN && i <= FUN_STATIC = Fun
205 | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
206 | i == THUNK_SELECTOR = ThunkSelector
207 | i == BLACKHOLE = Blackhole
208 | i >= IND && i <= IND_STATIC = Indirection i'
209 | i' == aP_CODE = AP
210 | i == AP_STACK = AP
211 | i' == pAP_CODE = PAP
212 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i'
213 | 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 amap' :: (t -> b) -> Array Int t -> [b]
238 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
239 where g (I# i#) = case indexArray# arr# i# of
240 (# e #) -> f e
241
242 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
243 {-
244 unsafeDeepSeq :: a -> b -> b
245 unsafeDeepSeq = unsafeDeepSeq1 2
246 where unsafeDeepSeq1 0 a b = seq a $! b
247 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
248 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
249 -- | unsafePerformIO (isFullyEvaluated a) = b
250 | otherwise = case unsafePerformIO (getClosureData a) of
251 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
252 where tipe = unsafePerformIO (getClosureType a)
253 -}
254 isPointed :: Type -> Bool
255 isPointed t | Just (t, _) <- splitTyConApp_maybe t
256 = not$ isUnliftedTypeKind (tyConKind t)
257 isPointed _ = True
258
259 extractUnboxed :: [Type] -> Closure -> [[Word]]
260 extractUnboxed tt clos = go tt (nonPtrs clos)
261 where sizeofType t
262 | Just (tycon,_) <- splitTyConApp_maybe t
263 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
264 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
265 go [] _ = []
266 go (t:tt) xx
267 | (x, rest) <- splitAt (sizeofType t) xx
268 = x : go tt rest
269
270 sizeofTyCon :: TyCon -> Int -- in *words*
271 sizeofTyCon = primRepSizeW . tyConPrimRep
272
273 -----------------------------------
274 -- * Traversals for Terms
275 -----------------------------------
276 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
277
278 data TermFold a = TermFold { fTerm :: TermProcessor a a
279 , fPrim :: Type -> [Word] -> a
280 , fSuspension :: ClosureType -> Type -> HValue
281 -> Maybe Name -> a
282 , fNewtypeWrap :: Type -> Either String DataCon
283 -> a -> a
284 , fRefWrap :: Type -> a -> a
285 }
286
287 foldTerm :: TermFold a -> Term -> a
288 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
289 foldTerm tf (Prim ty v ) = fPrim tf ty v
290 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
291 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
292 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
293
294 idTermFold :: TermFold Term
295 idTermFold = TermFold {
296 fTerm = Term,
297 fPrim = Prim,
298 fSuspension = Suspension,
299 fNewtypeWrap = NewtypeWrap,
300 fRefWrap = RefWrap
301 }
302 idTermFoldM :: Monad m => TermFold (m Term)
303 idTermFoldM = TermFold {
304 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
305 fPrim = (return.). Prim,
306 fSuspension = (((return.).).). Suspension,
307 fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t,
308 fRefWrap = \ty t -> RefWrap ty `liftM` t
309 }
310
311 mapTermType :: (Type -> Type) -> Term -> Term
312 mapTermType f = foldTerm idTermFold {
313 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
314 fSuspension = \ct ty hval n ->
315 Suspension ct (f ty) hval n,
316 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
317 fRefWrap = \ty t -> RefWrap (f ty) t}
318
319 termTyVars :: Term -> TyVarSet
320 termTyVars = foldTerm TermFold {
321 fTerm = \ty _ _ tt ->
322 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
323 fSuspension = \_ ty _ _ -> tyVarsOfType ty,
324 fPrim = \ _ _ -> emptyVarEnv,
325 fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t,
326 fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t}
327 where concatVarEnv = foldr plusVarEnv emptyVarEnv
328
329 ----------------------------------
330 -- Pretty printing of terms
331 ----------------------------------
332
333 type Precedence = Int
334 type TermPrinter = Precedence -> Term -> SDoc
335 type TermPrinterM m = Precedence -> Term -> m SDoc
336
337 app_prec,cons_prec, max_prec ::Int
338 max_prec = 10
339 app_prec = max_prec
340 cons_prec = 5 -- TODO Extract this info from GHC itself
341
342 pprTerm :: TermPrinter -> TermPrinter
343 pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
344 pprTerm _ _ _ = panic "pprTerm"
345
346 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
347 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
348
349 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
350 tt_docs <- mapM (y app_prec) tt
351 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
352
353 ppr_termM y p Term{dc=Right dc, subTerms=tt}
354 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
355 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
356 <+> hsep (map (ppr_term1 True) tt)
357 -} -- TODO Printing infix constructors properly
358 | null tt = return$ ppr dc
359 | otherwise = do
360 tt_docs <- mapM (y app_prec) tt
361 return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
362
363 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
364 ppr_termM y p RefWrap{wrapped_term=t} = do
365 contents <- y app_prec t
366 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
367 -- The constructor name is wired in here ^^^ for the sake of simplicity.
368 -- I don't think mutvars are going to change in a near future.
369 -- In any case this is solely a presentation matter: MutVar# is
370 -- a datatype with no constructors, implemented by the RTS
371 -- (hence there is no way to obtain a datacon and print it).
372 ppr_termM _ _ t = ppr_termM1 t
373
374
375 ppr_termM1 :: Monad m => Term -> m SDoc
376 ppr_termM1 Prim{value=words, ty=ty} =
377 return$ text$ repPrim (tyConAppTyCon ty) words
378 ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
379 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
380 | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit "<function>")
381 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
382 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
383 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
384 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
385
386 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
387 | Just (tc,_) <- splitNewTyConApp_maybe ty
388 , ASSERT(isNewTyCon tc) True
389 , Just new_dc <- tyConSingleDataCon_maybe tc = do
390 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 , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
437 ]
438 where ifTerm pred f prec t@Term{}
439 | pred t = Just `liftM` f prec t
440 ifTerm _ _ _ _ = return Nothing
441
442 isIntegerTy ty = fromMaybe False $ do
443 (tc,_) <- splitTyConApp_maybe ty
444 return (tyConName tc == integerTyConName)
445
446 isTupleTy ty = fromMaybe False $ do
447 (tc,_) <- splitTyConApp_maybe ty
448 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
449
450 isTyCon a_tc ty = fromMaybe False $ do
451 (tc,_) <- splitTyConApp_maybe ty
452 return (a_tc == tc)
453
454 coerceShow f _p = return . text . show . f . unsafeCoerce# . val
455
456 --Note pprinting of list terms is not lazy
457 doList p h t = do
458 let elems = h : getListTerms t
459 isConsLast = not(termType(last elems) `coreEqType` termType h)
460 print_elems <- mapM (y cons_prec) elems
461 return$ if isConsLast
462 then cparen (p >= cons_prec)
463 . pprDeeperList fsep
464 . punctuate (space<>colon)
465 $ print_elems
466 else brackets (pprDeeperList fcat$
467 punctuate comma print_elems)
468
469 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
470 getListTerms Term{subTerms=[]} = []
471 getListTerms t@Suspension{} = [t]
472 getListTerms t = pprPanic "getListTerms" (ppr t)
473
474
475 repPrim :: TyCon -> [Word] -> String
476 repPrim t = rep where
477 rep x
478 | t == charPrimTyCon = show (build x :: Char)
479 | t == intPrimTyCon = show (build x :: Int)
480 | t == wordPrimTyCon = show (build x :: Word)
481 | t == floatPrimTyCon = show (build x :: Float)
482 | t == doublePrimTyCon = show (build x :: Double)
483 | t == int32PrimTyCon = show (build x :: Int32)
484 | t == word32PrimTyCon = show (build x :: Word32)
485 | t == int64PrimTyCon = show (build x :: Int64)
486 | t == word64PrimTyCon = show (build x :: Word64)
487 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
488 | t == stablePtrPrimTyCon = "<stablePtr>"
489 | t == stableNamePrimTyCon = "<stableName>"
490 | t == statePrimTyCon = "<statethread>"
491 | t == realWorldTyCon = "<realworld>"
492 | t == threadIdPrimTyCon = "<ThreadId>"
493 | t == weakPrimTyCon = "<Weak>"
494 | t == arrayPrimTyCon = "<array>"
495 | t == byteArrayPrimTyCon = "<bytearray>"
496 | t == mutableArrayPrimTyCon = "<mutableArray>"
497 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
498 | t == mutVarPrimTyCon= "<mutVar>"
499 | t == mVarPrimTyCon = "<mVar>"
500 | t == tVarPrimTyCon = "<tVar>"
501 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
502 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
503 -- This ^^^ relies on the representation of Haskell heap values being
504 -- the same as in a C array.
505
506 -----------------------------------
507 -- Type Reconstruction
508 -----------------------------------
509 {-
510 Type Reconstruction is type inference done on heap closures.
511 The algorithm walks the heap generating a set of equations, which
512 are solved with syntactic unification.
513 A type reconstruction equation looks like:
514
515 <datacon reptype> = <actual heap contents>
516
517 The full equation set is generated by traversing all the subterms, starting
518 from a given term.
519
520 The only difficult part is that newtypes are only found in the lhs of equations.
521 Right hand sides are missing them. We can either (a) drop them from the lhs, or
522 (b) reconstruct them in the rhs when possible.
523
524 The function congruenceNewtypes takes a shot at (b)
525 -}
526
527 -- The Type Reconstruction monad
528 type TR a = TcM a
529
530 runTR :: HscEnv -> TR a -> IO a
531 runTR hsc_env c = do
532 mb_term <- runTR_maybe hsc_env c
533 case mb_term of
534 Nothing -> panic "Can't unify"
535 Just x -> return x
536
537 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
538 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
539
540 traceTR :: SDoc -> TR ()
541 traceTR = liftTcM . traceTc
542
543 trIO :: IO a -> TR a
544 trIO = liftTcM . liftIO
545
546 liftTcM :: TcM a -> TR a
547 liftTcM = id
548
549 newVar :: Kind -> TR TcType
550 newVar = liftTcM . fmap mkTyVarTy . newBoxyTyVar
551
552 -- | Returns the instantiated type scheme ty', and the substitution sigma
553 -- such that sigma(ty') = ty
554 instScheme :: Type -> TR (TcType, TvSubst)
555 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
556 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
557 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
558
559 -- Adds a constraint of the form t1 == t2
560 -- t1 is expected to come from walking the heap
561 -- t2 is expected to come from a datacon signature
562 -- Before unification, congruenceNewtypes needs to
563 -- do its magic.
564 addConstraint :: TcType -> TcType -> TR ()
565 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry boxyUnify
566 >> return () -- TOMDO: what about the coercion?
567 -- we should consider family instances
568
569 -- Type & Term reconstruction
570 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
571 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
572 tv <- newVar argTypeKind
573 case mb_ty of
574 Nothing -> go bound tv tv hval
575 >>= zonkTerm
576 >>= return . expandNewtypes
577 Just ty | isMonomorphic ty -> go bound ty ty hval
578 >>= zonkTerm
579 >>= return . expandNewtypes
580 Just ty -> do
581 (ty',rev_subst) <- instScheme (sigmaType ty)
582 addConstraint tv ty'
583 term <- go bound tv tv hval >>= zonkTerm
584 --restore original Tyvars
585 return$ expandNewtypes $ mapTermType (substTy rev_subst) term
586 where
587 go bound _ _ _ | seq bound False = undefined
588 go 0 tv _ty a = do
589 clos <- trIO $ getClosureData a
590 return (Suspension (tipe clos) tv a Nothing)
591 go bound tv ty a = do
592 let monomorphic = not(isTyVarTy tv)
593 -- This ^^^ is a convention. The ancestor tests for
594 -- monomorphism and passes a type instead of a tv
595 clos <- trIO $ getClosureData a
596 case tipe clos of
597 -- Thunks we may want to force
598 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
599 -- force blackholes, because it would almost certainly result in deadlock,
600 -- and showing the '_' is more useful.
601 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
602 -- We always follow indirections
603 Indirection _ -> go bound tv ty $! (ptrs clos ! 0)
604 -- We also follow references
605 MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty
606 -- , tycon == mutVarPrimTyCon
607 -> do
608 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
609 tv' <- newVar liftedTypeKind
610 addConstraint tv (mkTyConApp tycon [world,tv'])
611 x <- go bound tv' ty_contents contents
612 return (RefWrap ty x)
613
614 -- The interesting case
615 Constr -> do
616 Right dcname <- dataConInfoPtrToName (infoPtr clos)
617 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
618 case mb_dc of
619 Nothing -> do -- This can happen for private constructors compiled -O0
620 -- where the .hi descriptor does not export them
621 -- In such case, we return a best approximation:
622 -- ignore the unpointed args, and recover the pointeds
623 -- This preserves laziness, and should be safe.
624 let tag = showSDoc (ppr dcname)
625 vars <- replicateM (length$ elems$ ptrs clos)
626 (newVar (liftedTypeKind))
627 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
628 | (i, tv) <- zip [0..] vars]
629 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
630 Just dc -> do
631 let extra_args = length(dataConRepArgTys dc) -
632 length(dataConOrigArgTys dc)
633 subTtypes = matchSubTypes dc ty
634 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
635 subTermTvs <- sequence
636 [ if isMonomorphic t then return t
637 else (newVar k)
638 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
639 -- It is vital for newtype reconstruction that the unification step
640 -- is done right here, _before_ the subterms are RTTI reconstructed
641 when (not monomorphic) $ do
642 let myType = mkFunTys (reOrderTerms subTermTvs
643 subTtypesNP
644 subTtypes)
645 tv
646 (signatureType,_) <- instScheme(dataConRepType dc)
647 addConstraint myType signatureType
648 subTermsP <- sequence $ drop extra_args
649 -- \^^^ all extra arguments are pointed
650 [ appArr (go (pred bound) tv t) (ptrs clos) i
651 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
652 let unboxeds = extractUnboxed subTtypesNP clos
653 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
654 subTerms = reOrderTerms subTermsP subTermsNP
655 (drop extra_args subTtypes)
656 return (Term tv (Right dc) a subTerms)
657 -- The otherwise case: can be a Thunk,AP,PAP,etc.
658 tipe_clos ->
659 return (Suspension tipe_clos tv a Nothing)
660
661 matchSubTypes dc ty
662 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
663 -- assumption: ^^^ looks through newtypes
664 , isVanillaDataCon dc --TODO non-vanilla case
665 = dataConInstArgTys dc ty_args
666 | otherwise = dataConRepArgTys dc
667
668 -- This is used to put together pointed and nonpointed subterms in the
669 -- correct order.
670 reOrderTerms _ _ [] = []
671 reOrderTerms pointed unpointed (ty:tys)
672 | isPointed ty = ASSERT2(not(null pointed)
673 , ptext (sLit "reOrderTerms") $$
674 (ppr pointed $$ ppr unpointed))
675 let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
676 | otherwise = ASSERT2(not(null unpointed)
677 , ptext (sLit "reOrderTerms") $$
678 (ppr pointed $$ ppr unpointed))
679 let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
680
681 expandNewtypes t@Term{ ty=ty, subTerms=tt }
682 | Just (tc, args) <- splitNewTyConApp_maybe ty
683 , isNewTyCon tc
684 , wrapped_type <- newTyConInstRhs tc args
685 , Just dc <- tyConSingleDataCon_maybe tc
686 , t' <- expandNewtypes t{ ty = wrapped_type
687 , subTerms = map expandNewtypes tt }
688 = NewtypeWrap ty (Right dc) t'
689
690 | otherwise = t{ subTerms = map expandNewtypes tt }
691
692 expandNewtypes t = t
693
694
695 -- Fast, breadth-first Type reconstruction
696 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
697 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
698 tv <- newVar argTypeKind
699 case mb_ty of
700 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
701 (uncurry go)
702 (Seq.singleton (tv, hval))
703 max_depth
704 zonkTcType tv -- TODO untested!
705 Just ty | isMonomorphic ty -> return ty
706 Just ty -> do
707 (ty',rev_subst) <- instScheme (sigmaType ty)
708 addConstraint tv ty'
709 search (isMonomorphic `fmap` zonkTcType tv)
710 (\(ty,a) -> go ty a)
711 (Seq.singleton (tv, hval))
712 max_depth
713 substTy rev_subst `fmap` zonkTcType tv
714 where
715 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
716 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
717 int max_depth <> text " steps")
718 search stop expand l d =
719 case viewl l of
720 EmptyL -> return ()
721 x :< xx -> unlessM stop $ do
722 new <- expand x
723 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
724
725 -- returns unification tasks,since we are going to want a breadth-first search
726 go :: Type -> HValue -> TR [(Type, HValue)]
727 go tv a = do
728 clos <- trIO $ getClosureData a
729 case tipe clos of
730 Indirection _ -> go tv $! (ptrs clos ! 0)
731 MutVar _ -> do
732 contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
733 tv' <- newVar liftedTypeKind
734 world <- newVar liftedTypeKind
735 addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv'])
736 -- x <- go tv' ty_contents contents
737 return [(tv', contents)]
738 Constr -> do
739 Right dcname <- dataConInfoPtrToName (infoPtr clos)
740 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
741 case mb_dc of
742 Nothing-> do
743 -- TODO: Check this case
744 forM [0..length (elems $ ptrs clos)] $ \i -> do
745 tv <- newVar liftedTypeKind
746 return$ appArr (\e->(tv,e)) (ptrs clos) i
747
748 Just dc -> do
749 let extra_args = length(dataConRepArgTys dc) -
750 length(dataConOrigArgTys dc)
751 subTtypes <- mapMif (not . isMonomorphic)
752 (\t -> newVar (typeKind t))
753 (dataConRepArgTys dc)
754
755 -- It is vital for newtype reconstruction that the unification step
756 -- is done right here, _before_ the subterms are RTTI reconstructed
757 let myType = mkFunTys subTtypes tv
758 (signatureType,_) <- instScheme(dataConRepType dc)
759 addConstraint myType signatureType
760 return $ [ appArr (\e->(t,e)) (ptrs clos) i
761 | (i,t) <- drop extra_args $
762 zip [0..] (filter isPointed subTtypes)]
763 _ -> return []
764
765 -- Compute the difference between a base type and the type found by RTTI
766 -- improveType <base_type> <rtti_type>
767 -- The types can contain skolem type variables, which need to be treated as normal vars.
768 -- In particular, we want them to unify with things.
769 improveRTTIType :: HscEnv -> Type -> Type -> IO (Maybe TvSubst)
770 improveRTTIType hsc_env ty rtti_ty = runTR_maybe hsc_env $ do
771 let (_,ty0) = splitForAllTys ty
772 ty_tvs = varSetElems $ tyVarsOfType ty0
773 let (_,rtti_ty0)= splitForAllTys rtti_ty
774 rtti_tvs = varSetElems $ tyVarsOfType rtti_ty0
775 (ty_tvs',_,ty')<- tcInstType (mapM tcInstTyVar) (mkSigmaTy ty_tvs [] ty0)
776 (_,_,rtti_ty') <- tcInstType (mapM tcInstTyVar) (mkSigmaTy rtti_tvs [] rtti_ty0)
777 boxyUnify rtti_ty' ty'
778 tvs1_contents <- zonkTcTyVars ty_tvs'
779 let subst = uncurry zipTopTvSubst
780 (unzip [(tv,ty) | tv <- ty_tvs, ty <- tvs1_contents
781 , getTyVar_maybe ty /= Just tv
782 , not(isTyVarTy ty)])
783 -- liftIO $ hPutStrLn stderr $ showSDocDebug $ text "unify " <+> sep [ppr ty, ppr rtti_ty, equals, ppr subst ]
784 return subst
785
786 -- Dealing with newtypes
787 {-
788 congruenceNewtypes does a parallel fold over two Type values,
789 compensating for missing newtypes on both sides.
790 This is necessary because newtypes are not present
791 in runtime, but sometimes there is evidence available.
792 Evidence can come from DataCon signatures or
793 from compile-time type inference.
794 What we are doing here is an approximation
795 of unification modulo a set of equations derived
796 from newtype definitions. These equations should be the
797 same as the equality coercions generated for newtypes
798 in System Fc. The idea is to perform a sort of rewriting,
799 taking those equations as rules, before launching unification.
800
801 The caller must ensure the following.
802 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
803 The 2nd type (rhs) comes from a DataCon type signature.
804 Rewriting (i.e. adding/removing a newtype wrapper) can happen
805 in both types, but in the rhs it is restricted to the result type.
806
807 Note that it is very tricky to make this 'rewriting'
808 work with the unification implemented by TcM, where
809 substitutions are operationally inlined. The order in which
810 constraints are unified is vital as we cannot modify
811 anything that has been touched by a previous unification step.
812 Therefore, congruenceNewtypes is sound only if the types
813 recovered by the RTTI mechanism are unified Top-Down.
814 -}
815 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
816 congruenceNewtypes lhs rhs
817 -- TyVar lhs inductive case
818 | Just tv <- getTyVar_maybe lhs
819 = recoverTc (return (lhs,rhs)) $ do
820 Indirect ty_v <- readMetaTyVar tv
821 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
822 return (lhs, rhs1)
823 -- FunTy inductive case
824 | Just (l1,l2) <- splitFunTy_maybe lhs
825 , Just (r1,r2) <- splitFunTy_maybe rhs
826 = do (l2',r2') <- congruenceNewtypes l2 r2
827 (l1',r1') <- congruenceNewtypes l1 r1
828 return (mkFunTy l1' l2', mkFunTy r1' r2')
829 -- TyconApp Inductive case; this is the interesting bit.
830 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
831 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
832 , tycon_l /= tycon_r
833 = do rhs' <- upgrade tycon_l rhs
834 return (lhs, rhs')
835
836 | otherwise = return (lhs,rhs)
837
838 where upgrade :: TyCon -> Type -> TR Type
839 upgrade new_tycon ty
840 | not (isNewTyCon new_tycon) = return ty
841 | otherwise = do
842 vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
843 let ty' = mkTyConApp new_tycon vars
844 liftTcM (unifyType ty (repType ty'))
845 -- assumes that reptype doesn't ^^^^ touch tyconApp args
846 return ty'
847
848
849 --------------------------------------------------------------------------------
850 -- Semantically different to recoverM in TcRnMonad
851 -- recoverM retains the errors in the first action,
852 -- whereas recoverTc here does not
853 recoverTc :: TcM a -> TcM a -> TcM a
854 recoverTc recover thing = do
855 (_,mb_res) <- tryTcErrs thing
856 case mb_res of
857 Nothing -> recover
858 Just res -> return res
859
860 isMonomorphic :: Type -> Bool
861 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
862 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
863
864 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
865 mapMif pred f xx = sequence $ mapMif_ pred f xx
866 where
867 mapMif_ _ _ [] = []
868 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
869
870 unlessM :: Monad m => m Bool -> m () -> m ()
871 unlessM condM acc = condM >>= \c -> unless c acc
872
873 -- Strict application of f at index i
874 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
875 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
876 = ASSERT (i < length(elems a))
877 case indexArray# ptrs# i# of
878 (# e #) -> f e
879
880 zonkTerm :: Term -> TcM Term
881 zonkTerm = foldTerm idTermFoldM {
882 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
883 zonkTcType ty >>= \ty' ->
884 return (Term ty' dc v tt)
885 ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty ->
886 return (Suspension ct ty v b)
887 ,fNewtypeWrap= \ty dc t ->
888 return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t}
889
890
891 -- Is this defined elsewhere?
892 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
893 sigmaType :: Type -> Type
894 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
895
896