RtClosureInspect.hs 51.8 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 ( zonkTcTypeToType, mkEmptyZonkEnv )
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
60
import GHC.Exts
patrickdoc's avatar
patrickdoc committed
61
import GHC.Exts.Heap
62
import GHC.IO ( IO(..) )
63
import SMRep ( roundUpTo )
64 65

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

77

78 79 80 81
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------

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

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

          | Suspension { ctype    :: ClosureType
pepe's avatar
pepe committed
94
                       , ty       :: RttiType
95
                       , val      :: ForeignHValue
96 97
                       , bound_to :: Maybe Name   -- Useful for printing
                       }
pepe's avatar
pepe committed
98 99 100 101 102
          | 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
103 104
                       , dc           :: Either String DataCon
                       , wrapped_term :: Term }
pepe's avatar
pepe committed
105 106
          | RefWrap    {       -- The contents of a reference
                         ty           :: RttiType
107
                       , wrapped_term :: Term }
108

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

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

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

patrickdoc's avatar
patrickdoc committed
123 124 125
----------------------------------------
-- Runtime Closure information functions
----------------------------------------
126

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

patrickdoc's avatar
patrickdoc committed
133
-- Lookup the name in a constructor closure
134
constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
patrickdoc's avatar
patrickdoc committed
135 136 137 138 139
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 =
140
   return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
patrickdoc's avatar
patrickdoc committed
141

142
-----------------------------------
mnislaih's avatar
mnislaih committed
143
-- * Traversals for Terms
144
-----------------------------------
145
type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
146

147
data TermFold a = TermFold { fTerm        :: TermProcessor a a
pepe's avatar
pepe committed
148
                           , fPrim        :: RttiType -> [Word] -> a
149
                           , fSuspension  :: ClosureType -> RttiType -> ForeignHValue
mnislaih's avatar
mnislaih committed
150
                                            -> Maybe Name -> a
pepe's avatar
pepe committed
151
                           , fNewtypeWrap :: RttiType -> Either String DataCon
152
                                            -> a -> a
pepe's avatar
pepe committed
153 154 155 156 157 158 159
                           , fRefWrap     :: RttiType -> a -> a
                           }


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

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
171
foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
172
foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
173

pepe's avatar
pepe committed
174 175 176 177 178 179 180 181

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

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

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

pepe's avatar
pepe committed
199 200 201 202 203 204 205 206 207
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}

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

218 219 220 221
----------------------------------
-- Pretty printing of terms
----------------------------------

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

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

mnislaih's avatar
mnislaih committed
230 231 232 233
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
234
  tt_docs <- mapM (y app_prec) tt
dterei's avatar
dterei committed
235 236
  return $ cparen (not (null tt) && p >= app_prec)
                  (text dc_tag <+> pprDeeperList fsep tt_docs)
237

Simon Peyton Jones's avatar
Simon Peyton Jones committed
238
ppr_termM y p Term{dc=Right dc, subTerms=tt}
239
{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
240 241
  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
    <+> hsep (map (ppr_term1 True) tt)
242
-} -- TODO Printing infix constructors properly
Simon Peyton Jones's avatar
Simon Peyton Jones committed
243 244 245 246 247 248 249 250 251 252 253
  = 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)]
254

mnislaih's avatar
mnislaih committed
255
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
mnislaih's avatar
mnislaih committed
256
ppr_termM y p RefWrap{wrapped_term=t}  = do
257 258 259 260 261 262 263
  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
264
ppr_termM _ _ t = ppr_termM1 t
mnislaih's avatar
mnislaih committed
265

mnislaih's avatar
mnislaih committed
266

267
ppr_termM1 :: Monad m => Term -> m SDoc
patrickdoc's avatar
patrickdoc committed
268
ppr_termM1 Prim{valRaw=words, ty=ty} =
Ian Lynagh's avatar
Ian Lynagh committed
269
    return $ repPrim (tyConAppTyCon ty) words
270
ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
Simon Peyton Jones's avatar
Simon Peyton Jones committed
271
    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
mnislaih's avatar
mnislaih committed
272
ppr_termM1 Suspension{ty=ty, bound_to=Just n}
pepe's avatar
pepe committed
273
--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
274 275 276 277
  | 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
278

279
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
280
  | Just (tc,_) <- tcSplitTyConApp_maybe ty
281
  , ASSERT(isNewTyCon tc) True
282
  , Just new_dc <- tyConSingleDataCon_maybe tc = do
283 284
             real_term <- y max_prec t
             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
285 286
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"

287 288 289 290
-------------------------------------------------------
-- Custom Term Pretty Printers
-------------------------------------------------------

