Fix assertions in RtClosureInspect
[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 pprTerm,
18 cPprTerm,
19 cPprTermBase,
20 termType,
21 foldTerm,
22 TermFold(..),
23 idTermFold,
24 idTermFoldM,
25 isFullyEvaluated,
26 isPointed,
27 isFullyEvaluatedTerm,
28 mapTermType,
29 termTyVars,
30 -- unsafeDeepSeq,
31 cvReconstructType,
32 computeRTTIsubst,
33 sigmaType,
34 Closure(..),
35 getClosureData,
36 ClosureType(..),
37 isConstr,
38 isIndirection
39 ) where
40
41 #include "HsVersions.h"
42
43 import ByteCodeItbls ( StgInfoTable )
44 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
45 import HscTypes ( HscEnv )
46 import Linker
47
48 import DataCon
49 import Type
50 import TcRnMonad ( TcM, initTc, ioToTcRn,
51 tryTcErrs)
52 import TcType
53 import TcMType
54 import TcUnify
55 import TcGadt
56 import TcEnv
57 import DriverPhases
58 import TyCon
59 import Name
60 import VarEnv
61 import Util
62 import VarSet
63
64 import TysPrim
65 import PrelNames
66 import TysWiredIn
67
68 import Constants
69 import Outputable
70 import Maybes
71 import Panic
72
73 import GHC.Arr ( Array(..) )
74 import GHC.Exts
75
76 import Control.Monad
77 import Data.Maybe
78 import Data.Array.Base
79 import Data.Ix
80 import Data.List ( partition )
81 import qualified Data.Sequence as Seq
82 import Data.Monoid
83 import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse)
84 import Foreign
85 import System.IO.Unsafe
86
87 ---------------------------------------------
88 -- * A representation of semi evaluated Terms
89 ---------------------------------------------
90 {-
91 A few examples in this representation:
92
93 > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
94
95 > (('a',_,_),_,('b',_,_)) =
96 Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
97 [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
98 , Suspension
99 , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
100 -}
101
102 data Term = Term { ty :: Type
103 , dc :: Either String DataCon
104 -- The heap datacon. If ty is a newtype,
105 -- this is NOT the newtype datacon.
106 -- Empty if the datacon aint exported by the .hi
107 -- (private constructors in -O0 libraries)
108 , val :: HValue
109 , subTerms :: [Term] }
110
111 | Prim { ty :: Type
112 , value :: [Word] }
113
114 | Suspension { ctype :: ClosureType
115 , mb_ty :: Maybe Type
116 , val :: HValue
117 , bound_to :: Maybe Name -- Useful for printing
118 }
119
120 isTerm, isSuspension, isPrim :: Term -> Bool
121 isTerm Term{} = True
122 isTerm _ = False
123 isSuspension Suspension{} = True
124 isSuspension _ = False
125 isPrim Prim{} = True
126 isPrim _ = False
127
128 termType :: Term -> Maybe Type
129 termType t@(Suspension {}) = mb_ty t
130 termType t = Just$ ty t
131
132 isFullyEvaluatedTerm :: Term -> Bool
133 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
134 isFullyEvaluatedTerm Suspension {} = False
135 isFullyEvaluatedTerm Prim {} = True
136
137 instance Outputable (Term) where
138 ppr = head . cPprTerm cPprTermBase
139
140 -------------------------------------------------------------------------
141 -- Runtime Closure Datatype and functions for retrieving closure related stuff
142 -------------------------------------------------------------------------
143 data ClosureType = Constr
144 | Fun
145 | Thunk Int
146 | ThunkSelector
147 | Blackhole
148 | AP
149 | PAP
150 | Indirection Int
151 | Other Int
152 deriving (Show, Eq)
153
154 data Closure = Closure { tipe :: ClosureType
155 , infoPtr :: Ptr ()
156 , infoTable :: StgInfoTable
157 , ptrs :: Array Int HValue
158 , nonPtrs :: [Word]
159 }
160
161 instance Outputable ClosureType where
162 ppr = text . show
163
164 #include "../includes/ClosureTypes.h"
165
166 aP_CODE, pAP_CODE :: Int
167 aP_CODE = AP
168 pAP_CODE = PAP
169 #undef AP
170 #undef PAP
171
172 getClosureData :: a -> IO Closure
173 getClosureData a =
174 case unpackClosure# a of
175 (# iptr, ptrs, nptrs #) -> do
176 itbl <- peek (Ptr iptr)
177 let tipe = readCType (BCI.tipe itbl)
178 elems = fromIntegral (BCI.ptrs itbl)
179 ptrsList = Array 0 (elems - 1) elems ptrs
180 nptrs_data = [W# (indexWordArray# nptrs i)
181 | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
182 ASSERT(elems >= 0) return ()
183 ptrsList `seq`
184 return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
185
186 readCType :: Integral a => a -> ClosureType
187 readCType i
188 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
189 | i >= FUN && i <= FUN_STATIC = Fun
190 | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i)
191 | i == THUNK_SELECTOR = ThunkSelector
192 | i == BLACKHOLE = Blackhole
193 | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
194 | fromIntegral i == aP_CODE = AP
195 | i == AP_STACK = AP
196 | fromIntegral i == pAP_CODE = PAP
197 | otherwise = Other (fromIntegral i)
198
199 isConstr, isIndirection, isThunk :: ClosureType -> Bool
200 isConstr Constr = True
201 isConstr _ = False
202
203 isIndirection (Indirection _) = True
204 --isIndirection ThunkSelector = True
205 isIndirection _ = False
206
207 isThunk (Thunk _) = True
208 isThunk ThunkSelector = True
209 isThunk AP = True
210 isThunk _ = False
211
212 isFullyEvaluated :: a -> IO Bool
213 isFullyEvaluated a = do
214 closure <- getClosureData a
215 case tipe closure of
216 Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
217 return$ and are_subs_evaluated
218 _ -> return False
219 where amapM f = sequence . amap' f
220
221 amap' :: (t -> b) -> Array Int t -> [b]
222 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
223 where g (I# i#) = case indexArray# arr# i# of
224 (# e #) -> f e
225
226 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
227 {-
228 unsafeDeepSeq :: a -> b -> b
229 unsafeDeepSeq = unsafeDeepSeq1 2
230 where unsafeDeepSeq1 0 a b = seq a $! b
231 unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
232 | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
233 -- | unsafePerformIO (isFullyEvaluated a) = b
234 | otherwise = case unsafePerformIO (getClosureData a) of
235 closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
236 where tipe = unsafePerformIO (getClosureType a)
237 -}
238 isPointed :: Type -> Bool
239 isPointed t | Just (t, _) <- splitTyConApp_maybe t
240 = not$ isUnliftedTypeKind (tyConKind t)
241 isPointed _ = True
242
243 extractUnboxed :: [Type] -> Closure -> [[Word]]
244 extractUnboxed tt clos = go tt (nonPtrs clos)
245 where sizeofType t
246 | Just (tycon,_) <- splitTyConApp_maybe t
247 = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
248 | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
249 go [] _ = []
250 go (t:tt) xx
251 | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx
252 = x : go tt rest
253
254 sizeofTyCon :: TyCon -> Int
255 sizeofTyCon = sizeofPrimRep . tyConPrimRep
256
257 -----------------------------------
258 -- * Traversals for Terms
259 -----------------------------------
260 type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b
261
262 data TermFold a = TermFold { fTerm :: TermProcessor a a
263 , fPrim :: Type -> [Word] -> a
264 , fSuspension :: ClosureType -> Maybe Type -> HValue
265 -> Maybe Name -> a
266 }
267
268 foldTerm :: TermFold a -> Term -> a
269 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
270 foldTerm tf (Prim ty v ) = fPrim tf ty v
271 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
272
273 idTermFold :: TermFold Term
274 idTermFold = TermFold {
275 fTerm = Term,
276 fPrim = Prim,
277 fSuspension = Suspension
278 }
279 idTermFoldM :: Monad m => TermFold (m Term)
280 idTermFoldM = TermFold {
281 fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
282 fPrim = (return.). Prim,
283 fSuspension = (((return.).).). Suspension
284 }
285
286 mapTermType :: (Type -> Type) -> Term -> Term
287 mapTermType f = foldTerm idTermFold {
288 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
289 fSuspension = \ct mb_ty hval n ->
290 Suspension ct (fmap f mb_ty) hval n }
291
292 termTyVars :: Term -> TyVarSet
293 termTyVars = foldTerm TermFold {
294 fTerm = \ty _ _ tt ->
295 tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
296 fSuspension = \_ mb_ty _ _ ->
297 maybe emptyVarEnv tyVarsOfType mb_ty,
298 fPrim = \ _ _ -> emptyVarEnv }
299 where concatVarEnv = foldr plusVarEnv emptyVarEnv
300 ----------------------------------
301 -- Pretty printing of terms
302 ----------------------------------
303
304 app_prec,cons_prec ::Int
305 app_prec = 10
306 cons_prec = 5 -- TODO Extract this info from GHC itself
307
308 pprTerm :: (Int -> Term -> Maybe SDoc) -> Int -> Term -> SDoc
309 pprTerm y p t | Just doc <- pprTermM y p t = doc
310 pprTerm _ _ _ = panic "pprTerm"
311
312 pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
313 pprTermM y p Term{dc=Left dc_tag, subTerms=tt} = do
314 tt_docs <- mapM (y app_prec) tt
315 return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
316
317 pprTermM y p t@Term{dc=Right dc, subTerms=tt, ty=ty}
318 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
319 = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2)
320 <+> hsep (map (pprTerm1 True) tt)
321 -} -- TODO Printing infix constructors properly
322 | null tt = return$ ppr dc
323 | Just (tc,_) <- splitNewTyConApp_maybe ty
324 , isNewTyCon tc
325 , Just new_dc <- maybeTyConSingleCon tc = do
326 real_value <- y 10 t{ty=repType ty}
327 return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
328 | otherwise = do
329 tt_docs <- mapM (y app_prec) tt
330 return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)
331
332 pprTermM _ _ t = pprTermM1 t
333
334 pprTermM1 :: Monad m => Term -> m SDoc
335 pprTermM1 Prim{value=words, ty=ty} =
336 return$ text$ repPrim (tyConAppTyCon ty) words
337 pprTermM1 Term{} = panic "pprTermM1 - unreachable"
338 pprTermM1 Suspension{bound_to=Nothing} = return$ char '_'
339 pprTermM1 Suspension{mb_ty=Just ty, bound_to=Just n}
340 | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
341 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
342 pprTermM1 _ = panic "pprTermM1"
343
344 type CustomTermPrinter m = Int -> TermProcessor Term (m (Maybe SDoc))
345
346 -- Takes a list of custom printers with a explicit recursion knot and a term,
347 -- and returns the output of the first succesful printer, or the default printer
348 cPprTerm :: Monad m =>
349 ((Int->Term->m SDoc)->[CustomTermPrinter m]) -> Term -> m SDoc
350 cPprTerm printers_ = go 0 where
351 printers = printers_ go
352 go prec t@(Term ty dc val tt) = do
353 let default_ = Just `liftM` pprTermM go prec t
354 mb_customDocs = [pp prec ty dc val tt | pp <- printers] ++ [default_]
355 Just doc <- firstJustM mb_customDocs
356 return$ cparen (prec>app_prec+1) doc
357 go _ t = pprTermM1 t
358 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
359 firstJustM [] = return Nothing
360
361 -- Default set of custom printers. Note that the recursion knot is explicit
362 cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[CustomTermPrinter m]
363 cPprTermBase y =
364 [
365 ifTerm isTupleTy (\ _ _ tt ->
366 liftM (parens . hcat . punctuate comma)
367 . mapM (y (-1))
368 $ tt)
369 , ifTerm (\ty tt -> isTyCon listTyCon ty tt && tt `lengthIs` 2)
370 (\ p _ [h,t] -> doList p h t)
371 , ifTerm (isTyCon intTyCon) (coerceShow$ \(a::Int)->a)
372 , ifTerm (isTyCon charTyCon) (coerceShow$ \(a::Char)->a)
373 -- , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
374 , ifTerm (isTyCon floatTyCon) (coerceShow$ \(a::Float)->a)
375 , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
376 , ifTerm isIntegerTy (coerceShow$ \(a::Integer)->a)
377 ]
378 where ifTerm pred f prec ty _ val tt
379 | pred ty tt = liftM Just (f prec val tt)
380 | otherwise = return Nothing
381 isIntegerTy ty _ = fromMaybe False $ do
382 (tc,_) <- splitTyConApp_maybe ty
383 return (tyConName tc == integerTyConName)
384 isTupleTy ty _ = fromMaybe False $ do
385 (tc,_) <- splitTyConApp_maybe ty
386 return (tc `elem` (fst.unzip.elems) boxedTupleArr)
387 isTyCon a_tc ty _ = fromMaybe False $ do
388 (tc,_) <- splitTyConApp_maybe ty
389 return (a_tc == tc)
390 coerceShow f _ val _ = (return . text . show . f . unsafeCoerce#) val
391 --TODO pprinting of list terms is not lazy
392 doList p h t = do
393 let elems = h : getListTerms t
394 isConsLast = termType(last elems) /= termType h
395 print_elems <- mapM (y cons_prec) elems
396 return$ if isConsLast
397 then cparen (p >= cons_prec)
398 . hsep
399 . punctuate (space<>colon)
400 $ print_elems
401 else brackets (hcat$ punctuate comma print_elems)
402
403 where Just a /= Just b = not (a `coreEqType` b)
404 _ /= _ = True
405 getListTerms Term{subTerms=[h,t]} = h : getListTerms t
406 getListTerms Term{subTerms=[]} = []
407 getListTerms t@Suspension{} = [t]
408 getListTerms t = pprPanic "getListTerms" (ppr t)
409
410
411 repPrim :: TyCon -> [Word] -> String
412 repPrim t = rep where
413 rep x
414 | t == charPrimTyCon = show (build x :: Char)
415 | t == intPrimTyCon = show (build x :: Int)
416 | t == wordPrimTyCon = show (build x :: Word)
417 | t == floatPrimTyCon = show (build x :: Float)
418 | t == doublePrimTyCon = show (build x :: Double)
419 | t == int32PrimTyCon = show (build x :: Int32)
420 | t == word32PrimTyCon = show (build x :: Word32)
421 | t == int64PrimTyCon = show (build x :: Int64)
422 | t == word64PrimTyCon = show (build x :: Word64)
423 | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
424 | t == stablePtrPrimTyCon = "<stablePtr>"
425 | t == stableNamePrimTyCon = "<stableName>"
426 | t == statePrimTyCon = "<statethread>"
427 | t == realWorldTyCon = "<realworld>"
428 | t == threadIdPrimTyCon = "<ThreadId>"
429 | t == weakPrimTyCon = "<Weak>"
430 | t == arrayPrimTyCon = "<array>"
431 | t == byteArrayPrimTyCon = "<bytearray>"
432 | t == mutableArrayPrimTyCon = "<mutableArray>"
433 | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
434 | t == mutVarPrimTyCon= "<mutVar>"
435 | t == mVarPrimTyCon = "<mVar>"
436 | t == tVarPrimTyCon = "<tVar>"
437 | otherwise = showSDoc (char '<' <> ppr t <> char '>')
438 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
439 -- This ^^^ relies on the representation of Haskell heap values being
440 -- the same as in a C array.
441
442 -----------------------------------
443 -- Type Reconstruction
444 -----------------------------------
445 {-
446 Type Reconstruction is type inference done on heap closures.
447 The algorithm walks the heap generating a set of equations, which
448 are solved with syntactic unification.
449 A type reconstruction equation looks like:
450
451 <datacon reptype> = <actual heap contents>
452
453 The full equation set is generated by traversing all the subterms, starting
454 from a given term.
455
456 The only difficult part is that newtypes are only found in the lhs of equations.
457 Right hand sides are missing them. We can either (a) drop them from the lhs, or
458 (b) reconstruct them in the rhs when possible.
459
460 The function congruenceNewtypes takes a shot at (b)
461 -}
462
463 -- The Type Reconstruction monad
464 type TR a = TcM a
465
466 runTR :: HscEnv -> TR a -> IO a
467 runTR hsc_env c = do
468 mb_term <- runTR_maybe hsc_env c
469 case mb_term of
470 Nothing -> panic "Can't unify"
471 Just x -> return x
472
473 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
474 runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
475
476 trIO :: IO a -> TR a
477 trIO = liftTcM . ioToTcRn
478
479 liftTcM :: TcM a -> TR a
480 liftTcM = id
481
482 newVar :: Kind -> TR TcType
483 newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
484
485 -- | Returns the instantiated type scheme ty', and the substitution sigma
486 -- such that sigma(ty') = ty
487 instScheme :: Type -> TR (TcType, TvSubst)
488 instScheme ty | (tvs, _rho) <- tcSplitForAllTys ty = liftTcM$ do
489 (tvs',_theta,ty') <- tcInstType (mapM tcInstTyVar) ty
490 return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
491
492 -- Adds a constraint of the form t1 == t2
493 -- t1 is expected to come from walking the heap
494 -- t2 is expected to come from a datacon signature
495 -- Before unification, congruenceNewtypes needs to
496 -- do its magic.
497 addConstraint :: TcType -> TcType -> TR ()
498 addConstraint t1 t2 = congruenceNewtypes t1 t2 >>= uncurry unifyType
499 >> return () -- TOMDO: what about the coercion?
500 -- we should consider family instances
501
502 -- Type & Term reconstruction
503 cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
504 cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
505 tv <- newVar argTypeKind
506 case mb_ty of
507 Nothing -> go bound tv tv hval >>= zonkTerm
508 Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
509 Just ty -> do
510 (ty',rev_subst) <- instScheme (sigmaType ty)
511 addConstraint tv ty'
512 term <- go bound tv tv hval >>= zonkTerm
513 --restore original Tyvars
514 return$ mapTermType (substTy rev_subst) term
515 where
516 go bound _ _ _ | seq bound False = undefined
517 go 0 tv _ty a = do
518 clos <- trIO $ getClosureData a
519 return (Suspension (tipe clos) (Just tv) a Nothing)
520 go bound tv ty a = do
521 let monomorphic = not(isTyVarTy tv)
522 -- This ^^^ is a convention. The ancestor tests for
523 -- monomorphism and passes a type instead of a tv
524 clos <- trIO $ getClosureData a
525 case tipe clos of
526 -- Thunks we may want to force
527 -- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never
528 -- force blackholes, because it would almost certainly result in deadlock,
529 -- and showing the '_' is more useful.
530 t | isThunk t && force -> seq a $ go (pred bound) tv ty a
531 -- We always follow indirections
532 Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
533 -- The interesting case
534 Constr -> do
535 Right dcname <- dataConInfoPtrToName (infoPtr clos)
536 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
537 case mb_dc of
538 Nothing -> do -- This can happen for private constructors compiled -O0
539 -- where the .hi descriptor does not export them
540 -- In such case, we return a best approximation:
541 -- ignore the unpointed args, and recover the pointeds
542 -- This preserves laziness, and should be safe.
543 let tag = showSDoc (ppr dcname)
544 vars <- replicateM (length$ elems$ ptrs clos)
545 (newVar (liftedTypeKind))
546 subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i
547 | (i, tv) <- zip [0..] vars]
548 return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
549 Just dc -> do
550 let extra_args = length(dataConRepArgTys dc) -
551 length(dataConOrigArgTys dc)
552 subTtypes = matchSubTypes dc ty
553 (subTtypesP, subTtypesNP) = partition isPointed subTtypes
554 subTermTvs <- sequence
555 [ if isMonomorphic t then return t
556 else (newVar k)
557 | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
558 -- It is vital for newtype reconstruction that the unification step
559 -- is done right here, _before_ the subterms are RTTI reconstructed
560 when (not monomorphic) $ do
561 let myType = mkFunTys (reOrderTerms subTermTvs
562 subTtypesNP
563 subTtypes)
564 tv
565 (signatureType,_) <- instScheme(dataConRepType dc)
566 addConstraint myType signatureType
567 subTermsP <- sequence $ drop extra_args
568 -- ^^^ all extra arguments are pointed
569 [ appArr (go (pred bound) tv t) (ptrs clos) i
570 | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
571 let unboxeds = extractUnboxed subTtypesNP clos
572 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
573 subTerms = reOrderTerms subTermsP subTermsNP
574 (drop extra_args subTtypes)
575 return (Term tv (Right dc) a subTerms)
576 -- The otherwise case: can be a Thunk,AP,PAP,etc.
577 tipe_clos ->
578 return (Suspension tipe_clos (Just tv) a Nothing)
579
580 -- matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
581 matchSubTypes dc ty
582 | Just (_,ty_args) <- splitTyConApp_maybe (repType ty)
583 -- assumption: ^^^ looks through newtypes
584 , isVanillaDataCon dc --TODO non-vanilla case
585 = dataConInstArgTys dc ty_args
586 | otherwise = dataConRepArgTys dc
587
588 -- This is used to put together pointed and nonpointed subterms in the
589 -- correct order.
590 reOrderTerms _ _ [] = []
591 reOrderTerms pointed unpointed (ty:tys)
592 | isPointed ty = ASSERT2(not(null pointed)
593 , ptext SLIT("reOrderTerms") $$
594 (ppr pointed $$ ppr unpointed))
595 head pointed : reOrderTerms (tail pointed) unpointed tys
596 | otherwise = ASSERT2(not(null unpointed)
597 , ptext SLIT("reOrderTerms") $$
598 (ppr pointed $$ ppr unpointed))
599 head unpointed : reOrderTerms pointed (tail unpointed) tys
600
601
602
603 -- Fast, breadth-first Type reconstruction
604 cvReconstructType :: HscEnv -> Int -> Maybe Type -> HValue -> IO (Maybe Type)
605 cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do
606 tv <- newVar argTypeKind
607 case mb_ty of
608 Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
609 (uncurry go)
610 (Seq.singleton (tv, hval))
611 max_depth
612 zonkTcType tv -- TODO untested!
613 Just ty | isMonomorphic ty -> return ty
614 Just ty -> do
615 (ty',rev_subst) <- instScheme (sigmaType ty)
616 addConstraint tv ty'
617 search (isMonomorphic `fmap` zonkTcType tv)
618 (\(ty,a) -> go ty a)
619 (Seq.singleton (tv, hval))
620 max_depth
621 substTy rev_subst `fmap` zonkTcType tv
622 where
623 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
624 search _ _ _ 0 = fail$ "Failed to reconstruct a type after " ++
625 show max_depth ++ " steps"
626 search stop expand l d =
627 case viewl l of
628 EmptyL -> return ()
629 x :< xx -> unlessM stop $ do
630 new <- expand x
631 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
632
633 -- returns unification tasks,since we are going to want a breadth-first search
634 go :: Type -> HValue -> TR [(Type, HValue)]
635 go tv a = do
636 clos <- trIO $ getClosureData a
637 case tipe clos of
638 Indirection _ -> go tv $! (ptrs clos ! 0)
639 Constr -> do
640 Right dcname <- dataConInfoPtrToName (infoPtr clos)
641 (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
642 case mb_dc of
643 Nothing-> do
644 -- TODO: Check this case
645 forM [0..length (elems $ ptrs clos)] $ \i -> do
646 tv <- newVar liftedTypeKind
647 return$ appArr (\e->(tv,e)) (ptrs clos) i
648
649 Just dc -> do
650 let extra_args = length(dataConRepArgTys dc) -
651 length(dataConOrigArgTys dc)
652 subTtypes <- mapMif (not . isMonomorphic)
653 (\t -> newVar (typeKind t))
654 (dataConRepArgTys dc)
655
656 -- It is vital for newtype reconstruction that the unification step
657 -- is done right here, _before_ the subterms are RTTI reconstructed
658 let myType = mkFunTys subTtypes tv
659 (signatureType,_) <- instScheme(dataConRepType dc)
660 addConstraint myType signatureType
661 return $ [ appArr (\e->(t,e)) (ptrs clos) i
662 | (i,t) <- drop extra_args $
663 zip [0..] (filter isPointed subTtypes)]
664 _ -> return []
665
666 -- This helper computes the difference between a base type t and the
667 -- improved rtti_t computed by RTTI
668 -- The main difference between RTTI types and their normal counterparts
669 -- is that the former are _not_ polymorphic, thus polymorphism must
670 -- be stripped. Syntactically, forall's must be stripped
671 computeRTTIsubst :: Type -> Type -> Maybe TvSubst
672 computeRTTIsubst ty rtti_ty =
673 -- In addition, we strip newtypes too, since the reconstructed type might
674 -- not have recovered them all
675 tcUnifyTys (const BindMe)
676 [repType' $ dropForAlls$ ty]
677 [repType' $ rtti_ty]
678 -- TODO stripping newtypes shouldn't be necessary, test
679
680
681 -- Dealing with newtypes
682 {-
683 A parallel fold over two Type values,
684 compensating for missing newtypes on both sides.
685 This is necessary because newtypes are not present
686 in runtime, but since sometimes there is evidence
687 available we do our best to reconstruct them.
688 Evidence can come from DataCon signatures or
689 from compile-time type inference.
690 I am using the words congruence and rewriting
691 because what we are doing here is an approximation
692 of unification modulo a set of equations, which would
693 come from newtype definitions. These should be the
694 equality coercions seen in System Fc. Rewriting
695 is performed, taking those equations as rules,
696 before launching unification.
697
698 It doesn't make sense to rewrite everywhere,
699 or we would end up with all newtypes. So we rewrite
700 only in presence of evidence.
701 The lhs comes from the heap structure of ptrs,nptrs.
702 The rhs comes from a DataCon type signature.
703 Rewriting in the rhs is restricted to the result type.
704
705 Note that it is very tricky to make this 'rewriting'
706 work with the unification implemented by TcM, where
707 substitutions are 'inlined'. The order in which
708 constraints are unified is vital for this (or I am
709 using TcM wrongly).
710 -}
711 congruenceNewtypes :: TcType -> TcType -> TcM (TcType,TcType)
712 congruenceNewtypes lhs rhs
713 -- TyVar lhs inductive case
714 | Just tv <- getTyVar_maybe lhs
715 = recoverTc (return (lhs,rhs)) $ do
716 Indirect ty_v <- readMetaTyVar tv
717 (_lhs1, rhs1) <- congruenceNewtypes ty_v rhs
718 return (lhs, rhs1)
719 -- FunTy inductive case
720 | Just (l1,l2) <- splitFunTy_maybe lhs
721 , Just (r1,r2) <- splitFunTy_maybe rhs
722 = do (l2',r2') <- congruenceNewtypes l2 r2
723 (l1',r1') <- congruenceNewtypes l1 r1
724 return (mkFunTy l1' l2', mkFunTy r1' r2')
725 -- TyconApp Inductive case; this is the interesting bit.
726 | Just (tycon_l, _) <- splitNewTyConApp_maybe lhs
727 , Just (tycon_r, _) <- splitNewTyConApp_maybe rhs
728 , tycon_l /= tycon_r
729 = return (lhs, upgrade tycon_l rhs)
730
731 | otherwise = return (lhs,rhs)
732
733 where upgrade :: TyCon -> Type -> Type
734 upgrade new_tycon ty
735 | not (isNewTyCon new_tycon) = ty
736 | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
737 , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
738 = substTy subst ty'
739 upgrade _ _ = panic "congruenceNewtypes.upgrade"
740 -- assumes that reptype doesn't touch tyconApp args ^^^
741
742
743 --------------------------------------------------------------------------------
744 -- Semantically different to recoverM in TcRnMonad
745 -- recoverM retains the errors in the first action,
746 -- whereas recoverTc here does not
747 recoverTc :: TcM a -> TcM a -> TcM a
748 recoverTc recover thing = do
749 (_,mb_res) <- tryTcErrs thing
750 case mb_res of
751 Nothing -> recover
752 Just res -> return res
753
754 isMonomorphic :: Type -> Bool
755 isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
756 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'
757
758 mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
759 mapMif pred f xx = sequence $ mapMif_ pred f xx
760 where
761 mapMif_ _ _ [] = []
762 mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
763
764 unlessM :: Monad m => m Bool -> m () -> m ()
765 unlessM condM acc = condM >>= \c -> unless c acc
766
767 -- Strict application of f at index i
768 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
769 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
770 = ASSERT (i < length(elems a))
771 case indexArray# ptrs# i# of
772 (# e #) -> f e
773
774 zonkTerm :: Term -> TcM Term
775 zonkTerm = foldTerm idTermFoldM {
776 fTerm = \ty dc v tt -> sequence tt >>= \tt ->
777 zonkTcType ty >>= \ty' ->
778 return (Term ty' dc v tt)
779 ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
780 return (Suspension ct ty v b)}
781
782
783 -- Is this defined elsewhere?
784 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
785 sigmaType :: Type -> Type
786 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
787
788