RtClosureInspect.hs 53.5 KB
Newer Older
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
1
{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}
2

3 4 5 6 7 8 9 10
-----------------------------------------------------------------------------
--
-- GHC Interactive support for inspecting arbitrary closures at runtime
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-----------------------------------------------------------------------------
module RtClosureInspect(
11 12
     -- * Entry points and types
     cvObtainTerm,
13
     cvReconstructType,
14
     improveRTTIType,
pepe's avatar
pepe committed
15 16
     Term(..),

17 18 19 20 21
     -- * Utils
     isFullyEvaluatedTerm,
     termType, mapTermType, termTyCoVars,
     foldTerm, TermFold(..),
     cPprTerm, cPprTermBase,
pepe's avatar
pepe committed
22

23
     constrClosToName -- exported to use in test T4891
pepe's avatar
pepe committed
24
 ) where
25 26 27

#include "HsVersions.h"

28 29
import GhcPrelude

30
import GHCi
patrickdoc's avatar
patrickdoc committed
31
import GHCi.RemoteTypes
pepe's avatar
pepe committed
32
import HscTypes
33

34 35
import DataCon
import Type
36
import RepType
37
import qualified Unify as U
38
import Var
twanvl's avatar
twanvl committed
39
import TcRnMonad
40 41
import TcType
import TcMType
42
import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
43
import TcUnify
44
import TcEnv
pepe's avatar
pepe committed
45

46 47
import TyCon
import Name
patrickdoc's avatar
patrickdoc committed
48 49 50
import OccName
import Module
import IfaceEnv
51
import Util
52
import VarSet
53
import BasicTypes       ( Boxity(..) )
54
import TysPrim
55 56
import PrelNames
import TysWiredIn
pepe's avatar
pepe committed
57
import DynFlags
58
import Outputable as Ppr
59
import GHC.Char
patrickdoc's avatar
patrickdoc committed
60
import GHC.Exts.Heap
61
import SMRep ( roundUpTo )
62 63 64

import Control.Monad
import Data.Maybe
pepe's avatar
pepe committed
65
import Data.List
66
#if defined(INTEGER_GMP)
David Eichmann's avatar
David Eichmann committed
67 68
import GHC.Exts
import Data.Array.Base
69
import GHC.Integer.GMP.Internals
70 71 72
#elif defined(INTEGER_SIMPLE)
import GHC.Exts
import GHC.Integer.Simple.Internals
73
#endif
74
import qualified Data.Sequence as Seq
75
import Data.Sequence (viewl, ViewL(..))
76
import Foreign
Ross Paterson's avatar
Ross Paterson committed
77
import System.IO.Unsafe
78

79

80 81 82 83
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------

pepe's avatar
pepe committed
84
data Term = Term { ty        :: RttiType
85
                 , dc        :: Either String DataCon
mnislaih's avatar
mnislaih committed
86
                               -- Carries a text representation if the datacon is
87
                               -- not exported by the .hi file, which is the case
mnislaih's avatar
mnislaih committed
88
                               -- for private constructors in -O0 compiled libraries
89
                 , val       :: ForeignHValue
90 91
                 , subTerms  :: [Term] }

pepe's avatar
pepe committed
92
          | Prim { ty        :: RttiType
patrickdoc's avatar
patrickdoc committed
93
                 , valRaw    :: [Word] }
94 95

          | Suspension { ctype    :: ClosureType
pepe's avatar
pepe committed
96
                       , ty       :: RttiType
97
                       , val      :: ForeignHValue
98 99
                       , bound_to :: Maybe Name   -- Useful for printing
                       }
pepe's avatar
pepe committed
100 101 102 103 104
          | NewtypeWrap{       -- At runtime there are no newtypes, and hence no
                               -- newtype constructors. A NewtypeWrap is just a
                               -- made-up tag saying "heads up, there used to be
                               -- a newtype constructor here".
                         ty           :: RttiType
105 106
                       , dc           :: Either String DataCon
                       , wrapped_term :: Term }
pepe's avatar
pepe committed
107 108
          | RefWrap    {       -- The contents of a reference
                         ty           :: RttiType
109
                       , wrapped_term :: Term }
110

pepe's avatar
pepe committed
111
termType :: Term -> RttiType
mnislaih's avatar
mnislaih committed
112
termType t = ty t
113

mnislaih's avatar
mnislaih committed
114 115 116
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Prim {}            = True
117
isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
118
isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
119
isFullyEvaluatedTerm _                  = False
mnislaih's avatar
mnislaih committed
120

