RtClosureInspect.hs 50.6 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
     cvObtainTerm,      -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
12
     cvReconstructType,
13
     improveRTTIType,
pepe's avatar
pepe committed
14 15 16 17

     Term(..),
     isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
     isFullyEvaluated, isFullyEvaluatedTerm,
18
     termType, mapTermType, termTyCoVars,
pepe's avatar
pepe committed
19 20 21 22 23
     foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
     pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,

--     unsafeDeepSeq,

24
     Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
pepe's avatar
pepe committed
25
 ) where
26 27 28

#include "HsVersions.h"

29
import DebuggerUtils
30 31 32
import GHCi.RemoteTypes ( HValue )
import qualified GHCi.InfoTable as InfoTable
import GHCi.InfoTable (StgInfoTable, peekItbl)
pepe's avatar
pepe committed
33
import HscTypes
34

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

47 48
import TyCon
import Name
49
import Util
50
import VarSet
51
import BasicTypes       ( Boxity(..) )
52
import TysPrim
53 54
import PrelNames
import TysWiredIn
pepe's avatar
pepe committed
55
import DynFlags
56
import Outputable as Ppr
57
import GHC.Arr          ( Array(..) )
58
import GHC.Exts
59
import GHC.IO ( IO(..) )
60 61 62 63

import Control.Monad
import Data.Maybe
import Data.Array.Base
mnislaih's avatar
mnislaih committed
64
import Data.Ix
pepe's avatar
pepe committed
65
import Data.List
66
import qualified Data.Sequence as Seq
67
import Data.Sequence (viewl, ViewL(..))
68
import Foreign
Ross Paterson's avatar
Ross Paterson committed
69
import System.IO.Unsafe
70

71 72 73 74
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------

pepe's avatar
pepe committed
75
data Term = Term { ty        :: RttiType
76
                 , dc        :: Either String DataCon
mnislaih's avatar
mnislaih committed
77
                               -- Carries a text representation if the datacon is
78
                               -- not exported by the .hi file, which is the case
mnislaih's avatar
mnislaih committed
79
                               -- for private constructors in -O0 compiled libraries
80
                 , val       :: HValue
81 82
                 , subTerms  :: [Term] }

pepe's avatar
pepe committed
83
          | Prim { ty        :: RttiType
84
                 , value     :: [Word] }
85 86

          | Suspension { ctype    :: ClosureType
pepe's avatar
pepe committed
87
                       , ty       :: RttiType
88 89 90
                       , val      :: HValue
                       , bound_to :: Maybe Name   -- Useful for printing
                       }
pepe's avatar
pepe committed
91 92 93 94 95
          | 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
96 97
                       , dc           :: Either String DataCon
                       , wrapped_term :: Term }
pepe's avatar
pepe committed
98 99
          | RefWrap    {       -- The contents of a reference
                         ty           :: RttiType
100
                       , wrapped_term :: Term }
101

pepe's avatar
pepe committed
102
isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
103 104 105 106 107 108
isTerm Term{} = True
isTerm   _    = False
isSuspension Suspension{} = True
isSuspension      _       = False
isPrim Prim{} = True
isPrim   _    = False
109 110
isNewtypeWrap NewtypeWrap{} = True
isNewtypeWrap _             = False
111

pepe's avatar
pepe committed
112 113 114 115 116 117 118
isFun Suspension{ctype=Fun} = True
isFun _ = False

isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
isFunLike _ = False

termType :: Term -> RttiType
mnislaih's avatar
mnislaih committed
119
termType t = ty t
120

mnislaih's avatar
mnislaih committed
121 122 123
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Prim {}            = True
124
isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
125
isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
126
isFullyEvaluatedTerm _                  = False
mnislaih's avatar
mnislaih committed
127

128
instance Outputable (Term) where
mnislaih's avatar
mnislaih committed
129 130
 ppr t | Just doc <- cPprTerm cPprTermBase t = doc
       | otherwise = panic "Outputable Term instance"
131 132 133 134

-------------------------------------------------------------------------
-- Runtime Closure Datatype and functions for retrieving closure related stuff
-------------------------------------------------------------------------
135 136 137
data ClosureType = Constr
                 | Fun
                 | Thunk Int
138
                 | ThunkSelector
