Update Trac ticket URLs to point to GitLab
[ghc.git] / compiler / ghci / RtClosureInspect.hs
1 {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- GHC Interactive support for inspecting arbitrary closures at runtime
6 --
7 -- Pepe Iborra (supported by Google SoC) 2006
8 --
9 -----------------------------------------------------------------------------
10 module RtClosureInspect(
11 -- * Entry points and types
12 cvObtainTerm,
13 cvReconstructType,
14 improveRTTIType,
15 Term(..),
16
17 -- * Utils
18 isFullyEvaluatedTerm,
19 termType, mapTermType, termTyCoVars,
20 foldTerm, TermFold(..),
21 cPprTerm, cPprTermBase,
22
23 constrClosToName -- exported to use in test T4891
24 ) where
25
26 #include "HsVersions.h"
27
28 import GhcPrelude
29
30 import GHCi
31 import GHCi.RemoteTypes
32 import HscTypes
33
34 import DataCon
35 import Type
36 import RepType
37 import qualified Unify as U
38 import Var
39 import TcRnMonad
40 import TcType
41 import TcMType
42 import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
43 import TcUnify
44 import TcEnv
45
46 import TyCon
47 import Name
48 import OccName
49 import Module
50 import IfaceEnv
51 import Util
52 import VarSet
53 import BasicTypes ( Boxity(..) )
54 import TysPrim
55 import PrelNames
56 import TysWiredIn
57 import DynFlags
58 import Outputable as Ppr
59 import GHC.Char
60 import GHC.Exts.Heap
61 import SMRep ( roundUpTo )
62
63 import Control.Monad
64 import Data.Maybe
65 import Data.List
66 #if defined(INTEGER_GMP)
67 import GHC.Exts
68 import Data.Array.Base
69 import GHC.Integer.GMP.Internals
70 #elif defined(INTEGER_SIMPLE)
71 import GHC.Exts
72 import GHC.Integer.Simple.Internals
73 #endif
74 import qualified Data.Sequence as Seq
75 import Data.Sequence (viewl, ViewL(..))
76 import Foreign
77 import System.IO.Unsafe
78
79
80 ---------------------------------------------
81 -- * A representation of semi evaluated Terms
82 ---------------------------------------------
83
84 data Term = Term { ty :: RttiType
85 , dc :: Either String DataCon
86 -- Carries a text representation if the datacon is
87 -- not exported by the .hi file, which is the case
88 -- for private constructors in -O0 compiled libraries
89 , val :: ForeignHValue
90 , subTerms :: [Term] }
91
92 | Prim { ty :: RttiType
93 , valRaw :: [Word] }
94
95 | Suspension { ctype :: ClosureType
96 , ty :: RttiType
97 , val :: ForeignHValue
98 , bound_to :: Maybe Name -- Useful for printing
99 }
100 | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
101 -- newtype constructors. A NewtypeWrap is just a
102 -- made-up tag saying "heads up, there used to be
103 -- a newtype constructor here".
104 ty :: RttiType
105 , dc :: Either String DataCon
106 , wrapped_term :: Term }
107 | RefWrap { -- The contents of a reference
108 ty :: RttiType
109 , wrapped_term :: Term }
110
111 termType :: Term -> RttiType
112 termType t = ty t
113
114 isFullyEvaluatedTerm :: Term -> Bool
115 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
116 isFullyEvaluatedTerm Prim {} = True
117 isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
118 isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
119 isFullyEvaluatedTerm _ = False
120
121 instance Outputable (Term) where
122 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
123 | otherwise = panic "Outputable Term instance"
124
125 ----------------------------------------
126 -- Runtime Closure information functions
127 ----------------------------------------
128
129 isThunk :: GenClosure a -> Bool
130 isThunk ThunkClosure{} = True
131 isThunk APClosure{} = True
132 isThunk APStackClosure{} = True
133 isThunk _ = False
134
135 -- Lookup the name in a constructor closure
136 constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
137 constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
138 let occName = mkOccName OccName.dataName occ
139 modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
140 Right `fmap` lookupOrigIO hsc_env modName occName
141 constrClosToName _hsc_env clos =
142 return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
143
144 -----------------------------------
145 -- * Traversals for Terms
146 -----------------------------------
147 type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
148
149 data TermFold a = TermFold { fTerm :: TermProcessor a a
150 , fPrim :: RttiType -> [Word] -> a
151 , fSuspension :: ClosureType -> RttiType -> ForeignHValue
152 -> Maybe Name -> a
153 , fNewtypeWrap :: RttiType -> Either String DataCon
154 -> a -> a
155 , fRefWrap :: RttiType -> a -> a
156 }
157
158
159 data TermFoldM m a =
160 TermFoldM {fTermM :: TermProcessor a (m a)
161 , fPrimM :: RttiType -> [Word] -> m a
162 , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue
163 -> Maybe Name -> m a
164 , fNewtypeWrapM :: RttiType -> Either String DataCon
165 -> a -> m a
166 , fRefWrapM :: RttiType -> a -> m a
167 }
168
169 foldTerm :: TermFold a -> Term -> a
170 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
171 foldTerm tf (Prim ty v ) = fPrim tf ty v
172 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
173 foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t)
174 foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t)
175
176
177 foldTermM :: Monad m => TermFoldM m a -> Term -> m a
178 foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
179 foldTermM tf (Prim ty v ) = fPrimM tf ty v
180 foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
181 foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc
182 foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty
183
184 idTermFold :: TermFold Term
185 idTermFold = TermFold {
186 fTerm = Term,
187 fPrim = Prim,
188 fSuspension = Suspension,
189 fNewtypeWrap = NewtypeWrap,
190 fRefWrap = RefWrap
191 }
192
193 mapTermType :: (RttiType -> Type) -> Term -> Term
194 mapTermType f = foldTerm idTermFold {
195 fTerm = \ty dc hval tt -> Term (f ty) dc hval tt,
196 fSuspension = \ct ty hval n ->
197 Suspension ct (f ty) hval n,
198 fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
199 fRefWrap = \ty t -> RefWrap (f ty) t}
200
201 mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term
202 mapTermTypeM f = foldTermM TermFoldM {
203 fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt,
204 fPrimM = (return.) . Prim,
205 fSuspensionM = \ct ty hval n ->
206 f ty >>= \ty' -> return $ Suspension ct ty' hval n,
207 fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
208 fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
209
210 termTyCoVars :: Term -> TyCoVarSet
211 termTyCoVars = foldTerm TermFold {
212 fTerm = \ty _ _ tt ->
213 tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
214 fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
215 fPrim = \ _ _ -> emptyVarSet,
216 fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
217 fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
218 where concatVarEnv = foldr unionVarSet emptyVarSet
219
220 ----------------------------------
221 -- Pretty printing of terms
222 ----------------------------------
223
224 type Precedence = Int
225 type TermPrinterM m = Precedence -> Term -> m SDoc
226
227 app_prec,cons_prec, max_prec ::Int
228 max_prec = 10
229 app_prec = max_prec
230 cons_prec = 5 -- TODO Extract this info from GHC itself
231
232 pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
233 pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
234
235 ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
236 tt_docs <- mapM (y app_prec) tt
237 return $ cparen (not (null tt) && p >= app_prec)
238 (text dc_tag <+> pprDeeperList fsep tt_docs)
239
240 ppr_termM y p Term{dc=Right dc, subTerms=tt}
241 {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
242 = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
243 <+> hsep (map (ppr_term1 True) tt)
244 -} -- TODO Printing infix constructors properly
245 = do { tt_docs' <- mapM (y app_prec) tt
246 ; return $ ifPprDebug (show_tm tt_docs')
247 (show_tm (dropList (dataConTheta dc) tt_docs'))
248 -- Don't show the dictionary arguments to
249 -- constructors unless -dppr-debug is on
250 }
251 where
252 show_tm tt_docs
253 | null tt_docs = ppr dc
254 | otherwise = cparen (p >= app_prec) $
255 sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
256
257 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
258 ppr_termM y p RefWrap{wrapped_term=t} = do
259 contents <- y app_prec t
260 return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
261 -- The constructor name is wired in here ^^^ for the sake of simplicity.
262 -- I don't think mutvars are going to change in a near future.
263 -- In any case this is solely a presentation matter: MutVar# is
264 -- a datatype with no constructors, implemented by the RTS
265 -- (hence there is no way to obtain a datacon and print it).
266 ppr_termM _ _ t = ppr_termM1 t
267
268
269 ppr_termM1 :: Monad m => Term -> m SDoc
270 ppr_termM1 Prim{valRaw=words, ty=ty} =
271 return $ repPrim (tyConAppTyCon ty) words
272 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
273 return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
274 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
275 -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
276 | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
277 ppr_termM1 Term{} = panic "ppr_termM1 - Term"
278 ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
279 ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
280
281 pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
282 | Just (tc,_) <- tcSplitTyConApp_maybe ty
283 , ASSERT(isNewTyCon tc) True
284 , Just new_dc <- tyConSingleDataCon_maybe tc = do
285 real_term <- y max_prec t
286 return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
287 pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
288
289 -------------------------------------------------------
290 -- Custom Term Pretty Printers
291 -------------------------------------------------------
292
293 -- We can want to customize the representation of a
294 -- term depending on its type.
295 -- However, note that custom printers have to work with
296 -- type representations, instead of directly with types.
297 -- We cannot use type classes here, unless we employ some
298 -- typerep trickery (e.g. Weirich's RepLib tricks),
299 -- which I didn't. Therefore, this code replicates a lot
300 -- of what type classes provide for free.
301
302 type CustomTermPrinter m = TermPrinterM m
303 -> [Precedence -> Term -> (m (Maybe SDoc))]
304
305 -- | Takes a list of custom printers with a explicit recursion knot and a term,
306 -- and returns the output of the first successful printer, or the default printer
307 cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
308 cPprTerm printers_ = go 0 where
309 printers = printers_ go
310 go prec t = do
311 let default_ = Just `liftM` pprTermM go prec t
312 mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
313 mdoc <- firstJustM mb_customDocs
314 case mdoc of
315 Nothing -> panic "cPprTerm"
316 Just doc -> return $ cparen (prec>app_prec+1) doc
317
318 firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
319 firstJustM [] = return Nothing
320
321 -- Default set of custom printers. Note that the recursion knot is explicit
322 cPprTermBase :: forall m. Monad m => CustomTermPrinter m
323 cPprTermBase y =
324 [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
325 . mapM (y (-1))
326 . subTerms)
327 , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
328 ppr_list
329 , ifTerm' (isTyCon intTyCon . ty) ppr_int
330 , ifTerm' (isTyCon charTyCon . ty) ppr_char
331 , ifTerm' (isTyCon floatTyCon . ty) ppr_float
332 , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
333 , ifTerm' (isIntegerTy . ty) ppr_integer
334 ]
335 where
336 ifTerm :: (Term -> Bool)
337 -> (Precedence -> Term -> m SDoc)
338 -> Precedence -> Term -> m (Maybe SDoc)
339 ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)
340
341 ifTerm' :: (Term -> Bool)
342 -> (Precedence -> Term -> m (Maybe SDoc))
343 -> Precedence -> Term -> m (Maybe SDoc)
344 ifTerm' pred f prec t@Term{}
345 | pred t = f prec t
346 ifTerm' _ _ _ _ = return Nothing
347
348 isTupleTy ty = fromMaybe False $ do
349 (tc,_) <- tcSplitTyConApp_maybe ty
350 return (isBoxedTupleTyCon tc)
351
352 isTyCon a_tc ty = fromMaybe False $ do
353 (tc,_) <- tcSplitTyConApp_maybe ty
354 return (a_tc == tc)
355
356 isIntegerTy ty = fromMaybe False $ do
357 (tc,_) <- tcSplitTyConApp_maybe ty
358 return (tyConName tc == integerTyConName)
359
360 ppr_int, ppr_char, ppr_float, ppr_double
361 :: Precedence -> Term -> m (Maybe SDoc)
362 ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
363 return (Just (Ppr.int (fromIntegral w)))
364 ppr_int _ _ = return Nothing
365
366 ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} =
367 return (Just (Ppr.pprHsChar (chr (fromIntegral w))))
368 ppr_char _ _ = return Nothing
369
370 ppr_float _ Term{subTerms=[Prim{valRaw=[w]}]} = do
371 let f = unsafeDupablePerformIO $
372 alloca $ \p -> poke p w >> peek (castPtr p)
373 return (Just (Ppr.float f))
374 ppr_float _ _ = return Nothing
375
376 ppr_double _ Term{subTerms=[Prim{valRaw=[w]}]} = do
377 let f = unsafeDupablePerformIO $
378 alloca $ \p -> poke p w >> peek (castPtr p)
379 return (Just (Ppr.double f))
380 -- let's assume that if we get two words, we're on a 32-bit
381 -- machine. There's no good way to get a DynFlags to check the word
382 -- size here.
383 ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do
384 let f = unsafeDupablePerformIO $
385 alloca $ \p -> do
386 poke p (fromIntegral w1 :: Word32)
387 poke (p `plusPtr` 4) (fromIntegral w2 :: Word32)
388 peek (castPtr p)
389 return (Just (Ppr.double f))
390 ppr_double _ _ = return Nothing
391
392 ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
393 #if defined(INTEGER_GMP)
394 -- Reconstructing Integers is a bit of a pain. This depends deeply
395 -- on the integer-gmp representation, so it'll break if that
396 -- changes (but there are several tests in
397 -- tests/ghci.debugger/scripts that will tell us if this is wrong).
398 --
399 -- data Integer
400 -- = S# Int#
401 -- | Jp# {-# UNPACK #-} !BigNat
402 -- | Jn# {-# UNPACK #-} !BigNat
403 --
404 -- data BigNat = BN# ByteArray#
405 --
406 ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
407 return (Just (Ppr.integer (S# (word2Int# w))))
408 ppr_integer _ Term{dc=Right con,
409 subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
410 -- We don't need to worry about sizes that are not an integral
411 -- number of words, because luckily GMP uses arrays of words
412 -- (see GMP_LIMB_SHIFT).
413 let
414 !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
415 constr
416 | "Jp#" <- getOccString (dataConName con) = Jp#
417 | otherwise = Jn#
418 return (Just (Ppr.integer (constr (BN# arr#))))
419 #elif defined(INTEGER_SIMPLE)
420 -- As with the GMP case, this depends deeply on the integer-simple
421 -- representation.
422 --
423 -- @
424 -- data Integer = Positive !Digits | Negative !Digits | Naught
425 --
426 -- data Digits = Some !Word# !Digits
427 -- | None
428 -- @
429 --
430 -- NB: the above has some type synonyms expanded out for the sake of brevity
431 ppr_integer _ Term{subTerms=[]} =
432 return (Just (Ppr.integer Naught))
433 ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]}
434 | Just digits <- get_digits digitTerm
435 = return (Just (Ppr.integer (constr digits)))
436 where
437 get_digits :: Term -> Maybe Digits
438 get_digits Term{subTerms=[]} = Just None
439 get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]}
440 = Some w <$> get_digits t
441 get_digits _ = Nothing
442
443 constr
444 | "Positive" <- getOccString (dataConName con) = Positive
445 | otherwise = Negative
446 #endif
447 ppr_integer _ _ = return Nothing
448
449 --Note pprinting of list terms is not lazy
450 ppr_list :: Precedence -> Term -> m SDoc
451 ppr_list p (Term{subTerms=[h,t]}) = do
452 let elems = h : getListTerms t
453 isConsLast = not (termType (last elems) `eqType` termType h)
454 is_string = all (isCharTy . ty) elems
455 chars = [ chr (fromIntegral w)
456 | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
457
458 print_elems <- mapM (y cons_prec) elems
459 if is_string
460 then return (Ppr.doubleQuotes (Ppr.text chars))
461 else if isConsLast
462 then return $ cparen (p >= cons_prec)
463 $ pprDeeperList fsep
464 $ punctuate (space<>colon) print_elems
465 else return $ brackets
466 $ pprDeeperList fcat
467 $ punctuate comma print_elems
468
469 where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
470 getListTerms Term{subTerms=[]} = []
471 getListTerms t@Suspension{} = [t]
472 getListTerms t = pprPanic "getListTerms" (ppr t)
473 ppr_list _ _ = panic "doList"
474
475
476 repPrim :: TyCon -> [Word] -> SDoc
477 repPrim t = rep where
478 rep x
479 -- Char# uses native machine words, whereas Char's Storable instance uses
480 -- Int32, so we have to read it as an Int.
481 | t == charPrimTyCon = text $ show (chr (build x :: Int))
482 | t == intPrimTyCon = text $ show (build x :: Int)
483 | t == wordPrimTyCon = text $ show (build x :: Word)
484 | t == floatPrimTyCon = text $ show (build x :: Float)
485 | t == doublePrimTyCon = text $ show (build x :: Double)
486 | t == int32PrimTyCon = text $ show (build x :: Int32)
487 | t == word32PrimTyCon = text $ show (build x :: Word32)
488 | t == int64PrimTyCon = text $ show (build x :: Int64)
489 | t == word64PrimTyCon = text $ show (build x :: Word64)
490 | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x)
491 | t == stablePtrPrimTyCon = text "<stablePtr>"
492 | t == stableNamePrimTyCon = text "<stableName>"
493 | t == statePrimTyCon = text "<statethread>"
494 | t == proxyPrimTyCon = text "<proxy>"
495 | t == realWorldTyCon = text "<realworld>"
496 | t == threadIdPrimTyCon = text "<ThreadId>"
497 | t == weakPrimTyCon = text "<Weak>"
498 | t == arrayPrimTyCon = text "<array>"
499 | t == smallArrayPrimTyCon = text "<smallArray>"
500 | t == byteArrayPrimTyCon = text "<bytearray>"
501 | t == mutableArrayPrimTyCon = text "<mutableArray>"
502 | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
503 | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
504 | t == mutVarPrimTyCon = text "<mutVar>"
505 | t == mVarPrimTyCon = text "<mVar>"
506 | t == tVarPrimTyCon = text "<tVar>"
507 | otherwise = char '<' <> ppr t <> char '>'
508 where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
509 -- This ^^^ relies on the representation of Haskell heap values being
510 -- the same as in a C array.
511
512 -----------------------------------
513 -- Type Reconstruction
514 -----------------------------------
515 {-
516 Type Reconstruction is type inference done on heap closures.
517 The algorithm walks the heap generating a set of equations, which
518 are solved with syntactic unification.
519 A type reconstruction equation looks like:
520
521 <datacon reptype> = <actual heap contents>
522
523 The full equation set is generated by traversing all the subterms, starting
524 from a given term.
525
526 The only difficult part is that newtypes are only found in the lhs of equations.
527 Right hand sides are missing them. We can either (a) drop them from the lhs, or
528 (b) reconstruct them in the rhs when possible.
529
530 The function congruenceNewtypes takes a shot at (b)
531 -}
532
533
534 -- A (non-mutable) tau type containing
535 -- existentially quantified tyvars.
536 -- (since GHC type language currently does not support
537 -- existentials, we leave these variables unquantified)
538 type RttiType = Type
539
540 -- An incomplete type as stored in GHCi:
541 -- no polymorphism: no quantifiers & all tyvars are skolem.
542 type GhciType = Type
543
544
545 -- The Type Reconstruction monad
546 --------------------------------
547 type TR a = TcM a
548
549 runTR :: HscEnv -> TR a -> IO a
550 runTR hsc_env thing = do
551 mb_val <- runTR_maybe hsc_env thing
552 case mb_val of
553 Nothing -> error "unable to :print the term"
554 Just x -> return x
555
556 runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
557 runTR_maybe hsc_env thing_inside
558 = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
559 ; return res }
560
561 -- | Term Reconstruction trace
562 traceTR :: SDoc -> TR ()
563 traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
564
565
566 -- Semantically different to recoverM in TcRnMonad
567 -- recoverM retains the errors in the first action,
568 -- whereas recoverTc here does not
569 recoverTR :: TR a -> TR a -> TR a
570 recoverTR = tryTcDiscardingErrs
571
572 trIO :: IO a -> TR a
573 trIO = liftTcM . liftIO
574
575 liftTcM :: TcM a -> TR a
576 liftTcM = id
577
578 newVar :: Kind -> TR TcType
579 newVar = liftTcM . newFlexiTyVarTy
580
581 newOpenVar :: TR TcType
582 newOpenVar = liftTcM newOpenFlexiTyVarTy
583
584 instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
585 -- Instantiate fresh mutable type variables from some TyVars
586 -- This function preserves the print-name, which helps error messages
587 instTyVars tvs
588 = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
589
590 type RttiInstantiation = [(TcTyVar, TyVar)]
591 -- Associates the typechecker-world meta type variables
592 -- (which are mutable and may be refined), to their
593 -- debugger-world RuntimeUnk counterparts.
594 -- If the TcTyVar has not been refined by the runtime type
595 -- elaboration, then we want to turn it back into the
596 -- original RuntimeUnk
597
598 -- | Returns the instantiated type scheme ty', and the
599 -- mapping from new (instantiated) -to- old (skolem) type variables
600 instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
601 instScheme (tvs, ty)
602 = do { (subst, tvs') <- instTyVars tvs
603 ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
604 ; return (substTy subst ty, rtti_inst) }
605
606 applyRevSubst :: RttiInstantiation -> TR ()
607 -- Apply the *reverse* substitution in-place to any un-filled-in
608 -- meta tyvars. This recovers the original debugger-world variable
609 -- unless it has been refined by new information from the heap
610 applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
611 where
612 do_pair (tc_tv, rtti_tv)
613 = do { tc_ty <- zonkTcTyVar tc_tv
614 ; case tcGetTyVar_maybe tc_ty of
615 Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
616 _ -> return () }
617
618 -- Adds a constraint of the form t1 == t2
619 -- t1 is expected to come from walking the heap
620 -- t2 is expected to come from a datacon signature
621 -- Before unification, congruenceNewtypes needs to
622 -- do its magic.
623 addConstraint :: TcType -> TcType -> TR ()
624 addConstraint actual expected = do
625 traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
626 recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
627 text "with", ppr expected]) $
628 discardResult $
629 captureConstraints $
630 do { (ty1, ty2) <- congruenceNewtypes actual expected
631 ; unifyType Nothing ty1 ty2 }
632 -- TOMDO: what about the coercion?
633 -- we should consider family instances
634
635
636 -- | Term reconstruction
637 --
638 -- Given a pointer to a heap object (`HValue`) and its type, build a `Term`
639 -- representation of the object. Subterms (objects in the payload) are also
640 -- built up to the given `max_depth`. After `max_depth` any subterms will appear
641 -- as `Suspension`s. Any thunks found while traversing the object will be forced
642 -- based on `force` parameter.
643 --
644 -- Types of terms will be refined based on constructors we find during term
645 -- reconstruction. See `cvReconstructType` for an overview of how type
646 -- reconstruction works.
647 --
648 cvObtainTerm
649 :: HscEnv
650 -> Int -- ^ How many times to recurse for subterms
651 -> Bool -- ^ Force thunks
652 -> RttiType -- ^ Type of the object to reconstruct
653 -> ForeignHValue -- ^ Object to reconstruct
654 -> IO Term
655 cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
656 -- we quantify existential tyvars as universal,
657 -- as this is needed to be able to manipulate
658 -- them properly
659 let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
660 sigma_old_ty = mkInvForAllTys old_tvs old_tau
661 traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
662 term <-
663 if null old_tvs
664 then do
665 term <- go max_depth sigma_old_ty sigma_old_ty hval
666 term' <- zonkTerm term
667 return $ fixFunDictionaries $ expandNewtypes term'
668 else do
669 (old_ty', rev_subst) <- instScheme quant_old_ty
670 my_ty <- newOpenVar
671 when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
672 addConstraint my_ty old_ty')
673 term <- go max_depth my_ty sigma_old_ty hval
674 new_ty <- zonkTcType (termType term)
675 if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
676 then do
677 traceTR (text "check2 passed")
678 addConstraint new_ty old_ty'
679 applyRevSubst rev_subst
680 zterm' <- zonkTerm term
681 return ((fixFunDictionaries . expandNewtypes) zterm')
682 else do
683 traceTR (text "check2 failed" <+> parens
684 (ppr term <+> text "::" <+> ppr new_ty))
685 -- we have unsound types. Replace constructor types in
686 -- subterms with tyvars
687 zterm' <- mapTermTypeM
688 (\ty -> case tcSplitTyConApp_maybe ty of
689 Just (tc, _:_) | tc /= funTyCon
690 -> newOpenVar
691 _ -> return ty)
692 term
693 zonkTerm zterm'
694 traceTR (text "Term reconstruction completed." $$
695 text "Term obtained: " <> ppr term $$
696 text "Type obtained: " <> ppr (termType term))
697 return term
698 where
699 go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
700 -- I believe that my_ty should not have any enclosing
701 -- foralls, nor any free RuntimeUnk skolems;
702 -- that is partly what the quantifyType stuff achieved
703 --
704 -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
705
706 go 0 my_ty _old_ty a = do
707 traceTR (text "Gave up reconstructing a term after" <>
708 int max_depth <> text " steps")
709 clos <- trIO $ GHCi.getClosure hsc_env a
710 return (Suspension (tipe (info clos)) my_ty a Nothing)
711 go !max_depth my_ty old_ty a = do
712 let monomorphic = not(isTyVarTy my_ty)
713 -- This ^^^ is a convention. The ancestor tests for
714 -- monomorphism and passes a type instead of a tv
715 clos <- trIO $ GHCi.getClosure hsc_env a
716 case clos of
717 -- Thunks we may want to force
718 t | isThunk t && force -> do
719 traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
720 liftIO $ GHCi.seqHValue hsc_env a
721 go (pred max_depth) my_ty old_ty a
722 -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If
723 -- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as
724 -- the suspension so that entering it in GHCi will enter the BLACKHOLE instead
725 -- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic).
726 BlackholeClosure{indirectee=ind} -> do
727 traceTR (text "Following a BLACKHOLE")
728 ind_clos <- trIO (GHCi.getClosure hsc_env ind)
729 let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)
730 case ind_clos of
731 -- TSO and BLOCKING_QUEUE cases
732 BlockingQueueClosure{} -> return_bh_value
733 OtherClosure info _ _
734 | tipe info == TSO -> return_bh_value
735 UnsupportedClosure info
736 | tipe info == TSO -> return_bh_value
737 -- Otherwise follow the indirectee
738 -- (NOTE: This code will break if we support TSO in ghc-heap one day)
739 _ -> go max_depth my_ty old_ty ind
740 -- We always follow indirections
741 IndClosure{indirectee=ind} -> do
742 traceTR (text "Following an indirection" )
743 go max_depth my_ty old_ty ind
744 -- We also follow references
745 MutVarClosure{var=contents}
746 | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
747 -> do
748 -- Deal with the MutVar# primitive
749 -- It does not have a constructor at all,
750 -- so we simulate the following one
751 -- MutVar# :: contents_ty -> MutVar# s contents_ty
752 traceTR (text "Following a MutVar")
753 contents_tv <- newVar liftedTypeKind
754 MASSERT(isUnliftedType my_ty)
755 (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy
756 contents_ty (mkTyConApp tycon [world,contents_ty])
757 addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty
758 x <- go (pred max_depth) contents_tv contents_ty contents
759 return (RefWrap my_ty x)
760
761 -- The interesting case
762 ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
763 traceTR (text "entering a constructor " <> ppr dArgs <+>
764 if monomorphic
765 then parens (text "already monomorphic: " <> ppr my_ty)
766 else Ppr.empty)
767 Right dcname <- liftIO $ constrClosToName hsc_env clos
768 (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
769 case mb_dc of
770 Nothing -> do -- This can happen for private constructors compiled -O0
771 -- where the .hi descriptor does not export them
772 -- In such case, we return a best approximation:
773 -- ignore the unpointed args, and recover the pointeds
774 -- This preserves laziness, and should be safe.
775 traceTR (text "Not constructor" <+> ppr dcname)
776 let dflags = hsc_dflags hsc_env
777 tag = showPpr dflags dcname
778 vars <- replicateM (length pArgs)
779 (newVar liftedTypeKind)
780 subTerms <- sequence $ zipWith (\x tv ->
781 go (pred max_depth) tv tv x) pArgs vars
782 return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
783 Just dc -> do
784 traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
785 subTtypes <- getDataConArgTys dc my_ty
786 subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
787 return (Term my_ty (Right dc) a subTerms)
788
789 -- This is to support printing of Integers. It's not a general
790 -- mechanism by any means; in particular we lose the size in
791 -- bytes of the array.
792 ArrWordsClosure{bytes=b, arrWords=ws} -> do
793 traceTR (text "ByteArray# closure, size " <> ppr b)
794 return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws])
795
796 -- The otherwise case: can be a Thunk,AP,PAP,etc.
797 _ -> do
798 traceTR (text "Unknown closure:" <+>
799 text (show (fmap (const ()) clos)))
800 return (Suspension (tipe (info clos)) my_ty a Nothing)
801
802 -- insert NewtypeWraps around newtypes
803 expandNewtypes = foldTerm idTermFold { fTerm = worker } where
804 worker ty dc hval tt
805 | Just (tc, args) <- tcSplitTyConApp_maybe ty
806 , isNewTyCon tc
807 , wrapped_type <- newTyConInstRhs tc args
808 , Just dc' <- tyConSingleDataCon_maybe tc
809 , t' <- worker wrapped_type dc hval tt
810 = NewtypeWrap ty (Right dc') t'
811 | otherwise = Term ty dc hval tt
812
813
814 -- Avoid returning types where predicates have been expanded to dictionaries.
815 fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
816 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
817 | otherwise = Suspension ct ty hval n
818
819 extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
820 -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
821 extractSubTerms recurse clos = liftM thdOf3 . go 0 0
822 where
823 array = dataArgs clos
824
825 go ptr_i arr_i [] = return (ptr_i, arr_i, [])
826 go ptr_i arr_i (ty:tys)
827 | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
828 , isUnboxedTupleTyCon tc
829 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
830 = do (ptr_i, arr_i, terms0) <-
831 go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
832 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
833 return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
834 | otherwise
835 = case typePrimRepArgs ty of
836 [rep_ty] -> do
837 (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty
838 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
839 return (ptr_i, arr_i, term0 : terms1)
840 rep_tys -> do
841 (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
842 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
843 return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
844
845 go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
846 go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
847 tv <- newVar liftedTypeKind
848 (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i tv rep_ty
849 (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
850 return (ptr_i, arr_i, term0 : terms1)
851
852 go_rep ptr_i arr_i ty rep
853 | isGcPtrRep rep = do
854 t <- recurse ty $ (ptrArgs clos)!!ptr_i
855 return (ptr_i + 1, arr_i, t)
856 | otherwise = do
857 -- This is a bit involved since we allow packing multiple fields
858 -- within a single word. See also
859 -- StgCmmLayout.mkVirtHeapOffsetsWithPadding
860 dflags <- getDynFlags
861 let word_size = wORD_SIZE dflags
862 big_endian = wORDS_BIGENDIAN dflags
863 size_b = primRepSizeB dflags rep
864 -- Align the start offset (eg, 2-byte value should be 2-byte
865 -- aligned). But not more than to a word. The offset calculation
866 -- should be the same with the offset calculation in
867 -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.
868 !aligned_idx = roundUpTo arr_i (min word_size size_b)
869 !new_arr_i = aligned_idx + size_b
870 ws | size_b < word_size =
871 [index size_b aligned_idx word_size big_endian]
872 | otherwise =
873 let (q, r) = size_b `quotRem` word_size
874 in ASSERT( r == 0 )
875 [ array!!i
876 | o <- [0.. q - 1]
877 , let i = (aligned_idx `quot` word_size) + o
878 ]
879 return (ptr_i, new_arr_i, Prim ty ws)
880
881 unboxedTupleTerm ty terms
882 = Term ty (Right (tupleDataCon Unboxed (length terms)))
883 (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
884
885 -- Extract a sub-word sized field from a word
886 index item_size_b index_b word_size big_endian =
887 (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
888 where
889 mask :: Word
890 mask = case item_size_b of
891 1 -> 0xFF
892 2 -> 0xFFFF
893 4 -> 0xFFFFFFFF
894 _ -> panic ("Weird byte-index: " ++ show index_b)
895 (q,r) = index_b `quotRem` word_size
896 word = array!!q
897 moveBytes = if big_endian
898 then word_size - (r + item_size_b) * 8
899 else r * 8
900
901
902 -- | Fast, breadth-first Type reconstruction
903 --
904 -- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually
905 -- obtained in GHCi), try to reconstruct a more monomorphic type of the object.
906 -- This is used for improving type information in debugger. For example, if we
907 -- have a polymorphic function:
908 --
909 -- sumNumList :: Num a => [a] -> a
910 -- sumNumList [] = 0
911 -- sumNumList (x : xs) = x + sumList xs
912 --
913 -- and add a breakpoint to it:
914 --
915 -- ghci> break sumNumList
916 -- ghci> sumNumList ([0 .. 9] :: [Int])
917 --
918 -- ghci shows us more precise types than just `a`s:
919 --
920 -- Stopped in Main.sumNumList, debugger.hs:3:23-39
921 -- _result :: Int = _
922 -- x :: Int = 0
923 -- xs :: [Int] = _
924 --
925 cvReconstructType
926 :: HscEnv
927 -> Int -- ^ How many times to recurse for subterms
928 -> GhciType -- ^ Type to refine
929 -> ForeignHValue -- ^ Refine the type using this value
930 -> IO (Maybe Type)
931 cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
932 traceTR (text "RTTI started with initial type " <> ppr old_ty)
933 let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
934 new_ty <-
935 if null old_tvs
936 then return old_ty
937 else do
938 (old_ty', rev_subst) <- instScheme sigma_old_ty
939 my_ty <- newOpenVar
940 when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
941 addConstraint my_ty old_ty')
942 search (isMonomorphic `fmap` zonkTcType my_ty)
943 (\(ty,a) -> go ty a)
944 (Seq.singleton (my_ty, hval))
945 max_depth
946 new_ty <- zonkTcType my_ty
947 if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
948 then do
949 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
950 addConstraint my_ty old_ty'
951 applyRevSubst rev_subst
952 zonkRttiType new_ty
953 else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
954 return old_ty
955 traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
956 return new_ty
957 where
958 -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
959 search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
960 int max_depth <> text " steps")
961 search stop expand l d =
962 case viewl l of
963 EmptyL -> return ()
964 x :< xx -> unlessM stop $ do
965 new <- expand x
966 search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
967
968 -- returns unification tasks,since we are going to want a breadth-first search
969 go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
970 go my_ty a = do
971 traceTR (text "go" <+> ppr my_ty)
972 clos <- trIO $ GHCi.getClosure hsc_env a
973 case clos of
974 BlackholeClosure{indirectee=ind} -> go my_ty ind
975 IndClosure{indirectee=ind} -> go my_ty ind
976 MutVarClosure{var=contents} -> do
977 tv' <- newVar liftedTypeKind
978 world <- newVar liftedTypeKind
979 addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
980 return [(tv', contents)]
981 ConstrClosure{ptrArgs=pArgs} -> do
982 Right dcname <- liftIO $ constrClosToName hsc_env clos
983 traceTR (text "Constr1" <+> ppr dcname)
984 (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
985 case mb_dc of
986 Nothing-> do
987 forM pArgs $ \x -> do
988 tv <- newVar liftedTypeKind
989 return (tv, x)
990
991 Just dc -> do
992 arg_tys <- getDataConArgTys dc my_ty
993 (_, itys) <- findPtrTyss 0 arg_tys
994 traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
995 return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs
996 _ -> return []
997
998 findPtrTys :: Int -- Current pointer index
999 -> Type -- Type
1000 -> TR (Int, [(Int, Type)])
1001 findPtrTys i ty
1002 | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
1003 , isUnboxedTupleTyCon tc
1004 = findPtrTyss i elem_tys
1005
1006 | otherwise
1007 = case typePrimRep ty of
1008 [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])
1009 | otherwise -> return (i, [])
1010 prim_reps ->
1011 foldM (\(i, extras) prim_rep ->
1012 if isGcPtrRep prim_rep
1013 then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
1014 else return (i, extras))
1015 (i, []) prim_reps
1016
1017 findPtrTyss :: Int
1018 -> [Type]
1019 -> TR (Int, [(Int, Type)])
1020 findPtrTyss i tys = foldM step (i, []) tys
1021 where step (i, discovered) elem_ty = do
1022 (i, extras) <- findPtrTys i elem_ty
1023 return (i, discovered ++ extras)
1024
1025
1026 -- Compute the difference between a base type and the type found by RTTI
1027 -- improveType <base_type> <rtti_type>
1028 -- The types can contain skolem type variables, which need to be treated as normal vars.
1029 -- In particular, we want them to unify with things.
1030 improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
1031 improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty
1032
1033 getDataConArgTys :: DataCon -> Type -> TR [Type]
1034 -- Given the result type ty of a constructor application (D a b c :: ty)
1035 -- return the types of the arguments. This is RTTI-land, so 'ty' might
1036 -- not be fully known. Moreover, the arg types might involve existentials;
1037 -- if so, make up fresh RTTI type variables for them
1038 --
1039 -- I believe that con_app_ty should not have any enclosing foralls
1040 getDataConArgTys dc con_app_ty
1041 = do { let rep_con_app_ty = unwrapType con_app_ty
1042 ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
1043 $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
1044 ; ASSERT( all isTyVar ex_tvs ) return ()
1045 -- ex_tvs can only be tyvars as data types in source
1046 -- Haskell cannot mention covar yet (Aug 2018)
1047 ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
1048 ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
1049 -- See Note [Constructor arg types]
1050 ; let con_arg_tys = substTys subst (dataConRepArgTys dc)
1051 ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst))
1052 ; return con_arg_tys }
1053 where
1054 univ_tvs = dataConUnivTyVars dc
1055 ex_tvs = dataConExTyCoVars dc
1056
1057 {- Note [Constructor arg types]
1058 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1059 Consider a GADT (cf #7386)
1060 data family D a b
1061 data instance D [a] a where
1062 MkT :: a -> D [a] (Maybe a)
1063 ...
1064
1065 In getDataConArgTys
1066 * con_app_ty is the known type (from outside) of the constructor application,
1067 say D [Int] Int
1068
1069 * The data constructor MkT has a (representation) dataConTyCon = DList,
1070 say where
1071 data DList a where
1072 MkT :: a -> DList a (Maybe a)
1073 ...
1074
1075 So the dataConTyCon of the data constructor, DList, differs from
1076 the "outside" type, D. So we can't straightforwardly decompose the
1077 "outside" type, and we end up in the "_" branch of the case.
1078
1079 Then we match the dataConOrigResTy of the data constructor against the
1080 outside type, hoping to get a substitution that tells how to instantiate
1081 the *representation* type constructor. This looks a bit delicate to
1082 me, but it seems to work.
1083 -}
1084
1085 -- Soundness checks
1086 --------------------
1087 {-
1088 This is not formalized anywhere, so hold to your seats!
1089 RTTI in the presence of newtypes can be a tricky and unsound business.
1090
1091 Example:
1092 ~~~~~~~~~
1093 Suppose we are doing RTTI for a partially evaluated
1094 closure t, the real type of which is t :: MkT Int, for
1095
1096 newtype MkT a = MkT [Maybe a]
1097
1098 The table below shows the results of RTTI and the improvement
1099 calculated for different combinations of evaluatedness and :type t.
1100 Regard the two first columns as input and the next two as output.
1101
1102 # | t | :type t | rtti(t) | improv. | result
1103 ------------------------------------------------------------
1104 1 | _ | t b | a | none | OK
1105 2 | _ | MkT b | a | none | OK
1106 3 | _ | t Int | a | none | OK
1107
1108 If t is not evaluated at *all*, we are safe.
1109
1110 4 | (_ : _) | t b | [a] | t = [] | UNSOUND
1111 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype)
1112 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND
1113
1114 If a is a minimal whnf, we run into trouble. Note that
1115 row 5 above does newtype enrichment on the ty_rtty parameter.
1116
1117 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND
1118 | | | b = Maybe a|
1119
1120 8 | (Just _:_)| MkT b | MkT a | none | OK
1121 9 | (Just _:_)| t Int | FAIL | none | OK
1122
1123 And if t is any more evaluated than whnf, we are still in trouble.
1124 Because constraints are solved in top-down order, when we reach the
1125 Maybe subterm what we got is already unsound. This explains why the
1126 row 9 fails to complete.
1127
1128 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK
1129 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK
1130
1131 We can undo the failure in row 9 by leaving out the constraint
1132 coming from the type signature of t (i.e., the 2nd column).
1133 Note that this type information is still used
1134 to calculate the improvement. But we fail
1135 when trying to calculate the improvement, as there is no unifier for
1136 t Int = [Maybe a] or t Int = [Maybe Int].
1137
1138
1139 Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]]
1140
1141 # | t | :type t | rtti(t) | improvement | result
1142 ---------------------------------------------------------------------
1143 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] |
1144 | | | | b = Maybe a |
1145
1146 The checks:
1147 ~~~~~~~~~~~
1148 Consider a function obtainType that takes a value and a type and produces
1149 the Term representation and a substitution (the improvement).
1150 Assume an auxiliar rtti' function which does the actual job if recovering
1151 the type, but which may produce a false type.
1152
1153 In pseudocode:
1154
1155 rtti' :: a -> IO Type -- Does not use the static type information
1156
1157 obtainType :: a -> Type -> IO (Maybe (Term, Improvement))
1158 obtainType v old_ty = do
1159 rtti_ty <- rtti' v
1160 if monomorphic rtti_ty || (check rtti_ty old_ty)
1161 then ...
1162 else return Nothing
1163 where check rtti_ty old_ty = check1 rtti_ty &&
1164 check2 rtti_ty old_ty
1165
1166 check1 :: Type -> Bool
1167 check2 :: Type -> Type -> Bool
1168
1169 Now, if rtti' returns a monomorphic type, we are safe.
1170 If that is not the case, then we consider two conditions.
1171
1172
1173 1. To prevent the class of unsoundness displayed by
1174 rows 4 and 7 in the example: no higher kind tyvars
1175 accepted.
1176
1177 check1 (t a) = NO
1178 check1 (t Int) = NO
1179 check1 ([] a) = YES
1180
1181 2. To prevent the class of unsoundness shown by row 6,
1182 the rtti type should be structurally more
1183 defined than the old type we are comparing it to.
1184 check2 :: NewType -> OldType -> Bool
1185 check2 a _ = True
1186 check2 [a] a = True
1187 check2 [a] (t Int) = False
1188 check2 [a] (t a) = False -- By check1 we never reach this equation
1189 check2 [Int] a = True
1190 check2 [Int] (t Int) = True
1191 check2 [Maybe a] (t Int) = False
1192 check2 [Maybe Int] (t Int) = True
1193 check2 (Maybe [a]) (m [Int]) = False
1194 check2 (Maybe [Int]) (m [Int]) = True
1195
1196 -}
1197
1198 check1 :: QuantifiedType -> Bool
1199 check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs)
1200 where
1201 isHigherKind = not . null . fst . splitPiTys
1202
1203 check2 :: QuantifiedType -> QuantifiedType -> Bool
1204 check2 (_, rtti_ty) (_, old_ty)
1205 | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
1206 = case () of
1207 _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
1208 -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds)
1209 _ | Just _ <- splitAppTy_maybe old_ty
1210 -> isMonomorphicOnNonPhantomArgs rtti_ty
1211 _ -> True
1212 | otherwise = True
1213
1214 -- Dealing with newtypes
1215 --------------------------
1216 {-
1217 congruenceNewtypes does a parallel fold over two Type values,
1218 compensating for missing newtypes on both sides.
1219 This is necessary because newtypes are not present
1220 in runtime, but sometimes there is evidence available.
1221 Evidence can come from DataCon signatures or
1222 from compile-time type inference.
1223 What we are doing here is an approximation
1224 of unification modulo a set of equations derived
1225 from newtype definitions. These equations should be the
1226 same as the equality coercions generated for newtypes
1227 in System Fc. The idea is to perform a sort of rewriting,
1228 taking those equations as rules, before launching unification.
1229
1230 The caller must ensure the following.
1231 The 1st type (lhs) comes from the heap structure of ptrs,nptrs.
1232 The 2nd type (rhs) comes from a DataCon type signature.
1233 Rewriting (i.e. adding/removing a newtype wrapper) can happen
1234 in both types, but in the rhs it is restricted to the result type.
1235
1236 Note that it is very tricky to make this 'rewriting'
1237 work with the unification implemented by TcM, where
1238 substitutions are operationally inlined. The order in which
1239 constraints are unified is vital as we cannot modify
1240 anything that has been touched by a previous unification step.
1241 Therefore, congruenceNewtypes is sound only if the types
1242 recovered by the RTTI mechanism are unified Top-Down.
1243 -}
1244 congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType)
1245 congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
1246 where
1247 go l r
1248 -- TyVar lhs inductive case
1249 | Just tv <- getTyVar_maybe l
1250 , isTcTyVar tv
1251 , isMetaTyVar tv
1252 = recoverTR (return r) $ do
1253 Indirect ty_v <- readMetaTyVar tv
1254 traceTR $ fsep [text "(congruence) Following indirect tyvar:",
1255 ppr tv, equals, ppr ty_v]
1256 go ty_v r
1257 -- FunTy inductive case
1258 | Just (l1,l2) <- splitFunTy_maybe l
1259 , Just (r1,r2) <- splitFunTy_maybe r
1260 = do r2' <- go l2 r2
1261 r1' <- go l1 r1
1262 return (mkVisFunTy r1' r2')
1263 -- TyconApp Inductive case; this is the interesting bit.
1264 | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
1265 , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
1266 , tycon_l /= tycon_r
1267 = upgrade tycon_l r
1268
1269 | otherwise = return r
1270
1271 where upgrade :: TyCon -> Type -> TR Type
1272 upgrade new_tycon ty
1273 | not (isNewTyCon new_tycon) = do
1274 traceTR (text "(Upgrade) Not matching newtype evidence: " <>
1275 ppr new_tycon <> text " for " <> ppr ty)
1276 return ty
1277 | otherwise = do
1278 traceTR (text "(Upgrade) upgraded " <> ppr ty <>
1279 text " in presence of newtype evidence " <> ppr new_tycon)
1280 (_, vars) <- instTyVars (tyConTyVars new_tycon)
1281 let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
1282 rep_ty = unwrapType ty'
1283 _ <- liftTcM (unifyType Nothing ty rep_ty)
1284 -- assumes that reptype doesn't ^^^^ touch tyconApp args
1285 return ty'
1286
1287
1288 zonkTerm :: Term -> TcM Term
1289 zonkTerm = foldTermM (TermFoldM
1290 { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' ->
1291 return (Term ty' dc v tt)
1292 , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty ->
1293 return (Suspension ct ty v b)
1294 , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
1295 return$ NewtypeWrap ty' dc t
1296 , fRefWrapM = \ty t -> return RefWrap `ap`
1297 zonkRttiType ty `ap` return t
1298 , fPrimM = (return.) . Prim })
1299
1300 zonkRttiType :: TcType -> TcM Type
1301 -- Zonk the type, replacing any unbound Meta tyvars
1302 -- by RuntimeUnk skolems, safely out of Meta-tyvar-land
1303 zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi
1304 ; zonkTcTypeToTypeX ze ty }
1305
1306 --------------------------------------------------------------------------------
1307 -- Restore Class predicates out of a representation type
1308 dictsView :: Type -> Type
1309 dictsView ty = ty
1310
1311
1312 -- Use only for RTTI types
1313 isMonomorphic :: RttiType -> Bool
1314 isMonomorphic ty = noExistentials && noUniversals
1315 where (tvs, _, ty') = tcSplitSigmaTy ty
1316 noExistentials = noFreeVarsOfType ty'
1317 noUniversals = null tvs
1318
1319 -- Use only for RTTI types
1320 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
1321 isMonomorphicOnNonPhantomArgs ty
1322 | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty)
1323 , phantom_vars <- tyConPhantomTyVars tc
1324 , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
1325 , tyv `notElem` phantom_vars]
1326 = all isMonomorphicOnNonPhantomArgs concrete_args
1327 | Just (ty1, ty2) <- splitFunTy_maybe ty
1328 = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
1329 | otherwise = isMonomorphic ty
1330
1331 tyConPhantomTyVars :: TyCon -> [TyVar]
1332 tyConPhantomTyVars tc
1333 | isAlgTyCon tc
1334 , Just dcs <- tyConDataCons_maybe tc
1335 , dc_vars <- concatMap dataConUnivTyVars dcs
1336 = tyConTyVars tc \\ dc_vars
1337 tyConPhantomTyVars _ = []
1338
1339 type QuantifiedType = ([TyVar], Type)
1340 -- Make the free type variables explicit
1341 -- The returned Type should have no top-level foralls (I believe)
1342
1343 quantifyType :: Type -> QuantifiedType
1344 -- Generalize the type: find all free and forall'd tyvars
1345 -- and return them, together with the type inside, which
1346 -- should not be a forall type.
1347 --
1348 -- Thus (quantifyType (forall a. a->[b]))
1349 -- returns ([a,b], a -> [b])
1350
1351 quantifyType ty = ( filter isTyVar $
1352 tyCoVarsOfTypeWellScoped rho
1353 , rho)
1354 where
1355 (_tvs, rho) = tcSplitForAllTys ty