src/GHC/HeapView.hs

   1 {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards #-}
   2
   3 module GHC.HeapView where
   4
   5 import System.IO.Unsafe
   6 import GHC.Exts
   7 import GHC.Prim
   8 import System.Environment
   9 import GHC.Arr ((!), Array(..), elems)
  10
  11 import GHC.Constants ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
  12
  13 import System.Mem
  14 import System.Mem.StableName
  15 import Foreign
  16 import Foreign.C
  17 import Foreign.Ptr
  18 import Foreign.Storable
  19 import Foreign.Marshal.Array
  20 import Numeric          ( showHex )
  21 import Data.Word
  22 import Data.Bits
  23 import Data.Char
  24 import Control.Monad
  25
  26 newtype HValue = HValue Any
  27
  28 -- A Safegard of HValues
  29 data Box = Box HValue
  30
  31 type HalfWord = Word32
  32
  33 instance Show Box where
  34 -- From libraries/base/GHC/Ptr.lhs
  35    showsPrec _ (Box (HValue any)) rs =
  36     -- unsafePerformIO (print "↓" >> pClosure any) `seq`
  37     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
  38      where
  39        ptr  = W# (aToWord# any)
  40        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
  41        addr = ptr - tag
  42         -- want 0s prefixed to pad it out to a fixed length.
  43        pad_out ls =
  44           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
  45
  46 asBox :: a -> Box
  47 asBox x = Box (unsafeCoerce# x)
  48
  49 {-
  50  - StgInfoTable parsing derived from ByteCodeItbls.lhs
  51  - Removed the code parameter for now
  52  - Replaced Type by an enumeration
  53  - Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
  54  -}
  55
  56
  57 data StgInfoTable = StgInfoTable {
  58    ptrs   :: HalfWord,
  59    nptrs  :: HalfWord,
  60    tipe   :: ClosureType,
  61    srtlen :: HalfWord
  62   }
  63   deriving (Show)
  64
  65 instance Storable StgInfoTable where
  66
  67    sizeOf itbl
  68       = sum
  69         [
  70          fieldSz ptrs itbl,
  71          fieldSz nptrs itbl,
  72          sizeOf (undefined :: HalfWord),
  73          fieldSz srtlen itbl
  74         ]
  75
  76    alignment _
  77       = wORD_SIZE
  78
  79    poke a0 itbl
  80       = error "Storable StgInfoTable is read-only"
  81
  82    peek a0
  83       = runState (castPtr a0)
  84       $ do
  85            ptrs'   <- load
  86            nptrs'  <- load
  87            tipe'   <- load
  88            srtlen' <- load
  89            return
  90               StgInfoTable {
  91                  ptrs   = ptrs',
  92                  nptrs  = nptrs',
  93                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
  94                  srtlen = srtlen'
  95               }
  96
  97 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
  98 fieldSz sel x = sizeOf (sel x)
  99
 100 load :: Storable a => PtrIO a
 101 load = do addr <- advance
 102           lift (peek addr)
 103
 104 type PtrIO = State (Ptr Word8) IO
 105
 106 advance :: Storable a => PtrIO (Ptr a)
 107 advance = State adv where
 108     adv addr = case castPtr addr of { addrCast -> return
 109         (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
 110
 111 sizeOfPointee :: (Storable a) => Ptr a -> Int
 112 sizeOfPointee addr = sizeOf (typeHack addr)
 113     where typeHack = undefined :: Ptr a -> a
 114
 115 store :: Storable a => a -> PtrIO ()
 116 store x = do addr <- advance
 117              lift (poke addr x)
 118
 119 {-
 120  - Embedded StateT, also from ByteCodeItbls
 121  -}
 122
 123 newtype State s m a = State (s -> m (s, a))
 124
 125 instance Monad m => Monad (State s m) where
 126   return a      = State (\s -> return (s, a))
 127   State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
 128   fail str      = State (\_ -> fail str)
 129
 130 lift m = State (\s -> m >>= \a -> return (s, a))
 131
 132 runState :: (Monad m) => s -> State s m a -> m a
 133 runState s (State m) = m s >>= return . snd
 134
 135 {-
 136  - Data Type representing Closures
 137  -}
 138
 139
 140 data ClosureType =
 141           INVALID_OBJECT
 142         | CONSTR
 143         | CONSTR_1_0
 144         | CONSTR_0_1
 145         | CONSTR_2_0
 146         | CONSTR_1_1
 147         | CONSTR_0_2
 148         | CONSTR_STATIC
 149         | CONSTR_NOCAF_STATIC
 150         | FUN
 151         | FUN_1_0
 152         | FUN_0_1
 153         | FUN_2_0
 154         | FUN_1_1
 155         | FUN_0_2
 156         | FUN_STATIC
 157         | THUNK
 158         | THUNK_1_0
 159         | THUNK_0_1
 160         | THUNK_2_0
 161         | THUNK_1_1
 162         | THUNK_0_2
 163         | THUNK_STATIC
 164         | THUNK_SELECTOR
 165         | BCO
 166         | AP
 167         | PAP
 168         | AP_STACK
 169         | IND
 170         | IND_PERM
 171         | IND_STATIC
 172         | RET_BCO
 173         | RET_SMALL
 174         | RET_BIG
 175         | RET_DYN
 176         | RET_FUN
 177         | UPDATE_FRAME
 178         | CATCH_FRAME
 179         | UNDERFLOW_FRAME
 180         | STOP_FRAME
 181         | BLOCKING_QUEUE
 182         | BLACKHOLE
 183         | MVAR_CLEAN
 184         | MVAR_DIRTY
 185         | ARR_WORDS
 186         | MUT_ARR_PTRS_CLEAN
 187         | MUT_ARR_PTRS_DIRTY
 188         | MUT_ARR_PTRS_FROZEN0
 189         | MUT_ARR_PTRS_FROZEN
 190         | MUT_VAR_CLEAN
 191         | MUT_VAR_DIRTY
 192         | WEAK
 193         | PRIM
 194         | MUT_PRIM
 195         | TSO
 196         | STACK
 197         | TREC_CHUNK
 198         | ATOMICALLY_FRAME
 199         | CATCH_RETRY_FRAME
 200         | CATCH_STM_FRAME
 201         | WHITEHOLE
 202  deriving (Show, Eq, Enum, Ord)
 203
 204 data Closure =
 205     ConsClosure {
 206         info         :: StgInfoTable
 207         , ptrArgs    :: [Box]
 208         , dataArgs   :: [Word]
 209         , descr      :: String
 210     } |
 211     ThunkClosure {
 212         info         :: StgInfoTable
 213         , ptrArgs    :: [Box]
 214         , dataArgs   :: [Word]
 215     } |
 216     SelectorClosure {
 217         info         :: StgInfoTable
 218         , selectee   :: Box
 219     } |
 220     IndClosure {
 221         info         :: StgInfoTable
 222         , indirectee   :: Box
 223     } |
 224     APClosure {
 225         info         :: StgInfoTable
 226         , arity      :: HalfWord
 227         , n_args     :: HalfWord
 228         , fun        :: Box
 229         , payload    :: [Box]
 230     } |
 231     PAPClosure {
 232         info         :: StgInfoTable
 233         , arity      :: HalfWord
 234         , n_args     :: HalfWord
 235         , fun        :: Box
 236         , payload    :: [Box]
 237     } |
 238     BCOClosure {
 239         info         :: StgInfoTable
 240         , instrs     :: Box
 241         , literals   :: Box
 242         , bcoptrs    :: Box
 243         , arity      :: HalfWord
 244         , size       :: HalfWord
 245         , bitmap     :: Word
 246     } |
 247     ArrWordsClosure {
 248         info         :: StgInfoTable
 249         , bytes      :: Word
 250         , words      :: [Word]
 251     } |
 252     MutArrClosure {
 253         info         :: StgInfoTable
 254         , mccPtrs    :: Word
 255         , mccSize    :: Word
 256         , mccPayload :: [Box]
 257         -- Card table ignored
 258     } |
 259     FunClosure {
 260         info         :: StgInfoTable
 261         , ptrArgs    :: [Box]
 262         , dataArgs   :: [Word]
 263     } |
 264     BlockingQueueClosure {
 265         info         :: StgInfoTable
 266         , link       :: Box
 267         , blackHole  :: Box
 268         , owner      :: Box
 269         , queue      :: Box
 270     } |
 271     OtherClosure {
 272         info         :: StgInfoTable
 273         , hvalues    :: [Box]
 274         , words      :: [Word]
 275     }
 276  deriving (Show)
 277
 278 allPtrs (ConsClosure {..}) = ptrArgs
 279 allPtrs (ThunkClosure {..}) = ptrArgs
 280 allPtrs (SelectorClosure {..}) = [selectee]
 281 allPtrs (IndClosure {..}) = [indirectee]
 282 allPtrs (APClosure {..}) = fun:payload
 283 allPtrs (PAPClosure {..}) = fun:payload
 284 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
 285 allPtrs (ArrWordsClosure {..}) = []
 286 allPtrs (MutArrClosure {..}) = mccPayload
 287 allPtrs (FunClosure {..}) = ptrArgs
 288 allPtrs (OtherClosure {..}) = hvalues
 289
 290
 291
 292 #ifdef PRIM_SUPPORTS_ANY
 293 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
 294 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
 295 #else
 296 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
 297 -- accepted
 298
 299 foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
 300 foreign import prim "slurpClosurezh" slurpClosure'# :: Addr#  -> (# Addr#, ByteArray#, Array# b #)
 301
 302 -- This is a datatype that has the same layout as Ptr, so that by
 303 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
 304 data Ptr' a = Ptr' a
 305
 306 addrOf# :: Any -> Addr#
 307 addrOf# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Ptr () of Ptr addr -> addr
 308
 309 aToWord# :: Any -> Word#
 310 aToWord# a  = aToWord'# (addrOf# a)
 311 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
 312 slurpClosure# a = slurpClosure'# (addrOf# a)
 313 #endif
 314
 315 --pClosure x = do
 316 --    getClosure x >>= print
 317
 318 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
 319 getClosureRaw x =
 320     case slurpClosure# (unsafeCoerce# x) of
 321         (# iptr, dat, ptrs #) -> do
 322             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
 323                 words = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
 324                 pelems = I# (sizeofArray# ptrs)
 325                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
 326             ptrList `seq` words `seq` return (Ptr iptr, words, ptrList)
 327
 328 -- From compiler/ghci/RtClosureInspect.hs
 329 amap' :: (t -> b) -> Array Int t -> [b]
 330 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
 331     where g (I# i#) = case indexArray# arr# i# of
 332                           (# e #) -> f e
 333
 334
 335
 336 -- #include "../includes/rts/storage/ClosureTypes.h"
 337
 338 getHValueClosureData :: Box -> IO Closure
 339 getHValueClosureData b@(Box a) = getClosureData a
 340
 341 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
 342 -- compiler/ghci/DebuggerUtils.hs
 343 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO String
 344 dataConInfoPtrToNames ptr = do
 345     conDescAddress <- getConDescAddress ptr
 346     wl <- peekArray0 0 conDescAddress
 347     return $ fmap (chr . fromIntegral) wl
 348   where
 349     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
 350     getConDescAddress ptr
 351       | True = do
 352           offsetToString <- peek (ptr `plusPtr` (negate wORD_SIZE))
 353           return $ (ptr `plusPtr` stdInfoTableSizeB)
 354                     `plusPtr` (fromIntegral (offsetToString :: Word))
 355     -- This is code for !ghciTablesNextToCode:
 356     {-
 357       | otherwise = peek . intPtrToPtr
 358                       . (+ fromIntegral
 359                             stdInfoTableSizeB)
 360                         . ptrToIntPtr $ ptr
 361     -}
 362
 363     -- hmmmmmm. Is there any way to tell this?
 364     opt_SccProfilingOn = False
 365
 366     stdInfoTableSizeW :: Int
 367     -- The size of a standard info table varies with profiling/ticky etc,
 368     -- so we can't get it from Constants
 369     -- It must vary in sync with mkStdInfoTable
 370     stdInfoTableSizeW
 371       = size_fixed + size_prof
 372       where
 373         size_fixed = 2  -- layout, type
 374         size_prof | opt_SccProfilingOn = 2
 375                   | otherwise    = 0
 376
 377     stdInfoTableSizeB :: Int
 378     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
 379
 380
 381 getClosureData :: a -> IO Closure
 382 getClosureData x = do
 383     (iptr, words, ptrs) <- getClosureRaw x
 384     itbl <- peek iptr
 385     case tipe itbl of
 386         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
 387             name <- dataConInfoPtrToNames iptr
 388             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) words) name
 389
 390         t | t >= THUNK && t <= THUNK_STATIC -> do
 391             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) words)
 392
 393         t | t >= FUN && t <= FUN_STATIC -> do
 394             return $ FunClosure itbl ptrs (drop (length ptrs + 1) words)
 395
 396         AP ->
 397             return $ APClosure itbl
 398                 (fromIntegral $ words !! 2)
 399                 (fromIntegral $ shiftR (words !! 2) (wORD_SIZE_IN_BITS `div` 2))
 400                 (head ptrs) (tail ptrs)
 401
 402         PAP ->
 403             return $ PAPClosure itbl
 404                 (fromIntegral $ words !! 2)
 405                 (fromIntegral $ shiftR (words !! 2) (wORD_SIZE_IN_BITS `div` 2))
 406                 (head ptrs) (tail ptrs)
 407
 408         THUNK_SELECTOR ->
 409             return $ SelectorClosure itbl (head ptrs)
 410
 411         IND ->
 412             return $ IndClosure itbl (head ptrs)
 413         IND_STATIC ->
 414             return $ IndClosure itbl (head ptrs)
 415         BLACKHOLE ->
 416             return $ IndClosure itbl (head ptrs)
 417
 418         BCO ->
 419             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
 420                 (fromIntegral $ words !! 4)
 421                 (fromIntegral $ shiftR (words !! 4) (wORD_SIZE_IN_BITS `div` 2))
 422                 (words !! 5)
 423
 424         ARR_WORDS ->
 425             return $ ArrWordsClosure itbl (words !! 1) (drop 2 words)
 426         MUT_ARR_PTRS_FROZEN ->
 427             return $ MutArrClosure itbl (words !! 2) (words !! 3) ptrs
 428
 429         BLOCKING_QUEUE ->
 430           return $ OtherClosure itbl ptrs words
 431         --    return $ BlockingQueueClosure itbl
 432         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
 433
 434         --  return $ OtherClosure itbl ptrs words
 435         x -> error $ "getClosureData: Cannot handle closure type " ++ show x