139 140 141 142
                 | Blackhole
                 | AP
                 | PAP
                 | Indirection Int
143
                 | MutVar Int
pepe's avatar
pepe committed
144
                 | MVar   Int
145
                 | Other  Int
146 147
 deriving (Show, Eq)

148
data Closure = Closure { tipe         :: ClosureType
149
                       , infoPtr      :: Ptr ()
150 151
                       , infoTable    :: StgInfoTable
                       , ptrs         :: Array Int HValue
152
                       , nonPtrs      :: [Word]
153 154 155
                       }

instance Outputable ClosureType where
156
  ppr = text . show
157

Simon Marlow's avatar
Simon Marlow committed
158
#include "../includes/rts/storage/ClosureTypes.h"
159

mnislaih's avatar
mnislaih committed
160
aP_CODE, pAP_CODE :: Int
161 162 163 164 165
aP_CODE = AP
pAP_CODE = PAP
#undef AP
#undef PAP

166 167
getClosureData :: DynFlags -> a -> IO Closure
getClosureData dflags a =
168
   case unpackClosure# a of
169
     (# iptr, ptrs, nptrs #) -> do
170 171 172
           let iptr0 = Ptr iptr
           let iptr1
                | ghciTablesNextToCode = iptr0
Ian Lynagh's avatar
Ian Lynagh committed
173 174 175 176 177 178
                | otherwise =
                   -- the info pointer we get back from unpackClosure#
                   -- is to the beginning of the standard info table,
                   -- but the Storable instance for info tables takes
                   -- into account the extra entry pointer when
                   -- !ghciTablesNextToCode, so we must adjust here:
179
                   iptr0 `plusPtr` negate (wORD_SIZE dflags)
180 181 182
           itbl <- peekItbl iptr1
           let tipe = readCType (InfoTable.tipe itbl)
               elems = fromIntegral (InfoTable.ptrs itbl)
183
               ptrsList = Array 0 (elems - 1) elems ptrs
184
               nptrs_data = [W# (indexWordArray# nptrs i)
185
                            | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]
186
           ASSERT(elems >= 0) return ()
187
           ptrsList `seq`
188
            return (Closure tipe iptr0 itbl ptrsList nptrs_data)
189 190

readCType :: Integral a => a -> ClosureType
191
readCType i
Simon Marlow's avatar
Simon Marlow committed
192
 | i >= CONSTR && i <= CONSTR_NOCAF        = Constr
193
 | i >= FUN    && i <= FUN_STATIC          = Fun
194
 | i >= THUNK  && i < THUNK_SELECTOR       = Thunk i'
195 196
 | i == THUNK_SELECTOR                     = ThunkSelector
 | i == BLACKHOLE                          = Blackhole
197 198
 | i >= IND    && i <= IND_STATIC          = Indirection i'
 | i' == aP_CODE                           = AP
199
 | i == AP_STACK                           = AP
200
 | i' == pAP_CODE                          = PAP
pepe's avatar
pepe committed
201 202
 | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
 | i == MVAR_CLEAN    || i == MVAR_DIRTY   = MVar i'
203 204
 | otherwise                               = Other  i'
  where i' = fromIntegral i
205

206
isConstr, isIndirection, isThunk :: ClosureType -> Bool
207 208 209 210 211 212
isConstr Constr = True
isConstr    _   = False

isIndirection (Indirection _) = True
isIndirection _ = False

213 214 215 216 217
isThunk (Thunk _)     = True
isThunk ThunkSelector = True
isThunk AP            = True
isThunk _             = False

218 219 220
isFullyEvaluated :: DynFlags -> a -> IO Bool
isFullyEvaluated dflags a = do
  closure <- getClosureData dflags a
221
  case tipe closure of
222
    Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure)
223
                 return$ and are_subs_evaluated
mnislaih's avatar
mnislaih committed
224
    _      -> return False
225 226 227 228 229 230 231
  where amapM f = sequence . amap' f

-- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
{-
unsafeDeepSeq :: a -> b -> b
unsafeDeepSeq = unsafeDeepSeq1 2
 where unsafeDeepSeq1 0 a b = seq a $! b
232
       unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
233
        | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
234 235 236 237 238 239 240
     -- | unsafePerformIO (isFullyEvaluated a) = b
        | otherwise = case unsafePerformIO (getClosureData a) of
                        closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
        where tipe = unsafePerformIO (getClosureType a)
-}