291 292
-- We can want to customize the representation of a
--  term depending on its type.
293 294
-- However, note that custom printers have to work with
--  type representations, instead of directly with types.
295
-- We cannot use type classes here, unless we employ some
296 297 298 299
--  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
300
type CustomTermPrinter m = TermPrinterM m
301
                         -> [Precedence -> Term -> (m (Maybe SDoc))]
302

303
-- | Takes a list of custom printers with a explicit recursion knot and a term,
Krzysztof Gogolewski's avatar
Typos  
Krzysztof Gogolewski committed
304
-- and returns the output of the first successful printer, or the default printer
305
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
mnislaih's avatar
mnislaih committed
306 307
cPprTerm printers_ = go 0 where
  printers = printers_ go
308
  go prec t = do
mnislaih's avatar
mnislaih committed
309
    let default_ = Just `liftM` pprTermM go prec t
310
        mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
311 312
    Just doc <- firstJustM mb_customDocs
    return$ cparen (prec>app_prec+1) doc
313

314 315
  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
  firstJustM [] = return Nothing
316

317
-- Default set of custom printers. Note that the recursion knot is explicit
318
cPprTermBase :: forall m. Monad m => CustomTermPrinter m
319
cPprTermBase y =
320
  [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
321 322 323
                                      . mapM (y (-1))
                                      . subTerms)
  , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
324
           ppr_list
325 326 327 328 329 330 331
  , ifTerm' (isTyCon intTyCon    . ty) ppr_int
  , ifTerm' (isTyCon charTyCon   . ty) ppr_char
  , ifTerm' (isTyCon floatTyCon  . ty) ppr_float
  , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
#if defined(INTEGER_GMP)
  , ifTerm' (isIntegerTy         . ty) ppr_integer
#endif
mnislaih's avatar
mnislaih committed
332
  ]
333
 where
334 335 336
   ifTerm :: (Term -> Bool)
          -> (Precedence -> Term -> m SDoc)
          -> Precedence -> Term -> m (Maybe SDoc)
337 338 339 340 341 342 343 344
   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
345

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

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

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

