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