-----------------------------------
mnislaih's avatar
mnislaih committed
241
-- * Traversals for Terms
242
-----------------------------------
pepe's avatar
pepe committed
243
type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
244

245
data TermFold a = TermFold { fTerm        :: TermProcessor a a
pepe's avatar
pepe committed
246 247
                           , fPrim        :: RttiType -> [Word] -> a
                           , fSuspension  :: ClosureType -> RttiType -> HValue
mnislaih's avatar
mnislaih committed
248
                                            -> Maybe Name -> a
pepe's avatar
pepe committed
249
                           , fNewtypeWrap :: RttiType -> Either String DataCon
250
                                            -> a -> a
pepe's avatar
pepe committed
251 252 253 254 255 256 257 258 259 260 261 262
                           , fRefWrap     :: RttiType -> a -> a
                           }


data TermFoldM m a =
                   TermFoldM {fTermM        :: TermProcessor a (m a)
                            , fPrimM        :: RttiType -> [Word] -> m a
                            , fSuspensionM  :: ClosureType -> RttiType -> HValue
                                             -> Maybe Name -> m a
                            , fNewtypeWrapM :: RttiType -> Either String DataCon
                                            -> a -> m a
                            , fRefWrapM     :: RttiType -> a -> m a
263 264 265 266 267 268
                           }

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
269
foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
270
foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
271

pepe's avatar
pepe committed
272 273 274 275 276 277 278 279

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

280 281 282 283
idTermFold :: TermFold Term
idTermFold = TermFold {
              fTerm = Term,
              fPrim = Prim,
284
              fSuspension  = Suspension,
285 286
              fNewtypeWrap = NewtypeWrap,
              fRefWrap = RefWrap
287 288
                      }

pepe's avatar
pepe committed
289
mapTermType :: (RttiType -> Type) -> Term -> Term
290 291
mapTermType f = foldTerm idTermFold {
          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
mnislaih's avatar
mnislaih committed
292 293
          fSuspension = \ct ty hval n ->
                          Suspension ct (f ty) hval n,
294 295
          fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
          fRefWrap    = \ty t -> RefWrap (f ty) t}
296

pepe's avatar
pepe committed
297 298 299 300 301 302 303 304 305
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}