358 359 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 416 417 418
   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
          | "Jp#" <- occNameString (nameOccName (dataConName con)) = Jp#
          | otherwise = Jn#
      return (Just (Ppr.integer (constr (BN# arr#))))
#endif
   ppr_integer _ _ = return Nothing
419 420 421 422 423

   --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
424
           isConsLast = not (termType (last elems) `eqType` termType h)
425
           is_string  = all (isCharTy . ty) elems
426 427
           chars = [ chr (fromIntegral w)
                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
428 429 430

       print_elems <- mapM (y cons_prec) elems
       if is_string
431
        then return (Ppr.doubleQuotes (Ppr.text chars))
432
        else if isConsLast
433 434
        then return $ cparen (p >= cons_prec)
                    $ pprDeeperList fsep
435
                    $ punctuate (space<>colon) print_elems
436
        else return $ brackets
437 438 439 440 441 442 443 444
                    $ 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"
445

446

Ian Lynagh's avatar
Ian Lynagh committed
447 448
repPrim :: TyCon -> [Word] -> SDoc
repPrim t = rep where
449
   rep x
450 451 452
    -- 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
453 454 455 456 457 458 459 460 461 462 463 464
    | 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>"
465
    | t == proxyPrimTyCon            = text "<proxy>"
Ian Lynagh's avatar
Ian Lynagh committed
466 467 468 469
    | t == realWorldTyCon            = text "<realworld>"
    | t == threadIdPrimTyCon         = text "<ThreadId>"
    | t == weakPrimTyCon             = text "<Weak>"
    | t == arrayPrimTyCon            = text "<array>"
470
    | t == smallArrayPrimTyCon       = text "<smallArray>"
Ian Lynagh's avatar
Ian Lynagh committed
471 472
    | t == byteArrayPrimTyCon        = text "<bytearray>"
    | t == mutableArrayPrimTyCon     = text "<mutableArray>"
473
    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
Ian Lynagh's avatar
Ian Lynagh committed
474 475 476 477 478
    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
    | t == mutVarPrimTyCon           = text "<mutVar>"
    | t == mVarPrimTyCon             = text "<mVar>"
    | t == tVarPrimTyCon             = text "<tVar>"
    | otherwise                      = char '<' <> ppr t <> char '>'
479 480 481
    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
482

483 484 485
-----------------------------------
-- Type Reconstruction
-----------------------------------
mnislaih's avatar
mnislaih committed
486 487 488 489 490 491
{-
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:

492
  <datacon reptype>  =  <actual heap contents>
mnislaih's avatar
mnislaih committed
493 494 495 496 497

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.
498 499
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
500 501 502

The function congruenceNewtypes takes a shot at (b)
-}
503 504


pepe's avatar
pepe committed
505 506 507 508 509 510 511 512 513
-- 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
514 515 516 517 518


-- The Type Reconstruction monad
--------------------------------
type TR a = TcM a
pepe's avatar
pepe committed
519 520 521 522 523

runTR :: HscEnv -> TR a -> IO a
runTR hsc_env thing = do
  mb_val <- runTR_maybe hsc_env thing
  case mb_val of
524
    Nothing -> error "unable to :print the term"
525 526 527
    Just x  -> return x

runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
528
runTR_maybe hsc_env thing_inside
529
  = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
530
       ; return res }
531

532
-- | Term Reconstruction trace
533
traceTR :: SDoc -> TR ()
pepe's avatar
pepe committed
534 535 536
traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti


537
-- Semantically different to recoverM in TcRnMonad
pepe's avatar
pepe committed
538 539 540
-- recoverM retains the errors in the first action,
--  whereas recoverTc here does not
recoverTR :: TR a -> TR a -> TR a
541
recoverTR = tryTcDiscardingErrs
542

543
trIO :: IO a -> TR a
twanvl's avatar
twanvl committed
544
trIO = liftTcM . liftIO
545

546
liftTcM :: TcM a -> TR a
mnislaih's avatar
mnislaih committed
547
liftTcM = id
548

549
newVar :: Kind -> TR TcType
550
newVar = liftTcM . newFlexiTyVarTy
551

552 553 554 555
newOpenVar :: TR TcType
newOpenVar = liftTcM newOpenFlexiTyVarTy

instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
556 557
-- Instantiate fresh mutable type variables from some TyVars
-- This function preserves the print-name, which helps error messages
558
instTyVars tvs
559
  = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
560

561
type RttiInstantiation = [(TcTyVar, TyVar)]
562 563
   -- 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
564
   -- debugger-world RuntimeUnk counterparts.
565 566
   -- 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
567
   -- original RuntimeUnk
568

569
-- | Returns the instantiated type scheme ty', and the
570
--   mapping from new (instantiated) -to- old (skolem) type variables
571
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
572
instScheme (tvs, ty)
573 574 575
  = do { (subst, tvs') <- instTyVars tvs
       ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
       ; return (substTy subst ty, rtti_inst) }
576 577 578 579 580 581 582

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
583
    do_pair (tc_tv, rtti_tv)
584 585 586 587
      = do { tc_ty <- zonkTcTyVar tc_tv
           ; case tcGetTyVar_maybe tc_ty of
               Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
               _                        -> return () }
588

589 590 591 592 593
-- 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
594
addConstraint :: TcType -> TcType -> TR ()
pepe's avatar
pepe committed
595
addConstraint actual expected = do
mnislaih's avatar
mnislaih committed
596
    traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
pepe's avatar
pepe committed
597
    recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
598
                                    text "with", ppr expected]) $
599 600
      discardResult $
      captureConstraints $
601
      do { (ty1, ty2) <- congruenceNewtypes actual expected
602
         ; unifyType Nothing ty1 ty2 }
pepe's avatar
pepe committed
603 604
     -- TOMDO: what about the coercion?
     -- we should consider family instances
mnislaih's avatar
mnislaih committed
605

606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623

-- | 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
624
    -> ForeignHValue   -- ^ Object to reconstruct
625
    -> IO Term
pepe's avatar
pepe committed
626 627 628 629
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
630
   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
631
       sigma_old_ty = mkInvForAllTys old_tvs old_tau
pepe's avatar
pepe committed
632 633
   traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
   term <-
634
     if null old_tvs
pepe's avatar
pepe committed
635
      then do
636 637 638
        term  <- go max_depth sigma_old_ty sigma_old_ty hval
        term' <- zonkTerm term
        return $ fixFunDictionaries $ expandNewtypes term'
pepe's avatar
pepe committed
639
      else do
640
              (old_ty', rev_subst) <- instScheme quant_old_ty
641
              my_ty <- newOpenVar
642
              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
pepe's avatar
pepe committed
643 644
                                          addConstraint my_ty old_ty')
              term  <- go max_depth my_ty sigma_old_ty hval
645 646
              new_ty <- zonkTcType (termType term)
              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
pepe's avatar
pepe committed
647 648
                 then do
                      traceTR (text "check2 passed")
649 650
                      addConstraint new_ty old_ty'
                      applyRevSubst rev_subst
pepe's avatar
pepe committed
651
                      zterm' <- zonkTerm term
652
                      return ((fixFunDictionaries . expandNewtypes) zterm')
pepe's avatar
pepe committed
653 654
                 else do
                      traceTR (text "check2 failed" <+> parens
655
                                       (ppr term <+> text "::" <+> ppr new_ty))
pepe's avatar
pepe committed
656 657 658 659 660
                      -- we have unsound types. Replace constructor types in
                      -- subterms with tyvars
                      zterm' <- mapTermTypeM
                                 (\ty -> case tcSplitTyConApp_maybe ty of
                                           Just (tc, _:_) | tc /= funTyCon
661
                                               -> newOpenVar
pepe's avatar
pepe committed
662
                                           _   -> return ty)
663
                                 term
pepe's avatar
pepe committed
664
                      zonkTerm zterm'
mnislaih's avatar
mnislaih committed
665 666 667
   traceTR (text "Term reconstruction completed." $$
            text "Term obtained: " <> ppr term $$
            text "Type obtained: " <> ppr (termType term))
pepe's avatar
pepe committed
668
   return term
669
    where
670
  go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
Gabor Greif's avatar
Gabor Greif committed
671
   -- I believe that my_ty should not have any enclosing
672 673 674
   -- foralls, nor any free RuntimeUnk skolems;
   -- that is partly what the quantifyType stuff achieved
   --
675 676
   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty

pepe's avatar
pepe committed
677
  go 0 my_ty _old_ty a = do
mnislaih's avatar
mnislaih committed
678 679
    traceTR (text "Gave up reconstructing a term after" <>
                  int max_depth <> text " steps")
680
    clos <- trIO $ GHCi.getClosure hsc_env a
patrickdoc's avatar
patrickdoc committed
681
    return (Suspension (tipe (info clos)) my_ty a Nothing)
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
682
  go !max_depth my_ty old_ty a = do
683
    let monomorphic = not(isTyVarTy my_ty)
684 685
    -- This ^^^ is a convention. The ancestor tests for
    -- monomorphism and passes a type instead of a tv
686
    clos <- trIO $ GHCi.getClosure hsc_env a
patrickdoc's avatar
patrickdoc committed
687
    case clos of
688
-- Thunks we may want to force
689 690 691 692
      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
693 694 695
-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE.  So we
-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
-- showing '_' which is what we want.
patrickdoc's avatar
patrickdoc committed
696 697
      BlackholeClosure{indirectee=ind} -> do
         traceTR (text "Following a BLACKHOLE")
698
         go max_depth my_ty old_ty ind
pepe's avatar
pepe committed
699
-- We always follow indirections
patrickdoc's avatar
patrickdoc committed
700 701
      IndClosure{indirectee=ind} -> do
         traceTR (text "Following an indirection" )
702
         go max_depth my_ty old_ty ind
703
-- We also follow references
704
      MutVarClosure{var=contents}
patrickdoc's avatar
patrickdoc committed
705
         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
706
             -> do
pepe's avatar
pepe committed
707
                  -- Deal with the MutVar# primitive
708
                  -- It does not have a constructor at all,
pepe's avatar
pepe committed
709 710 711 712
                  -- so we simulate the following one
                  -- MutVar# :: contents_ty -> MutVar# s contents_ty
         traceTR (text "Following a MutVar")
         contents_tv <- newVar liftedTypeKind
Richard Eisenberg's avatar
Richard Eisenberg committed
713
         ASSERT(isUnliftedType my_ty) return ()
714
         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
pepe's avatar
pepe committed
715 716 717 718
                            contents_ty (mkTyConApp tycon [world,contents_ty])
         addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
         x <- go (pred max_depth) contents_tv contents_ty contents
         return (RefWrap my_ty x)
719

720
 -- The interesting case
721 722
      ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
        traceTR (text "entering a constructor " <> ppr dArgs <+>
mnislaih's avatar
mnislaih committed
723 724
                      if monomorphic
                        then parens (text "already monomorphic: " <> ppr my_ty)
725
                        else Ppr.empty)
patrickdoc's avatar
patrickdoc committed
726 727
        Right dcname <- liftIO $ constrClosToName hsc_env clos
        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
728 729 730 731 732 733
        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.
734
                       traceTR (text "Not constructor" <+> ppr dcname)
Ian Lynagh's avatar
Ian Lynagh committed
735 736
                       let dflags = hsc_dflags hsc_env
                           tag = showPpr dflags dcname
patrickdoc's avatar
patrickdoc committed
737
                       vars     <- replicateM (length pArgs)
738
                                              (newVar liftedTypeKind)
739 740
                       subTerms <- sequence $ zipWith (\x tv ->
                           go (pred max_depth) tv tv x) pArgs vars
pepe's avatar
pepe committed
741 742
                       return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
          Just dc -> do
743
            traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
744
            subTtypes <- getDataConArgTys dc my_ty
745
            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
pepe's avatar
pepe committed
746
            return (Term my_ty (Right dc) a subTerms)
747

748 749 750 751 752 753 754
      -- 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])

755
-- The otherwise case: can be a Thunk,AP,PAP,etc.
patrickdoc's avatar
patrickdoc committed
756
      _ -> do
757 758
         traceTR (text "Unknown closure:" <+>
                  text (show (fmap (const ()) clos)))
patrickdoc's avatar
patrickdoc committed
759
         return (Suspension (tipe (info clos)) my_ty a Nothing)
760

pepe's avatar
pepe committed
761 762 763 764 765 766 767 768 769 770 771
  -- 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

772

pepe's avatar
pepe committed
773 774 775 776
   -- 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
777

778 779
extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
                -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
780
extractSubTerms recurse clos = liftM thdOf3 . go 0 0
781
  where
patrickdoc's avatar
patrickdoc committed
782
    array = dataArgs clos
783 784 785

    go ptr_i arr_i [] = return (ptr_i, arr_i, [])
    go ptr_i arr_i (ty:tys)
786 787
      | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
      , isUnboxedTupleTyCon tc
788
                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
789 790 791 792
      = do (ptr_i, arr_i, terms0) <-
               go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
793
      | otherwise
Richard Eisenberg's avatar
Richard Eisenberg committed
794
      = case typePrimRepArgs ty of
795
          [rep_ty] ->  do
796 797 798
            (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i ty rep_ty
            (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
            return (ptr_i, arr_i, term0 : terms1)
799
          rep_tys -> do
800 801 802
           (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
803

804 805
    go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
    go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
806
      tv <- newVar liftedTypeKind
807 808 809 810 811 812
      (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i tv rep_ty
      (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
      return (ptr_i, arr_i, term0 : terms1)

    go_rep ptr_i arr_i ty rep
      | isGcPtrRep rep = do
813
          t <- recurse ty $ (ptrArgs clos)!!ptr_i
814 815 816 817 818 819 820 821
          return (ptr_i + 1, arr_i, t)
      | otherwise = do
          -- This is a bit involved since we allow packing multiple fields
          -- within a single word. See also
          -- StgCmmLayout.mkVirtHeapOffsetsWithPadding
          dflags <- getDynFlags
          let word_size = wORD_SIZE dflags
              size_b = primRepSizeB dflags rep
822 823 824 825 826
              -- Align the start offset (eg, 2-byte value should be 2-byte
              -- aligned). But not more than to a word. The offset calculation
              -- should be the same with the offset calculation in
              -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.
              !aligned_idx = roundUpTo arr_i (min word_size size_b)
827
              !new_arr_i = aligned_idx + size_b
patrickdoc's avatar
patrickdoc committed
828
              ws | size_b < word_size =
829
                     [index size_b aligned_idx word_size]
patrickdoc's avatar
patrickdoc committed
830 831 832 833 834 835 836
                 | otherwise =
                     let (q, r) = size_b `quotRem` word_size
                     in ASSERT( r == 0 )
                        [ array!!i
                        | o <- [0.. q - 1]
                        , let i = (aligned_idx `quot` word_size) + o
                        ]
837
          return (ptr_i, new_arr_i, Prim ty ws)
838

839 840 841
    unboxedTupleTerm ty terms
      = Term ty (Right (tupleDataCon Unboxed (length terms)))
                (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
842

patrickdoc's avatar
patrickdoc committed
843
    -- Extract a sub-word sized field from a word
844
    index item_size_b index_b word_size =
patrickdoc's avatar
patrickdoc committed
845 846 847 848 849 850 851 852 853 854 855
        (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
      where
        mask :: Word
        mask = case item_size_b of
            1 -> 0xFF
            2 -> 0xFFFF
            4 -> 0xFFFFFFFF
            _ -> panic ("Weird byte-index: " ++ show index_b)
        (q,r) = index_b `quotRem` word_size
        word = array!!q
        moveBytes = r * 8
856

857

858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884
-- | Fast, breadth-first Type reconstruction
--
-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually
-- obtained in GHCi), try to reconstruct a more monomorphic type of the object.
-- This is used for improving type information in debugger. For example, if we
-- have a polymorphic function:
--