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