306 307
termTyCoVars :: Term -> TyCoVarSet
termTyCoVars = foldTerm TermFold {
308
            fTerm       = \ty _ _ tt   ->
David Feuer's avatar
David Feuer committed
309
                          tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
310
            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
David Feuer's avatar
David Feuer committed
311 312 313 314
            fPrim       = \ _ _ -> emptyVarSet,
            fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
            fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
    where concatVarEnv = foldr unionVarSet emptyVarSet
315

316 317 318 319
----------------------------------
-- Pretty printing of terms
----------------------------------

mnislaih's avatar
mnislaih committed
320 321 322 323
type Precedence        = Int
type TermPrinter       = Precedence -> Term ->   SDoc
type TermPrinterM m    = Precedence -> Term -> m SDoc

mnislaih's avatar
mnislaih committed
324 325 326
app_prec,cons_prec, max_prec ::Int
max_prec  = 10
app_prec  = max_prec
327
cons_prec = 5 -- TODO Extract this info from GHC itself
328

mnislaih's avatar
mnislaih committed
329 330
pprTerm :: TermPrinter -> TermPrinter
pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
mnislaih's avatar
mnislaih committed
331
pprTerm _ _ _ = panic "pprTerm"
332

mnislaih's avatar
mnislaih committed
333 334 335 336
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
337
  tt_docs <- mapM (y app_prec) tt
dterei's avatar
dterei committed
338 339
  return $ cparen (not (null tt) && p >= app_prec)
                  (text dc_tag <+> pprDeeperList fsep tt_docs)
340

Sylvain Henry's avatar
Sylvain Henry committed
341
ppr_termM y p Term{dc=Right dc, subTerms=tt} = do
342
{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
343 344
  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
    <+> hsep (map (ppr_term1 True) tt)
345
-} -- TODO Printing infix constructors properly
Sylvain Henry's avatar
Sylvain Henry committed
346 347 348 349 350 351 352 353 354 355 356
  tt_docs' <- mapM (y app_prec) tt
  return $ sdocWithPprDebug $ \dbg ->
    -- Don't show the dictionary arguments to
    -- constructors unless -dppr-debug is on
    let tt_docs = if dbg
           then tt_docs'
           else dropList (dataConTheta dc) tt_docs'
    in if null tt_docs
      then ppr dc
      else cparen (p >= app_prec) $
             sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
357

mnislaih's avatar
mnislaih committed
358
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
mnislaih's avatar
mnislaih committed
359
ppr_termM y p RefWrap{wrapped_term=t}  = do
360 361 362 363 364 365 366
  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
367
ppr_termM _ _ t = ppr_termM1 t
mnislaih's avatar
mnislaih committed
368

mnislaih's avatar
mnislaih committed
369

370
ppr_termM1 :: Monad m => Term -> m SDoc
371
ppr_termM1 Prim{value=words, ty=ty} =
Ian Lynagh's avatar
Ian Lynagh committed
372
    return $ repPrim (tyConAppTyCon ty) words
373
ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
pepe's avatar
pepe committed
374
    return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
mnislaih's avatar
mnislaih committed
375
ppr_termM1 Suspension{ty=ty, bound_to=Just n}
pepe's avatar
pepe committed
376
--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
377 378 379 380
  | 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
381

382
pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
383
  | Just (tc,_) <- tcSplitTyConApp_maybe ty
384
  , ASSERT(isNewTyCon tc) True
385
  , Just new_dc <- tyConSingleDataCon_maybe tc = do
386 387
             real_term <- y max_prec t
             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
388 389
pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"

390 391 392 393
-------------------------------------------------------
-- Custom Term Pretty Printers
-------------------------------------------------------

394 395
-- We can want to customize the representation of a
--  term depending on its type.
396 397
-- However, note that custom printers have to work with
--  type representations, instead of directly with types.
398
-- We cannot use type classes here, unless we employ some
399 400 401 402
--  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
403
type CustomTermPrinter m = TermPrinterM m
404
                         -> [Precedence -> Term -> (m (Maybe SDoc))]
405

406
-- | Takes a list of custom printers with a explicit recursion knot and a term,
Krzysztof Gogolewski's avatar
Typos  
Krzysztof Gogolewski committed
407
-- and returns the output of the first successful printer, or the default printer
408
cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
mnislaih's avatar
mnislaih committed
409 410
cPprTerm printers_ = go 0 where
  printers = printers_ go
411
  go prec t = do
mnislaih's avatar
mnislaih committed
412
    let default_ = Just `liftM` pprTermM go prec t
413
        mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
414 415
    Just doc <- firstJustM mb_customDocs
    return$ cparen (prec>app_prec+1) doc
416

417 418
  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
  firstJustM [] = return Nothing
419

420
-- Default set of custom printers. Note that the recursion knot is explicit
421
cPprTermBase :: forall m. Monad m => CustomTermPrinter m
422
cPprTermBase y =
423
  [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
424 425 426
                                      . mapM (y (-1))
                                      . subTerms)
  , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
427 428 429 430 431 432
           ppr_list
  , 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
433
  ]
434
 where
435 436 437 438 439 440 441
   ifTerm :: (Term -> Bool)
          -> (Precedence -> Term -> m SDoc)
          -> Precedence -> Term -> m (Maybe SDoc)
   ifTerm pred f prec t@Term{}
       | pred t    = Just `liftM` f prec t
   ifTerm _ _ _ _  = return Nothing

442 443
   isTupleTy ty    = fromMaybe False $ do
     (tc,_) <- tcSplitTyConApp_maybe ty
444 445
     return (isBoxedTupleTyCon tc)

446
   isTyCon a_tc ty = fromMaybe False $ do
447 448 449 450 451 452 453
     (tc,_) <- tcSplitTyConApp_maybe ty
     return (a_tc == tc)

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

454
   ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