121
instance Outputable (Term) where
mnislaih's avatar
mnislaih committed
122 123
 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
       | otherwise = panic "Outputable Term instance"
124

patrickdoc's avatar
patrickdoc committed
125 126 127
----------------------------------------
-- Runtime Closure information functions
----------------------------------------
128

129
isThunk :: GenClosure a -> Bool
patrickdoc's avatar
patrickdoc committed
130 131 132
isThunk ThunkClosure{} = True
isThunk APClosure{} = True
isThunk APStackClosure{} = True
133 134
isThunk _             = False

patrickdoc's avatar
patrickdoc committed
135
-- Lookup the name in a constructor closure
136
constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
patrickdoc's avatar
patrickdoc committed
137 138 139 140 141
constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
   let occName = mkOccName OccName.dataName occ
       modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
   Right `fmap` lookupOrigIO hsc_env modName occName
constrClosToName _hsc_env clos =
142
   return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
patrickdoc's avatar
patrickdoc committed
143

144
-----------------------------------
mnislaih's avatar
mnislaih committed
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
pepe's avatar
pepe committed
150
                           , fPrim        :: RttiType -> [Word] -> a
151
                           , fSuspension  :: ClosureType -> RttiType -> ForeignHValue
mnislaih's avatar
mnislaih committed
152
                                            -> Maybe Name -> a
pepe's avatar
pepe committed
153
                           , fNewtypeWrap :: RttiType -> Either String DataCon
154
                                            -> a -> a
pepe's avatar
pepe committed
155 156 157 158 159 160 161
                           , fRefWrap     :: RttiType -> a -> a
                           }


data TermFoldM m a =
                   TermFoldM {fTermM        :: TermProcessor a (m a)
                            , fPrimM        :: RttiType -> [Word] -> m a
162
                            , fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue
pepe's avatar
pepe committed
163 164 165 166
                                             -> Maybe Name -> m a
                            , fNewtypeWrapM :: RttiType -> Either String DataCon
                                            -> a -> m a
                            , fRefWrapM     :: RttiType -> a -> m a
167 168 169 170 171 172
                           }

foldTerm :: TermFold a -> Term -> a
foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
foldTerm tf (Prim ty    v   ) = fPrim tf ty v
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

pepe's avatar
pepe committed
176 177 178 179 180 181 182 183

foldTermM :: Monad m => TermFoldM m a -> Term -> m a
foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
foldTermM tf (Prim ty    v   ) = fPrimM tf ty v
foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc
foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty

184 185 186 187
idTermFold :: TermFold Term
idTermFold = TermFold {
              fTerm = Term,
              fPrim = Prim,
188
              fSuspension  = Suspension,
189 190
              fNewtypeWrap = NewtypeWrap,
              fRefWrap = RefWrap
191 192
                      }

pepe's avatar
pepe committed
193
mapTermType :: (RttiType -> Type) -> Term -> Term
194 195
mapTermType f = foldTerm idTermFold {
          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
mnislaih's avatar
mnislaih committed
196 197
          fSuspension = \ct ty hval n ->
                          Suspension ct (f ty) hval n,
198 199
          fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
          fRefWrap    = \ty t -> RefWrap (f ty) t}
200

pepe's avatar
pepe committed
201 202 203 204 205 206 207 208 209
mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term
mapTermTypeM f = foldTermM TermFoldM {
          fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,
          fPrimM       = (return.) . Prim,
          fSuspensionM = \ct ty hval n ->
                          f ty >>= \ty' -> return $ Suspension ct ty' hval n,
          fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
          fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}

