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