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