210 211
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = foldTerm TermFold {
212
            fTerm       = \ty _ _ tt   ->
David Feuer's avatar
David Feuer committed
213
                          tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
214
            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
David Feuer's avatar
David Feuer committed
215 216 217 218
            fPrim       = \ _ _ -> emptyVarSet,
            fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
            fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
    where concatVarEnv = foldr unionVarSet emptyVarSet
219

220 221 222 223
----------------------------------
-- Pretty printing of terms
----------------------------------

mnislaih's avatar
mnislaih committed
224 225 226
type Precedence        = Int
type TermPrinterM m    = Precedence -> Term -> m SDoc

mnislaih's avatar
mnislaih committed
227 228 229
app_prec,cons_prec, max_prec ::Int
max_prec  = 10
app_prec  = max_prec
230
cons_prec = 5 -- TODO Extract this info from GHC itself
231

mnislaih's avatar
mnislaih committed
232 233 234 235
pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
pprTermM y p t = pprDeeper `liftM` ppr_termM y p t

ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
236
  tt_docs <- mapM (y app_prec) tt
dterei's avatar
dterei committed
237 238
  return $ cparen (not (null tt) && p >= app_prec)
                  (text dc_tag <+> pprDeeperList fsep tt_docs)
239

Simon Peyton Jones's avatar
Simon Peyton Jones committed
240
ppr_termM y p Term{dc=Right dc, subTerms=tt}
241
{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
242 243
  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
    <+> hsep (map (ppr_term1 True) tt)
244
-} -- TODO Printing infix constructors properly
Simon Peyton Jones's avatar
Simon Peyton Jones committed
245 246 247 248 249 250 251 252 253 254 255
  = do { tt_docs' <- mapM (y app_prec) tt
       ; return $ ifPprDebug (show_tm tt_docs')
                             (show_tm (dropList (dataConTheta dc) tt_docs'))
                  -- Don't show the dictionary arguments to
                  -- constructors unless -dppr-debug is on
       }
  where
    show_tm tt_docs
      | null tt_docs = ppr dc
      | otherwise    = cparen (p >= app_prec) $
                       sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
256

mnislaih's avatar
mnislaih committed
257
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
mnislaih's avatar
mnislaih committed
258
ppr_termM y p RefWrap{wrapped_term=t}  = do
259 260 261 262 263 264 265
  contents <- y app_prec t
  return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
  -- The constructor name is wired in here ^^^ for the sake of simplicity.
  -- I don't think mutvars are going to change in a near future.
  -- In any case this is solely a presentation matter: MutVar# is
  -- a datatype with no constructors, implemented by the RTS
  -- (hence there is no way to obtain a datacon and print it).
mnislaih's avatar
mnislaih committed
266
ppr_termM _ _ t = ppr_termM1 t
mnislaih's avatar
mnislaih committed
267

mnislaih's avatar
mnislaih committed
268

269
ppr_termM1 :: Monad m => Term -> m SDoc
patrickdoc's avatar
patrickdoc committed
270
ppr_termM1 Prim{valRaw=words, ty=ty} =
Ian Lynagh's avatar
Ian Lynagh committed
271
    return $ repPrim (tyConAppTyCon ty) words
272
ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
Simon Peyton Jones's avatar
Simon Peyton Jones committed
273
    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
mnislaih's avatar
mnislaih committed
274
ppr_termM1 Suspension{ty=ty, bound_to=Just n}
pepe's avatar
pepe committed
275
--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
276 277 278 279
  | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
mnislaih's avatar
mnislaih committed
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 286
             real_term <- y max_prec t
             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
287 288
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"

289 290 291 292
-------------------------------------------------------
-- Custom Term Pretty Printers
-------------------------------------------------------

293 294
-- We can want to customize the representation of a
--  term depending on its type.
295 296
-- However, note that custom printers have to work with
--  type representations, instead of directly with types.
297
-- We cannot use type classes here, unless we employ some
298 299 300 301
--  typerep trickery (e.g. Weirich's RepLib tricks),
--  which I didn't. Therefore, this code replicates a lot
--  of what type classes provide for free.

mnislaih's avatar
mnislaih committed
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,
Krzysztof Gogolewski's avatar
Typos  
Krzysztof Gogolewski committed
306
-- and returns the output of the first successful printer, or the default printer
307
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
mnislaih's avatar
mnislaih committed
308 309
cPprTerm printers_ = go 0 where
  printers = printers_ go
310
  go prec t = do
mnislaih's avatar
mnislaih committed
311
    let default_ = Just `liftM` pprTermM go prec t
312
        mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
313 314 315 316
    mdoc <- firstJustM mb_customDocs
    case mdoc of
      Nothing -> panic "cPprTerm"
      Just doc -> return $ cparen (prec>app_prec+1) doc
317

318 319
  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
  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 326 327
                                      . mapM (y (-1))
                                      . subTerms)
  , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
328
           ppr_list
329 330 331 332 333
  , ifTerm' (isTyCon intTyCon    . ty) ppr_int
  , ifTerm' (isTyCon charTyCon   . ty) ppr_char
  , ifTerm' (isTyCon floatTyCon  . ty) ppr_float
  , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
  , ifTerm' (isIntegerTy         . ty) ppr_integer
mnislaih's avatar
mnislaih committed
334
  ]
335
 where
336 337 338
   ifTerm :: (Term -> Bool)
          -> (Precedence -> Term -> m SDoc)
          -> Precedence -> Term -> m (Maybe SDoc)
339 340 341 342 343 344 345 346
   ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)

   ifTerm' :: (Term -> Bool)
          -> (Precedence -> Term -> m (Maybe SDoc))
          -> Precedence -> Term -> m (Maybe SDoc)
   ifTerm' pred f prec t@Term{}
       | pred t    = f prec t
   ifTerm' _ _ _ _  = return Nothing
347

348 349
   isTupleTy ty    = fromMaybe False $ do
     (tc,_) <- tcSplitTyConApp_maybe ty
350 351
     return (isBoxedTupleTyCon tc)

352
   isTyCon a_tc ty = fromMaybe False $ do
353 354 355 356 357 358 359
     (tc,_) <- tcSplitTyConApp_maybe ty
     return (a_tc == tc)

   isIntegerTy ty = fromMaybe False $ do
     (tc,_) <- tcSplitTyConApp_maybe ty
     return (tyConName tc == integerTyConName)

360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415
   ppr_int, ppr_char, ppr_float, ppr_double
      :: Precedence -> Term -> m (Maybe SDoc)
   ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
      return (Just (Ppr.int (fromIntegral w)))
   ppr_int _ _ = return Nothing

   ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} =
      return (Just (Ppr.pprHsChar (chr (fromIntegral w))))
   ppr_char _ _ = return Nothing

   ppr_float   _ Term{subTerms=[Prim{valRaw=[w]}]} = do
      let f = unsafeDupablePerformIO $
                alloca $ \p -> poke p w >> peek (castPtr p)
      return (Just (Ppr.float f))
   ppr_float _ _ = return Nothing

   ppr_double  _ Term{subTerms=[Prim{valRaw=[w]}]} = do
      let f = unsafeDupablePerformIO $
                alloca $ \p -> poke p w >> peek (castPtr p)
      return (Just (Ppr.double f))
   -- let's assume that if we get two words, we're on a 32-bit
   -- machine. There's no good way to get a DynFlags to check the word
   -- size here.
   ppr_double  _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do
      let f = unsafeDupablePerformIO $
                alloca $ \p -> do
                  poke p (fromIntegral w1 :: Word32)
                  poke (p `plusPtr` 4) (fromIntegral w2 :: Word32)
                  peek (castPtr p)
      return (Just (Ppr.double f))
   ppr_double _ _ = return Nothing

   ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
#if defined(INTEGER_GMP)
   -- Reconstructing Integers is a bit of a pain. This depends deeply
   -- on the integer-gmp representation, so it'll break if that
   -- changes (but there are several tests in
   -- tests/ghci.debugger/scripts that will tell us if this is wrong).
   --
   --   data Integer
   --     = S# Int#
   --     | Jp# {-# UNPACK #-} !BigNat
   --     | Jn# {-# UNPACK #-} !BigNat
   --
   --   data BigNat = BN# ByteArray#
   --
   ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
      return (Just (Ppr.integer (S# (word2Int# w))))
   ppr_integer _ Term{dc=Right con,
                      subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
      -- We don't need to worry about sizes that are not an integral
      -- number of words, because luckily GMP uses arrays of words
      -- (see GMP_LIMB_SHIFT).
      let
        !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
        constr
416
          | "Jp#" <- getOccString (dataConName con) = Jp#
417 418
          | otherwise = Jn#
      return (Just (Ppr.integer (constr (BN# arr#))))
419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
#elif defined(INTEGER_SIMPLE)
   -- As with the GMP case, this depends deeply on the integer-simple
   -- representation.
   --
   -- @
   -- data Integer = Positive !Digits | Negative !Digits | Naught
   --
   -- data Digits = Some !Word# !Digits
   --             | None
   -- @
   --
   -- NB: the above has some type synonyms expanded out for the sake of brevity
   ppr_integer _ Term{subTerms=[]} =
      return (Just (Ppr.integer Naught))
   ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]}
        | Just digits <- get_digits digitTerm
        = return (Just (Ppr.integer (constr digits)))
      where
        get_digits :: Term -> Maybe Digits
        get_digits Term{subTerms=[]} = Just None
        get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]}
          = Some w <$> get_digits t
        get_digits _ = Nothing

        constr
          | "Positive" <- getOccString (dataConName con) = Positive
          | otherwise = Negative
446 447
#endif
   ppr_integer _ _ = return Nothing
448 449 450 451 452

   --Note pprinting of list terms is not lazy
   ppr_list :: Precedence -> Term -> m SDoc
   ppr_list p (Term{subTerms=[h,t]}) = do
       let elems      = h : getListTerms t
453
           isConsLast = not (termType (last elems) `eqType` termType h)
454
           is_string  = all (isCharTy . ty) elems
455 456
           chars = [ chr (fromIntegral w)
                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
457 458 459

       print_elems <- mapM (y cons_prec) elems
       if is_string
460
        then return (Ppr.doubleQuotes (Ppr.text chars))
461
        else if isConsLast
462 463
        then return $ cparen (p >= cons_prec)
                    $ pprDeeperList fsep
464
                    $ punctuate (space<>colon) print_elems
465
        else return $ brackets
466 467 468 469 470 471 472 473
                    $ pprDeeperList fcat
                    $ punctuate comma print_elems

        where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
              getListTerms Term{subTerms=[]}    = []
              getListTerms t@Suspension{}       = [t]
              getListTerms t = pprPanic "getListTerms" (ppr t)
   ppr_list _ _ = panic "doList"
474

475

Ian Lynagh's avatar
Ian Lynagh committed
476 477
repPrim :: TyCon -> [Word] -> SDoc
repPrim t = rep where
478
   rep x
479 480 481
    -- Char# uses native machine words, whereas Char's Storable instance uses
    -- Int32, so we have to read it as an Int.
    | t == charPrimTyCon             = text $ show (chr (build x :: Int))
Ian Lynagh's avatar
Ian Lynagh committed
482 483 484 485 486 487 488 489 490 491 492 493
    | t == intPrimTyCon              = text $ show (build x :: Int)
    | t == wordPrimTyCon             = text $ show (build x :: Word)
    | t == floatPrimTyCon            = text $ show (build x :: Float)
    | t == doublePrimTyCon           = text $ show (build x :: Double)
    | t == int32PrimTyCon            = text $ show (build x :: Int32)
    | t == word32PrimTyCon           = text $ show (build x :: Word32)
    | t == int64PrimTyCon            = text $ show (build x :: Int64)
    | t == word64PrimTyCon           = text $ show (build x :: Word64)
    | t == addrPrimTyCon             = text $ show (nullPtr `plusPtr` build x)
    | t == stablePtrPrimTyCon        = text "<stablePtr>"
    | t == stableNamePrimTyCon       = text "<stableName>"
    | t == statePrimTyCon            = text "<statethread>"
494
    | t == proxyPrimTyCon            = text "<proxy>"
Ian Lynagh's avatar
Ian Lynagh committed
495 496 497 498
    | t == realWorldTyCon            = text "<realworld>"
    | t == threadIdPrimTyCon         = text "<ThreadId>"
    | t == weakPrimTyCon             = text "<Weak>"
    | t == arrayPrimTyCon            = text "<array>"
499
    | t == smallArrayPrimTyCon       = text "<smallArray>"
Ian Lynagh's avatar
Ian Lynagh committed
500 501
    | t == byteArrayPrimTyCon        = text "<bytearray>"
    | t == mutableArrayPrimTyCon     = text "<mutableArray>"
502
    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
Ian Lynagh's avatar
Ian Lynagh committed
503 504 505 506 507
    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
    | t == mutVarPrimTyCon           = text "<mutVar>"
    | t == mVarPrimTyCon             = text "<mVar>"
    | t == tVarPrimTyCon             = text "<tVar>"
    | otherwise                      = char '<' <> ppr t <> char '>'
508 509 510
    where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
--   This ^^^ relies on the representation of Haskell heap values being
--   the same as in a C array.
mnislaih's avatar
mnislaih committed
511

512 513 514
-----------------------------------
-- Type Reconstruction
-----------------------------------
mnislaih's avatar
mnislaih committed
515 516 517 518 519 520
{-
Type Reconstruction is type inference done on heap closures.
The algorithm walks the heap generating a set of equations, which
are solved with syntactic unification.
A type reconstruction equation looks like:

521
  <datacon reptype>  =  <actual heap contents>
mnislaih's avatar
mnislaih committed
522 523 524 525 526

The full equation set is generated by traversing all the subterms, starting
from a given term.

The only difficult part is that newtypes are only found in the lhs of equations.
527 528
Right hand sides are missing them. We can either (a) drop them from the lhs, or
(b) reconstruct them in the rhs when possible.
mnislaih's avatar
mnislaih committed
529 530 531

The function congruenceNewtypes takes a shot at (b)
-}
532 533


pepe's avatar
pepe committed
534 535 536 537 538 539 540 541 542
-- A (non-mutable) tau type containing
-- existentially quantified tyvars.
--    (since GHC type language currently does not support
--     existentials, we leave these variables unquantified)
type RttiType = Type

-- An incomplete type as stored in GHCi:
--  no polymorphism: no quantifiers & all tyvars are skolem.
type GhciType = Type
543 544 545 546 547


-- The Type Reconstruction monad
--------------------------------
type TR a = TcM a
pepe's avatar
pepe committed
548 549 550 551 552

runTR :: HscEnv -> TR a -> IO a
runTR hsc_env thing = do
  mb_val <- runTR_maybe hsc_env thing
  case mb_val of
553
    Nothing -> error "unable to :print the term"
554 555 556
    Just x  -> return x

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 ()
pepe's avatar
pepe committed
563 564 565
traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti


566
-- Semantically different to recoverM in TcRnMonad
pepe's avatar
pepe committed
567 568 569
-- recoverM retains the errors in the first action,
--  whereas recoverTc here does not
recoverTR :: TR a -> TR a -> TR a
570
recoverTR = tryTcDiscardingErrs
571

572
trIO :: IO a -> TR a
twanvl's avatar
twanvl committed
573
trIO = liftTcM . liftIO
574

575
liftTcM :: TcM a -> TR a
mnislaih's avatar
mnislaih committed
576
liftTcM = id
577

578
newVar :: Kind -> TR TcType
579
newVar = liftTcM . newFlexiTyVarTy
580

581 582 583 584
newOpenVar :: TR TcType
newOpenVar = liftTcM newOpenFlexiTyVarTy

instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
585 586
-- Instantiate fresh mutable type variables from some TyVars
-- 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 592
   -- Associates the typechecker-world meta type variables
   -- (which are mutable and may be refined), to their
Simon Peyton Jones's avatar
Simon Peyton Jones committed
593
   -- debugger-world RuntimeUnk counterparts.
594 595
   -- If the TcTyVar has not been refined by the runtime type
   -- elaboration, then we want to turn it back into the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
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 603 604
  = do { (subst, tvs') <- instTyVars tvs
       ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
       ; return (substTy subst ty, rtti_inst) }
605 606 607 608 609 610 611

applyRevSubst :: RttiInstantiation -> TR ()
-- Apply the *reverse* substitution in-place to any un-filled-in
-- meta tyvars.  This recovers the original debugger-world variable
-- unless it has been refined by new information from the heap
applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
  where
612
    do_pair (tc_tv, rtti_tv)
613 614 615 616
      = do { tc_ty <- zonkTcTyVar tc_tv
           ; case tcGetTyVar_maybe tc_ty of
               Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
               _                        -> return () }
617

618 619 620 621 622
-- Adds a constraint of the form t1 == t2
-- t1 is expected to come from walking the heap
-- t2 is expected to come from a datacon signature
-- Before unification, congruenceNewtypes needs to
-- do its magic.
mnislaih's avatar
mnislaih committed
623
addConstraint :: TcType -> TcType -> TR ()
pepe's avatar
pepe committed
624
addConstraint actual expected = do
mnislaih's avatar
mnislaih committed
625
    traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
pepe's avatar
pepe committed
626
    recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
627
                                    text "with", ppr expected]) $
628 629
      discardResult $
      captureConstraints $
630
      do { (ty1, ty2) <- congruenceNewtypes actual expected
631
         ; unifyType Nothing ty1 ty2 }
pepe's avatar
pepe committed
632 633
     -- TOMDO: what about the coercion?
     -- we should consider family instances
mnislaih's avatar
mnislaih committed
634

635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652

-- | Term reconstruction
--
-- Given a pointer to a heap object (`HValue`) and its type, build a `Term`
-- representation of the object. Subterms (objects in the payload) are also
-- built up to the given `max_depth`. After `max_depth` any subterms will appear
-- as `Suspension`s. Any thunks found while traversing the object will be forced
-- based on `force` parameter.
--
-- Types of terms will be refined based on constructors we find during term
-- reconstruction. See `cvReconstructType` for an overview of how type
-- reconstruction works.
--
cvObtainTerm
    :: HscEnv
    -> Int      -- ^ How many times to recurse for subterms
    -> Bool     -- ^ Force thunks
    -> RttiType -- ^ Type of the object to reconstruct
653
    -> ForeignHValue   -- ^ Object to reconstruct
654
    -> IO Term
pepe's avatar
pepe committed
655 656 657 658
cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
  -- we quantify existential tyvars as universal,
  -- as this is needed to be able to manipulate
  -- them properly
659
   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
660
       sigma_old_ty = mkInvForAllTys old_tvs old_tau
pepe's avatar
pepe committed
661 662
   traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
   term <-
663
     if null old_tvs
pepe's avatar
pepe committed
664
      then do
665 666 667
        term  <- go max_depth sigma_old_ty sigma_old_ty hval
        term' <- zonkTerm term
        return $ fixFunDictionaries $ expandNewtypes term'
pepe's avatar
pepe committed
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") >>
pepe's avatar
pepe committed
672 673
                                          addConstraint my_ty old_ty')
              term  <- go max_depth my_ty sigma_old_ty hval
674 675
              new_ty <- zonkTcType (termType term)
              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
pepe's avatar
pepe committed
676 677
                 then do
                      traceTR (text "check2 passed")
678 679
                      addConstraint new_ty old_ty'
                      applyRevSubst rev_subst
pepe's avatar
pepe committed
680
                      zterm' <- zonkTerm term
681
                      return ((fixFunDictionaries . expandNewtypes) zterm')
pepe's avatar
pepe committed
682 683
                 else do
                      traceTR (text "check2 failed" <+> parens
684
                                       (ppr term <+> text "::" <+> ppr new_ty))
pepe's avatar
pepe committed
685 686 687 688 689
                      -- we have unsound types. Replace constructor types in
                      -- subterms with tyvars
                      zterm' <- mapTermTypeM
                                 (\ty -> case tcSplitTyConApp_maybe ty of
                                           Just (tc, _:_) | tc /= funTyCon
690
                                               -> newOpenVar
pepe's avatar
pepe committed
691
                                           _   -> return ty)
692
                                 term
pepe's avatar
pepe committed
693
                      zonkTerm zterm'
mnislaih's avatar
mnislaih committed
694 695 696
   traceTR (text "Term reconstruction completed." $$
            text "Term obtained: " <> ppr term $$
            text "Type obtained: " <> ppr (termType term))
pepe's avatar
pepe committed
697
   return term
698
    where
699
  go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
Gabor Greif's avatar
Gabor Greif committed
700
   -- I believe that my_ty should not have any enclosing
701 702 703
   -- foralls, nor any free RuntimeUnk skolems;
   -- that is partly what the quantifyType stuff achieved
   --
704 705
   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty

pepe's avatar
pepe committed
706
  go 0 my_ty _old_ty a = do
mnislaih's avatar
mnislaih committed
707 708
    traceTR (text "Gave up reconstructing a term after" <>
                  int max_depth <> text " steps")
709
    clos <- trIO $ GHCi.getClosure hsc_env a
patrickdoc's avatar
patrickdoc committed
710
    return (Suspension (tipe (info clos)) my_ty a Nothing)
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
711
  go !max_depth my_ty old_ty a = do
712
    let monomorphic = not(isTyVarTy my_ty)
713 714
    -- This ^^^ is a convention. The ancestor tests for
    -- monomorphism and passes a type instead of a tv
715
    clos <- trIO $ GHCi.getClosure hsc_env a
patrickdoc's avatar
patrickdoc committed
716
    case clos of
717
-- Thunks we may want to force
718 719 720 721
      t | isThunk t && force -> do
         traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
         liftIO $ GHCi.seqHValue hsc_env a
         go (pred max_depth) my_ty old_ty a
722 723 724 725
-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If
-- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as
-- the suspension so that entering it in GHCi will enter the BLACKHOLE instead
-- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic).
patrickdoc's avatar
patrickdoc committed
726 727
      BlackholeClosure{indirectee=ind} -> do
         traceTR (text "Following a BLACKHOLE")
728 729 730 731 732 733 734 735 736 737 738 739
         ind_clos <- trIO (GHCi.getClosure hsc_env ind)
         let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)
         case ind_clos of
           -- TSO and BLOCKING_QUEUE cases
           BlockingQueueClosure{} -> return_bh_value
           OtherClosure info _ _
             | tipe info == TSO -> return_bh_value
           UnsupportedClosure info
             | tipe info == TSO -> return_bh_value
           -- Otherwise follow the indirectee
           -- (NOTE: This code will break if we support TSO in ghc-heap one day)
           _ -> go max_depth my_ty old_ty ind
pepe's avatar
pepe committed
740
-- We always follow indirections
patrickdoc's avatar
patrickdoc committed
741 742
      IndClosure{indirectee=ind} -> do
         traceTR (text "Following an indirection" )
743
         go max_depth my_ty old_ty ind
744
-- We also follow references
745
      MutVarClosure{var=contents}
patrickdoc's avatar
patrickdoc committed
746
         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
747
             -> do
pepe's avatar
pepe committed
748
                  -- Deal with the MutVar# primitive
749
                  -- It does not have a constructor at all,
pepe's avatar
pepe committed
750 751 752 753
                  -- so we simulate the following one
                  -- MutVar# :: contents_ty -> MutVar# s contents_ty
         traceTR (text "Following a MutVar")
         contents_tv <- newVar liftedTypeKind
Ningning Xie's avatar
Ningning Xie committed
754
         MASSERT(isUnliftedType my_ty)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
755
         (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy
pepe's avatar
pepe committed
756
                            contents_ty (mkTyConApp tycon [world,contents_ty])
Simon Peyton Jones's avatar
Simon Peyton Jones committed
757
         addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty
pepe's avatar
pepe committed
758 759
         x <- go (pred max_depth) contents_tv contents_ty contents
         return (RefWrap my_ty x)
760

761
 -- The interesting case
762 763
      ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
        traceTR (text "entering a constructor " <> ppr dArgs <+>
mnislaih's avatar
mnislaih committed
764 765
                      if monomorphic
                        then parens (text "already monomorphic: " <> ppr my_ty)
766
                        else Ppr.empty)
patrickdoc's avatar
patrickdoc committed
767 768
        Right dcname <- liftIO $ constrClosToName hsc_env clos
        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
769 770 771 772 773 774
        case mb_dc of
          Nothing -> do -- This can happen for private constructors compiled -O0
                        -- where the .hi descriptor does not export them
                        -- In such case, we return a best approximation:
                        --  ignore the unpointed args, and recover the pointeds
                        -- This preserves laziness, and should be safe.
775
                       traceTR (text "Not constructor" <+> ppr dcname)
Ian Lynagh's avatar
Ian Lynagh committed
776 777
                       let dflags = hsc_dflags hsc_env
                           tag = showPpr dflags dcname
patrickdoc's avatar
patrickdoc committed
778
                       vars     <- replicateM (length pArgs)
779
                                              (newVar liftedTypeKind)
780 781
                       subTerms <- sequence $ zipWith (\x tv ->
                           go (pred max_depth) tv tv x) pArgs vars
pepe's avatar
pepe committed
782 783
                       return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
          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
pepe's avatar
pepe committed
787
            return (Term my_ty (Right dc) a subTerms)
788

789 790 791 792 793 794 795
      -- This is to support printing of Integers. It's not a general
      -- mechanism by any means; in particular we lose the size in
      -- bytes of the array.
      ArrWordsClosure{bytes=b, arrWords=ws} -> do
         traceTR (text "ByteArray# closure, size " <> ppr b)
         return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws])

796
-- The otherwise case: can be a Thunk,AP,PAP,etc.
patrickdoc's avatar
patrickdoc committed
797
      _ -> do
798 799
         traceTR (text "Unknown closure:" <+>
                  text (show (fmap (const ()) clos)))
patrickdoc's avatar
patrickdoc committed
800
         return (Suspension (tipe (info clos)) my_ty a Nothing)
801

pepe's avatar
pepe committed
802 803 804 805 806 807 808 809 810 811 812
  -- insert NewtypeWraps around newtypes
  expandNewtypes = foldTerm idTermFold { fTerm = worker } where
   worker ty dc hval tt
     | Just (tc, args) <- tcSplitTyConApp_maybe ty
     , isNewTyCon tc
     , wrapped_type    <- newTyConInstRhs tc args
     , Just dc'        <- tyConSingleDataCon_maybe tc
     , t'              <- worker wrapped_type dc hval tt
     = NewtypeWrap ty (Right dc') t'
     | otherwise = Term ty dc hval tt

813

pepe's avatar
pepe committed
814 815 816 817
   -- Avoid returning types where predicates have been expanded to dictionaries.
  fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
      worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
                          | otherwise  = Suspension ct ty hval n
mnislaih's avatar
mnislaih committed
818