455 456 457 458 459 460 461 462 463 464 465
      :: Precedence -> Term -> m SDoc
   ppr_int     _ v = return (Ppr.int     (unsafeCoerce# (val v)))
   ppr_char    _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
   ppr_float   _ v = return (Ppr.float   (unsafeCoerce# (val v)))
   ppr_double  _ v = return (Ppr.double  (unsafeCoerce# (val v)))
   ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))

   --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
466
           isConsLast = not (termType (last elems) `eqType` termType h)
467
           is_string  = all (isCharTy . ty) elems
468 469 470 471 472

       print_elems <- mapM (y cons_prec) elems
       if is_string
        then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
        else if isConsLast
473 474
        then return $ cparen (p >= cons_prec)
                    $ pprDeeperList fsep
475
                    $ punctuate (space<>colon) print_elems
476
        else return $ brackets
477 478 479 480 481 482 483 484
                    $ 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"
485

486

Ian Lynagh's avatar
Ian Lynagh committed
487 488
repPrim :: TyCon -> [Word] -> SDoc
repPrim t = rep where
489
   rep x
Ian Lynagh's avatar
Ian Lynagh committed
490 491 492 493 494 495 496 497 498 499 500 501 502
    | t == charPrimTyCon             = text $ show (build x :: Char)
    | 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>"
503
    | t == proxyPrimTyCon            = text "<proxy>"
Ian Lynagh's avatar
Ian Lynagh committed
504 505 506 507
    | t == realWorldTyCon            = text "<realworld>"
    | t == threadIdPrimTyCon         = text "<ThreadId>"
    | t == weakPrimTyCon             = text "<Weak>"
    | t == arrayPrimTyCon            = text "<array>"
508
    | t == smallArrayPrimTyCon       = text "<smallArray>"
Ian Lynagh's avatar
Ian Lynagh committed
509 510
    | t == byteArrayPrimTyCon        = text "<bytearray>"
    | t == mutableArrayPrimTyCon     = text "<mutableArray>"
511
    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
Ian Lynagh's avatar
Ian Lynagh committed
512 513 514 515 516
    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
    | t == mutVarPrimTyCon           = text "<mutVar>"
    | t == mVarPrimTyCon             = text "<mVar>"
    | t == tVarPrimTyCon             = text "<tVar>"
    | otherwise                      = char '<' <> ppr t <> char '>'
517 518 519
    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
520

521 522 523
-----------------------------------
-- Type Reconstruction
-----------------------------------
mnislaih's avatar
mnislaih committed
524 525 526 527 528 529
{-
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:

530
  <datacon reptype>  =  <actual heap contents>
mnislaih's avatar
mnislaih committed
531 532 533 534 535

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.
536 537
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
538 539 540

The function congruenceNewtypes takes a shot at (b)
-}
541 542


pepe's avatar
pepe committed
543 544 545 546 547 548 549 550 551
-- 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
552 553 554 555 556


-- The Type Reconstruction monad
--------------------------------
type TR a = TcM a
pepe's avatar
pepe committed
557 558 559 560 561

runTR :: HscEnv -> TR a -> IO a
runTR hsc_env thing = do
  mb_val <- runTR_maybe hsc_env thing
  case mb_val of
562
    Nothing -> error "unable to :print the term"
563 564 565
    Just x  -> return x

runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
566
runTR_maybe hsc_env thing_inside
567
  = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
568
       ; return res }
569

570
-- | Term Reconstruction trace
571
traceTR :: SDoc -> TR ()
pepe's avatar
pepe committed
572 573 574
traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti


575
-- Semantically different to recoverM in TcRnMonad
pepe's avatar
pepe committed
576 577 578
-- recoverM retains the errors in the first action,
--  whereas recoverTc here does not
recoverTR :: TR a -> TR a -> TR a
579
recoverTR = tryTcDiscardingErrs
580

581
trIO :: IO a -> TR a
twanvl's avatar
twanvl committed
582
trIO = liftTcM . liftIO
583

584
liftTcM :: TcM a -> TR a
mnislaih's avatar
mnislaih committed
585
liftTcM = id
586

587
newVar :: Kind -> TR TcType
588
newVar = liftTcM . newFlexiTyVarTy
589

590 591 592 593
newOpenVar :: TR TcType
newOpenVar = liftTcM newOpenFlexiTyVarTy

instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
594 595
-- Instantiate fresh mutable type variables from some TyVars
-- This function preserves the print-name, which helps error messages
596
instTyVars tvs
597
  = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
598

599
type RttiInstantiation = [(TcTyVar, TyVar)]
600 601
   -- 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
602
   -- debugger-world RuntimeUnk counterparts.
603 604
   -- 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
605
   -- original RuntimeUnk
606

607
-- | Returns the instantiated type scheme ty', and the
608
--   mapping from new (instantiated) -to- old (skolem) type variables
609
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
610
instScheme (tvs, ty)
611 612 613
  = do { (subst, tvs') <- instTyVars tvs
       ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
       ; return (substTy subst ty, rtti_inst) }
614 615 616 617 618 619 620

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
621
    do_pair (tc_tv, rtti_tv)
622 623 624 625
      = do { tc_ty <- zonkTcTyVar tc_tv
           ; case tcGetTyVar_maybe tc_ty of
               Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
               _                        -> return () }
626

627 628 629 630 631
-- 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
632
addConstraint :: TcType -> TcType -> TR ()
pepe's avatar
pepe committed
633
addConstraint actual expected = do
mnislaih's avatar
mnislaih committed
634
    traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
pepe's avatar
pepe committed
635
    recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
636
                                    text "with", ppr expected]) $
637 638
      discardResult $
      captureConstraints $
639
      do { (ty1, ty2) <- congruenceNewtypes actual expected
640
         ; unifyType Nothing ty1 ty2 }
pepe's avatar
pepe committed
641 642
     -- TOMDO: what about the coercion?
     -- we should consider family instances
mnislaih's avatar
mnislaih committed
643

644 645
-- Type & Term reconstruction
------------------------------
pepe's avatar
pepe committed
646 647 648 649 650
cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
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
651
   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
652
       sigma_old_ty = mkInvForAllTys old_tvs old_tau
pepe's avatar
pepe committed
653 654
   traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
   term <-
655
     if null old_tvs
pepe's avatar
pepe committed
656
      then do
657 658 659
        term  <- go max_depth sigma_old_ty sigma_old_ty hval
        term' <- zonkTerm term
        return $ fixFunDictionaries $ expandNewtypes term'
pepe's avatar
pepe committed
660
      else do
661
              (old_ty', rev_subst) <- instScheme quant_old_ty
662
              my_ty <- newOpenVar
663
              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
pepe's avatar
pepe committed
664 665
                                          addConstraint my_ty old_ty')
              term  <- go max_depth my_ty sigma_old_ty hval
666 667
              new_ty <- zonkTcType (termType term)
              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
pepe's avatar
pepe committed
668 669
                 then do
                      traceTR (text "check2 passed")
670 671
                      addConstraint new_ty old_ty'
                      applyRevSubst rev_subst
pepe's avatar
pepe committed
672
                      zterm' <- zonkTerm term
673
                      return ((fixFunDictionaries . expandNewtypes) zterm')
pepe's avatar
pepe committed
674 675
                 else do
                      traceTR (text "check2 failed" <+> parens
676
                                       (ppr term <+> text "::" <+> ppr new_ty))
pepe's avatar
pepe committed
677 678 679 680 681
                      -- we have unsound types. Replace constructor types in
                      -- subterms with tyvars
                      zterm' <- mapTermTypeM
                                 (\ty -> case tcSplitTyConApp_maybe ty of
                                           Just (tc, _:_) | tc /= funTyCon
682
                                               -> newOpenVar
pepe's avatar
pepe committed
683
                                           _   -> return ty)
684
                                 term
pepe's avatar
pepe committed
685
                      zonkTerm zterm'
mnislaih's avatar
mnislaih committed
686 687 688
   traceTR (text "Term reconstruction completed." $$
            text "Term obtained: " <> ppr term $$
            text "Type obtained: " <> ppr (termType term))
pepe's avatar
pepe committed
689
   return term
690
    where
691
  dflags = hsc_dflags hsc_env
692

pepe's avatar
pepe committed
693
  go :: Int -> Type -> Type -> HValue -> TcM Term
Gabor Greif's avatar
Gabor Greif committed
694
   -- I believe that my_ty should not have any enclosing
695 696 697
   -- foralls, nor any free RuntimeUnk skolems;
   -- that is partly what the quantifyType stuff achieved
   --
698 699
   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty

pepe's avatar
pepe committed
700
  go 0 my_ty _old_ty a = do
mnislaih's avatar
mnislaih committed
701 702
    traceTR (text "Gave up reconstructing a term after" <>
                  int max_depth <> text " steps")
703
    clos <- trIO $ getClosureData dflags a
pepe's avatar
pepe committed
704
    return (Suspension (tipe clos) my_ty a Nothing)
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
705
  go !max_depth my_ty old_ty a = do
706
    let monomorphic = not(isTyVarTy my_ty)
707 708
    -- This ^^^ is a convention. The ancestor tests for
    -- monomorphism and passes a type instead of a tv
709
    clos <- trIO $ getClosureData dflags a
710
    case tipe clos of
711
-- Thunks we may want to force
pepe's avatar
pepe committed
712 713
      t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
                                seq a (go (pred max_depth) my_ty old_ty a)
714 715 716 717 718
-- 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.
      Blackhole -> do traceTR (text "Following a BLACKHOLE")
                      appArr (go max_depth my_ty old_ty) (ptrs clos) 0
pepe's avatar
pepe committed
719 720 721
-- We always follow indirections
      Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
                          go max_depth my_ty old_ty $! (ptrs clos ! 0)
722
-- We also follow references
pepe's avatar
pepe committed
723
      MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
724
             -> do
pepe's avatar
pepe committed
725
                  -- Deal with the MutVar# primitive
726
                  -- It does not have a constructor at all,
pepe's avatar
pepe committed
727 728 729 730
                  -- so we simulate the following one
                  -- MutVar# :: contents_ty -> MutVar# s contents_ty
         traceTR (text "Following a MutVar")
         contents_tv <- newVar liftedTypeKind
731
         contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
Richard Eisenberg's avatar
Richard Eisenberg committed
732
         ASSERT(isUnliftedType my_ty) return ()
733
         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
pepe's avatar
pepe committed
734 735 736 737
                            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)
738

739 740
 -- The interesting case
      Constr -> do
mnislaih's avatar
mnislaih committed
741 742 743
        traceTR (text "entering a constructor " <>
                      if monomorphic
                        then parens (text "already monomorphic: " <> ppr my_ty)
744
                        else Ppr.empty)
745
        Right dcname <- dataConInfoPtrToName (infoPtr clos)
746
        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
747 748 749 750 751 752
        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.
753
                       traceTR (text "Not constructor" <+> ppr dcname)
Ian Lynagh's avatar
Ian Lynagh committed
754 755
                       let dflags = hsc_dflags hsc_env
                           tag = showPpr dflags dcname
756
                       vars     <- replicateM (length$ elems$ ptrs clos)
757
                                              (newVar liftedTypeKind)
758
                       subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
759
                                              | (i, tv) <- zip [0..] vars]
pepe's avatar
pepe committed
760 761
                       return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
          Just dc -> do
762
            traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
763
            subTtypes <- getDataConArgTys dc my_ty
764
            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
pepe's avatar
pepe committed
765
            return (Term my_ty (Right dc) a subTerms)
766

767
-- The otherwise case: can be a Thunk,AP,PAP,etc.
768 769
      tipe_clos -> do
         traceTR (text "Unknown closure:" <+> ppr tipe_clos)
pepe's avatar
pepe committed
770
         return (Suspension tipe_clos my_ty a Nothing)
771

pepe's avatar
pepe committed
772 773 774 775 776 777 778 779 780 781 782
  -- 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

783

pepe's avatar
pepe committed
784 785 786 787
   -- 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
788

789 790
extractSubTerms :: (Type -> HValue -> TcM Term)
                -> Closure -> [Type] -> TcM [Term]
791
extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
792 793 794 795 796
  where
    go ptr_i ws [] = return (ptr_i, ws, [])
    go ptr_i ws (ty:tys)
      | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
      , isUnboxedTupleTyCon tc
797 798
                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
      = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
799 800 801
           (ptr_i, ws, terms1) <- go ptr_i ws tys
           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
      | otherwise
Richard Eisenberg's avatar
Richard Eisenberg committed
802
      = case typePrimRepArgs ty of
803
          [rep_ty] ->  do
Richard Eisenberg's avatar
Richard Eisenberg committed
804
            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep_ty
805 806
            (ptr_i, ws, terms1) <- go