src/GHC/HeapView.hs

   1 {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-}
   2 {-|
   3 Module      :  GHC.HeapView
   4 Copyright   :  (c) 2012 Joachim Breitner
   5 License     :  BSD3
   6 Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>
   7
   8 With this module, you can investigate the heap representation of Haskell
   9 values, i.e. to investigate sharing and lazy evaluation.
  10 -}
  11
  12
  13 module GHC.HeapView (
  14     -- * Heap data types
  15     GenClosure(..),
  16     Closure,
  17     allPtrs,
  18     ClosureType(..),
  19     StgInfoTable(..),
  20     HalfWord,
  21     -- * Reading from the heap
  22     getClosureData,
  23     getBoxedClosureData,
  24     getClosureRaw,
  25     -- * Pretty printing
  26     ppClosure,
  27     -- * Heap maps
  28     -- $heapmap
  29     HeapTree(..),
  30     buildHeapTree,
  31     ppHeapTree,
  32     HeapGraphEntry(..),
  33     HeapGraphIndex,
  34     HeapGraph(..),
  35     lookupHeapGraph,
  36     heapGraphRoot,
  37     buildHeapGraph,
  38     multiBuildHeapGraph,
  39     addHeapGraph,
  40     annotateHeapGraph,
  41     updateHeapGraph,
  42     ppHeapGraph,
  43     -- * Boxes
  44     Box(..),
  45     asBox,
  46     areBoxesEqual,
  47     -- * Disassembler
  48     disassembleBCO,
  49     )
  50     where
  51
  52 import GHC.Exts         ( Any,
  53                           Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,
  54                           ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
  55                           unsafeCoerce# )
  56
  57 import GHC.Arr          (Array(..))
  58
  59 import GHC.Constants    ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
  60
  61 import Foreign          hiding ( unsafePerformIO, void )
  62 import Numeric          ( showHex )
  63 import Data.Char
  64 import Data.List
  65 import Data.Maybe       ( catMaybes )
  66 import Data.Monoid      ( Monoid, (<>), mempty )
  67 import Data.Functor
  68 import Data.Function
  69 import Data.Foldable    ( Foldable )
  70 import qualified Data.Foldable as F
  71 import Data.Traversable ( Traversable )
  72 import qualified Data.Traversable as T
  73 import qualified Data.IntMap as M
  74 import Control.Monad
  75 import Control.Monad.Trans.State
  76 import Control.Monad.Trans.Class
  77 import Control.Monad.IO.Class
  78 import Control.Monad.Trans.Writer.Strict
  79 import Control.Exception.Base (evaluate)
  80
  81 import GHC.Disassembler
  82
  83 #include "ghcautoconf.h"
  84
  85 -- | An arbitrarily Haskell value in a safe Box. The point is that even
  86 -- unevaluated thunks can safely be moved around inside the Box, and when
  87 -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
  88 -- to evalue the argument.
  89 data Box = Box Any
  90
  91 #if SIZEOF_VOID_P == 8
  92 type HalfWord = Word32
  93 #else
  94 type HalfWord = Word16
  95 #endif
  96
  97 instance Show Box where
  98 -- From libraries/base/GHC/Ptr.lhs
  99    showsPrec _ (Box a) rs =
 100     -- unsafePerformIO (print "↓" >> pClosure a) `seq`
 101     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
 102      where
 103        ptr  = W# (aToWord# a)
 104        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
 105        addr = ptr - tag
 106         -- want 0s prefixed to pad it out to a fixed length.
 107        pad_out ls =
 108           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
 109
 110 -- | Boxes can be compared, but this is not pure, as different heap objects can,
 111 -- after garbage collection, become the same object.
 112 areBoxesEqual :: Box -> Box -> IO Bool
 113 areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
 114     0# -> return False
 115     _  -> return True
 116
 117
 118 {-|
 119   This takes an arbitrary value and puts it into a box. Note that calls like
 120
 121   > asBox (head list)
 122
 123   will put the thunk \"head list\" into the box, /not/ the element at the head
 124   of the list. For that, use careful case expressions:
 125
 126   > case list of x:_ -> asBox x
 127 -}
 128 asBox :: a -> Box
 129 asBox x = Box (unsafeCoerce# x)
 130
 131 {-
 132    StgInfoTable parsing derived from ByteCodeItbls.lhs
 133    Removed the code parameter for now
 134    Replaced Type by an enumeration
 135    Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
 136  -}
 137
 138 {-| This is a somewhat faithful representation of an info table. See
 139    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>
 140    for more details on this data structure. Note that the 'Storable' instance
 141    provided here does _not_ support writing.
 142  -}
 143 data StgInfoTable = StgInfoTable {
 144    ptrs   :: HalfWord,
 145    nptrs  :: HalfWord,
 146    tipe   :: ClosureType,
 147    srtlen :: HalfWord
 148   }
 149   deriving (Show)
 150
 151 instance Storable StgInfoTable where
 152
 153    sizeOf itbl
 154       = sum
 155         [
 156          fieldSz ptrs itbl,
 157          fieldSz nptrs itbl,
 158          sizeOf (undefined :: HalfWord),
 159          fieldSz srtlen itbl
 160         ]
 161
 162    alignment _
 163       = wORD_SIZE
 164
 165    poke _a0 _itbl
 166       = error "Storable StgInfoTable is read-only"
 167
 168    peek a0
 169       = flip (evalStateT) (castPtr a0)
 170       $ do
 171            ptrs'   <- load
 172            nptrs'  <- load
 173            tipe'   <- load
 174            srtlen' <- load
 175            return
 176               StgInfoTable {
 177                  ptrs   = ptrs',
 178                  nptrs  = nptrs',
 179                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
 180                  srtlen = srtlen'
 181               }
 182
 183 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
 184 fieldSz sel x = sizeOf (sel x)
 185
 186 load :: Storable a => PtrIO a
 187 load = do addr <- advance
 188           lift (peek addr)
 189
 190 type PtrIO = StateT (Ptr Word8) IO
 191
 192 advance :: Storable a => PtrIO (Ptr a)
 193 advance = StateT adv where
 194     adv addr = case castPtr addr of { addrCast -> return
 195         (addrCast, addr `plusPtr` sizeOfPointee addrCast) }
 196
 197 sizeOfPointee :: (Storable a) => Ptr a -> Int
 198 sizeOfPointee addr = sizeOf (typeHack addr)
 199     where typeHack = undefined :: Ptr a -> a
 200
 201 {-
 202    Data Type representing Closures
 203  -}
 204
 205
 206 {-| A closure type enumeration, in order matching the actual value on the heap.
 207    Needs to be synchronized with
 208    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>
 209  -}
 210 data ClosureType =
 211           INVALID_OBJECT
 212         | CONSTR
 213         | CONSTR_1_0
 214         | CONSTR_0_1
 215         | CONSTR_2_0
 216         | CONSTR_1_1
 217         | CONSTR_0_2
 218         | CONSTR_STATIC
 219         | CONSTR_NOCAF_STATIC
 220         | FUN
 221         | FUN_1_0
 222         | FUN_0_1
 223         | FUN_2_0
 224         | FUN_1_1
 225         | FUN_0_2
 226         | FUN_STATIC
 227         | THUNK
 228         | THUNK_1_0
 229         | THUNK_0_1
 230         | THUNK_2_0
 231         | THUNK_1_1
 232         | THUNK_0_2
 233         | THUNK_STATIC
 234         | THUNK_SELECTOR
 235         | BCO
 236         | AP
 237         | PAP
 238         | AP_STACK
 239         | IND
 240         | IND_PERM
 241         | IND_STATIC
 242         | RET_BCO
 243         | RET_SMALL
 244         | RET_BIG
 245         | RET_DYN
 246         | RET_FUN
 247         | UPDATE_FRAME
 248         | CATCH_FRAME
 249         | UNDERFLOW_FRAME
 250         | STOP_FRAME
 251         | BLOCKING_QUEUE
 252         | BLACKHOLE
 253         | MVAR_CLEAN
 254         | MVAR_DIRTY
 255         | ARR_WORDS
 256         | MUT_ARR_PTRS_CLEAN
 257         | MUT_ARR_PTRS_DIRTY
 258         | MUT_ARR_PTRS_FROZEN0
 259         | MUT_ARR_PTRS_FROZEN
 260         | MUT_VAR_CLEAN
 261         | MUT_VAR_DIRTY
 262         | WEAK
 263         | PRIM
 264         | MUT_PRIM
 265         | TSO
 266         | STACK
 267         | TREC_CHUNK
 268         | ATOMICALLY_FRAME
 269         | CATCH_RETRY_FRAME
 270         | CATCH_STM_FRAME
 271         | WHITEHOLE
 272  deriving (Show, Eq, Enum, Ord)
 273
 274 {-| This is the main data type of this module, representing a Haskell value on
 275   the heap. This reflects
 276   <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
 277
 278   The data type is parametrized by the type to store references in, which
 279   is usually a 'Box' with appropriate type synonym 'Closure'.
 280  -}
 281 data GenClosure b =
 282     ConsClosure {
 283         info         :: StgInfoTable
 284         , ptrArgs    :: [b]
 285         , dataArgs   :: [Word]
 286         , pkg        :: String
 287         , modl       :: String
 288         , name       :: String
 289     } |
 290     ThunkClosure {
 291         info         :: StgInfoTable
 292         , ptrArgs    :: [b]
 293         , dataArgs   :: [Word]
 294     } |
 295     SelectorClosure {
 296         info         :: StgInfoTable
 297         , selectee   :: b
 298     } |
 299     IndClosure {
 300         info         :: StgInfoTable
 301         , indirectee   :: b
 302     } |
 303     BlackholeClosure {
 304         info         :: StgInfoTable
 305         , indirectee   :: b
 306     } |
 307     -- In GHCi, if Linker.h would allow a reverse looup, we could for exported
 308     -- functions fun actually find the name here.
 309     -- At least the other direction works via "lookupSymbol
 310     -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
 311     APClosure {
 312         info         :: StgInfoTable
 313         , arity      :: HalfWord
 314         , n_args     :: HalfWord
 315         , fun        :: b
 316         , payload    :: [b]
 317     } |
 318     PAPClosure {
 319         info         :: StgInfoTable
 320         , arity      :: HalfWord
 321         , n_args     :: HalfWord
 322         , fun        :: b
 323         , payload    :: [b]
 324     } |
 325     APStackClosure {
 326         info         :: StgInfoTable
 327         , fun        :: b
 328         , payload    :: [b]
 329     } |
 330     BCOClosure {
 331         info         :: StgInfoTable
 332         , instrs     :: b
 333         , literals   :: b
 334         , bcoptrs    :: b
 335         , arity      :: HalfWord
 336         , size       :: HalfWord
 337         , bitmap     :: Word
 338     } |
 339     ArrWordsClosure {
 340         info         :: StgInfoTable
 341         , bytes      :: Word
 342         , arrWords   :: [Word]
 343     } |
 344     MutArrClosure {
 345         info         :: StgInfoTable
 346         , mccPtrs    :: Word
 347         , mccSize    :: Word
 348         , mccPayload :: [b]
 349         -- Card table ignored
 350     } |
 351     MutVarClosure {
 352         info         :: StgInfoTable
 353         , var        :: b
 354     } |
 355     MVarClosure {
 356         info         :: StgInfoTable
 357         , queueHead  :: b
 358         , queueTail  :: b
 359         , value      :: b
 360     } |
 361     FunClosure {
 362         info         :: StgInfoTable
 363         , ptrArgs    :: [b]
 364         , dataArgs   :: [Word]
 365     } |
 366     BlockingQueueClosure {
 367         info         :: StgInfoTable
 368         , link       :: b
 369         , blackHole  :: b
 370         , owner      :: b
 371         , queue      :: b
 372     } |
 373     OtherClosure {
 374         info         :: StgInfoTable
 375         , hvalues    :: [b]
 376         , rawWords   :: [Word]
 377     } |
 378     UnsupportedClosure {
 379         info         :: StgInfoTable
 380     }
 381  deriving (Show, Functor, Foldable, Traversable)
 382
 383
 384 type Closure = GenClosure Box
 385
 386 -- | For generic code, this function returns all referenced closures.
 387 allPtrs :: GenClosure b -> [b]
 388 allPtrs (ConsClosure {..}) = ptrArgs
 389 allPtrs (ThunkClosure {..}) = ptrArgs
 390 allPtrs (SelectorClosure {..}) = [selectee]
 391 allPtrs (IndClosure {..}) = [indirectee]
 392 allPtrs (BlackholeClosure {..}) = [indirectee]
 393 allPtrs (APClosure {..}) = fun:payload
 394 allPtrs (PAPClosure {..}) = fun:payload
 395 allPtrs (APStackClosure {..}) = fun:payload
 396 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
 397 allPtrs (ArrWordsClosure {..}) = []
 398 allPtrs (MutArrClosure {..}) = mccPayload
 399 allPtrs (MutVarClosure {..}) = [var]
 400 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
 401 allPtrs (FunClosure {..}) = ptrArgs
 402 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
 403 allPtrs (OtherClosure {..}) = hvalues
 404 allPtrs (UnsupportedClosure {..}) = []
 405
 406
 407 #ifdef PRIM_SUPPORTS_ANY
 408 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
 409 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
 410 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
 411 #else
 412 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
 413 -- accepted
 414
 415 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
 416 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
 417
 418 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
 419
 420 -- This is a datatype that has the same layout as Ptr, so that by
 421 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
 422 data Ptr' a = Ptr' a
 423
 424 aToWord# :: Any -> Word#
 425 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
 426
 427 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
 428 slurpClosure# a = slurpClosure'# (aToWord# a)
 429
 430 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
 431 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
 432 #endif
 433
 434 --pClosure x = do
 435 --    getClosure x >>= print
 436
 437 -- | This returns the raw representation of the given argument. The second
 438 -- component of the triple are the words on the heap, and the third component
 439 -- are those words that are actually pointers. Once back in Haskell word, the
 440 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
 441 -- 'Box' will still point to the correct value.
 442 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
 443 getClosureRaw x =
 444     case slurpClosure# (unsafeCoerce# x) of
 445         (# iptr, dat, ptrs #) -> do
 446             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
 447                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
 448                 pelems = I# (sizeofArray# ptrs)
 449                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
 450             -- This is just for good measure, and seems to be not important.
 451             mapM_ evaluate ptrList
 452             -- This seems to be required to avoid crashes as well
 453             void $ evaluate nelems
 454             -- The following deep evaluation is crucial to avoid crashes (but why)?
 455             mapM_ evaluate rawWords
 456             return (Ptr iptr, rawWords, ptrList)
 457
 458 -- From compiler/ghci/RtClosureInspect.hs
 459 amap' :: (t -> b) -> Array Int t -> [b]
 460 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
 461     where g (I# i#) = case indexArray# arr# i# of
 462                           (# e #) -> f e
 463
 464 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
 465 -- compiler/ghci/DebuggerUtils.hs
 466 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
 467 dataConInfoPtrToNames ptr = do
 468     conDescAddress <- getConDescAddress ptr
 469     wl <- peekArray0 0 conDescAddress
 470     let (pkg, modl, name) = parse wl
 471     return (b2s pkg, b2s modl, b2s name)
 472   where
 473     b2s :: [Word8] -> String
 474     b2s = fmap (chr . fromIntegral)
 475
 476     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
 477     getConDescAddress ptr'
 478       | True = do
 479           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
 480           return $ (ptr' `plusPtr` stdInfoTableSizeB)
 481                     `plusPtr` (fromIntegral (offsetToString :: Word))
 482     -- This is code for !ghciTablesNextToCode:
 483     {-
 484       | otherwise = peek . intPtrToPtr
 485                       . (+ fromIntegral
 486                             stdInfoTableSizeB)
 487                         . ptrToIntPtr $ ptr
 488     -}
 489
 490     -- hmmmmmm. Is there any way to tell this?
 491     opt_SccProfilingOn = False
 492
 493     stdInfoTableSizeW :: Int
 494     -- The size of a standard info table varies with profiling/ticky etc,
 495     -- so we can't get it from Constants
 496     -- It must vary in sync with mkStdInfoTable
 497     stdInfoTableSizeW
 498       = size_fixed + size_prof
 499       where
 500         size_fixed = 2  -- layout, type
 501         size_prof | opt_SccProfilingOn = 2
 502                   | otherwise    = 0
 503
 504     stdInfoTableSizeB :: Int
 505     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
 506
 507 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
 508 parse :: [Word8] -> ([Word8], [Word8], [Word8])
 509 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
 510                 --then (error . concat)
 511                 --        ["getConDescAddress:parse:"
 512                 --        ,"(not . all (>0) . fmap le"
 513                 --        ,"ngth $ [pkg,modl,occ]"]
 514                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
 515                 else (pkg, modl, occ)
 516 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
 517   where
 518         (pkg, rest1) = break (== fromIntegral (ord ':')) input
 519         (modl, occ)
 520             = (concat $ intersperse [dot] $ reverse modWords, occWord)
 521             where
 522             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
 523                                     --then error "getConDescAddress:parse:length rest1 < 1"
 524                                     then parseModOcc [] []
 525                                     else parseModOcc [] (tail rest1)
 526         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
 527         dot = fromIntegral (ord '.')
 528         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
 529         parseModOcc acc str
 530             = case break (== dot) str of
 531                 (top, []) -> (acc, top)
 532                 (top, _:bot) -> parseModOcc (top : acc) bot
 533
 534
 535 -- | This function returns parsed heap representation of the argument _at this
 536 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
 537 -- Beware when passing something to this function, the same caveats as for
 538 -- 'asBox' apply.
 539 getClosureData :: a -> IO Closure
 540 getClosureData x = do
 541     (iptr, wds, ptrs) <- getClosureRaw x
 542     itbl <- peek iptr
 543     case tipe itbl of
 544         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
 545             (pkg, modl, name) <- dataConInfoPtrToNames iptr
 546             if modl == "ByteCodeInstr" && name == "BreakInfo"
 547               then return $ UnsupportedClosure itbl
 548               else return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
 549
 550         t | t >= THUNK && t <= THUNK_STATIC -> do
 551             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
 552
 553         t | t >= FUN && t <= FUN_STATIC -> do
 554             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
 555
 556         AP ->
 557             return $ APClosure itbl
 558                 (fromIntegral $ wds !! 2)
 559                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
 560                 (head ptrs) (tail ptrs)
 561
 562         PAP ->
 563             return $ PAPClosure itbl
 564                 (fromIntegral $ wds !! 2)
 565                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
 566                 (head ptrs) (tail ptrs)
 567
 568         AP_STACK ->
 569             return $ APStackClosure itbl (head ptrs) (tail ptrs)
 570
 571         THUNK_SELECTOR ->
 572             return $ SelectorClosure itbl (head ptrs)
 573
 574         IND ->
 575             return $ IndClosure itbl (head ptrs)
 576         IND_STATIC ->
 577             return $ IndClosure itbl (head ptrs)
 578         BLACKHOLE ->
 579             return $ BlackholeClosure itbl (head ptrs)
 580
 581         BCO ->
 582             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
 583                 (fromIntegral $ wds !! 4)
 584                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
 585                 (wds !! 5)
 586
 587         ARR_WORDS ->
 588             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
 589
 590         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
 591             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
 592
 593         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
 594             return $ MutVarClosure itbl (head ptrs)
 595
 596         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
 597             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
 598
 599         BLOCKING_QUEUE ->
 600             return $ OtherClosure itbl ptrs wds
 601         --    return $ BlockingQueueClosure itbl
 602         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
 603
 604         --  return $ OtherClosure itbl ptrs wds
 605         --
 606         _ ->
 607             return $ UnsupportedClosure itbl
 608
 609 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
 610 getBoxedClosureData :: Box -> IO Closure
 611 getBoxedClosureData (Box a) = getClosureData a
 612
 613
 614 isChar :: GenClosure b -> Maybe Char
 615 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
 616 isChar _ = Nothing
 617
 618 isCons :: GenClosure b -> Maybe (b, b)
 619 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
 620 isCons _ = Nothing
 621
 622 isTup :: GenClosure b -> Maybe [b]
 623 isTup (ConsClosure { dataArgs = [], ..}) =
 624     if length name >= 3 &&
 625        head name == '(' && last name == ')' &&
 626        all (==',') (tail (init name))
 627     then Just ptrArgs else Nothing
 628 isTup _ = Nothing
 629
 630
 631 isNil :: GenClosure b -> Bool
 632 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
 633 isNil _ = False
 634
 635 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
 636 -- It assumes that for the included boxes, you already replaced them by Strings
 637 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
 638 --
 639 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
 640 ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
 641 ppClosure showBox prec c = case c of
 642     _ | Just ch <- isChar c -> app $
 643         ["C#", show ch]
 644     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
 645         showBox 5 h ++ " : " ++ showBox 4 t
 646     _ | Just vs <- isTup c ->
 647         "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"
 648     ConsClosure {..} -> app $
 649         name : map (showBox 10) ptrArgs ++ map show dataArgs
 650     ThunkClosure {..} -> app $
 651         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
 652     SelectorClosure {..} -> app
 653         ["_sel", showBox 10 selectee]
 654     IndClosure {..} -> app
 655         ["_ind", showBox 10 indirectee]
 656     BlackholeClosure {..} -> app
 657         ["_bh",  showBox 10 indirectee]
 658     APClosure {..} -> app $ map (showBox 10) $
 659         fun : payload
 660     PAPClosure {..} -> app $ map (showBox 10) $
 661         fun : payload
 662     APStackClosure {..} -> app $ map (showBox 10) $
 663         fun : payload
 664     BCOClosure {..} -> app
 665         ["_bco"]
 666     ArrWordsClosure {..} -> app
 667         ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ]
 668     MutArrClosure {..} -> app
 669         ["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
 670     MutVarClosure {..} -> app $
 671         ["_mutVar", (showBox 10) var]
 672     MVarClosure {..} -> app $
 673         ["MVar", (showBox 10) value]
 674     FunClosure {..} ->
 675         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
 676     BlockingQueueClosure {..} ->
 677         "_blockingQueue"
 678     OtherClosure {..} ->
 679         "_other"
 680     UnsupportedClosure {..} ->
 681         "_unsupported"
 682   where
 683     app [a] = a  ++ "()"
 684     app xs = addBraces (10 <= prec) (intercalate " " xs)
 685
 686     shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs
 687
 688 {- $heapmap
 689
 690    For more global views of the heap, you can use heap maps. These come in
 691    variations, either a trees or as graphs, depending on
 692    whether you want to detect cycles and sharing or not.
 693
 694    The entries of a 'HeapGraph' can be annotated with arbitrary values. Most
 695    operations expect this to be in the 'Monoid' class: They use 'mempty' to
 696    annotate closures added because the passed values reference them, and they
 697    use 'mappend' to combine the annotations when two values conincide, e.g.
 698    during 'updateHeapGraph'.
 699 -}
 700
 701 -- | Heap maps as tree, i.e. no sharing, no cycles.
 702 data HeapTree = HeapTree Box (GenClosure HeapTree) | EndOfHeapTree
 703
 704 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
 705 heapTreeClosure (HeapTree _ c) = Just c
 706 heapTreeClosure EndOfHeapTree = Nothing
 707
 708 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
 709 -- that prevents it from running ad infinitum for cyclic or infinite
 710 -- structures.
 711 buildHeapTree :: Int -> Box -> IO HeapTree
 712 buildHeapTree 0 _ = do
 713     return $ EndOfHeapTree
 714 buildHeapTree n b = do
 715     c <- getBoxedClosureData b
 716     c' <- T.mapM (buildHeapTree (n-1)) c
 717     return $ HeapTree b c'
 718
 719 -- | Pretty-Printing a heap Tree
 720 --
 721 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
 722 -- unevaluated expression depending on the command line argument.
 723 --
 724 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
 725 ppHeapTree :: HeapTree -> String
 726 ppHeapTree = go 0
 727   where
 728     go _ EndOfHeapTree = "..."
 729     go prec t@(HeapTree _ c')
 730         | Just s <- isHeapTreeString t = show s
 731         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
 732         | Just bc <- disassembleBCO heapTreeClosure c'
 733                                        = app ("_bco" : map (go 10) (concatMap F.toList bc))
 734         | otherwise                    = ppClosure go prec c'
 735       where
 736         app [a] = a ++ "()"
 737         app xs = addBraces (10 <= prec) (intercalate " " xs)
 738
 739 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
 740 isHeapTreeList tree = do
 741     c <- heapTreeClosure tree
 742     if isNil c
 743       then return []
 744       else do
 745         (h,t) <- isCons c
 746         t' <- isHeapTreeList t
 747         return $ (:) h t'
 748
 749 isHeapTreeString :: HeapTree -> Maybe String
 750 isHeapTreeString t = do
 751     list <- isHeapTreeList t
 752     -- We do not want to print empty lists as "" as we do not know that they
 753     -- are really strings.
 754     if (null list)
 755         then Nothing
 756         else mapM (isChar <=< heapTreeClosure) list
 757
 758 -- | For heap graphs, i.e. data structures that also represent sharing and
 759 -- cyclic structures, these are the entries. If the referenced value is
 760 -- @Nothing@, then we do not have that value in the map, most likely due to
 761 -- exceeding the recursion bound passed to 'buildHeapGraph'.
 762 --
 763 -- Besides a pointer to the stored value and the closure representation we
 764 -- also keep track of whether the value was still alive at the last update of the
 765 -- heap graph. In addition we have a slot for arbitrary data, for the user's convenience.
 766 data HeapGraphEntry a = HeapGraphEntry {
 767         hgeBox :: Box,
 768         hgeClosure :: GenClosure (Maybe HeapGraphIndex),
 769         hgeLive :: Bool,
 770         hgeData :: a}
 771     deriving (Show, Functor)
 772 type HeapGraphIndex = Int
 773
 774 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
 775 -- as the internal representation may change. Nevertheless, we export it here:
 776 -- Sometimes the user knows better what he needs than we do.
 777 newtype HeapGraph a = HeapGraph (M.IntMap (HeapGraphEntry a))
 778     deriving (Show)
 779
 780 lookupHeapGraph :: HeapGraphIndex -> (HeapGraph a) -> Maybe (HeapGraphEntry a)
 781 lookupHeapGraph i (HeapGraph m) = M.lookup i m
 782
 783 heapGraphRoot :: HeapGraphIndex
 784 heapGraphRoot = 0
 785
 786 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
 787 -- than the given limit. The initial value has index 'heapGraphRoot'.
 788 buildHeapGraph
 789    :: Monoid a
 790    => Int -- ^ Search limit
 791    -> a -- ^ Data value for the root
 792    -> Box -- ^ The value to start with
 793    -> IO (HeapGraph a)
 794 buildHeapGraph limit rootD initialBox =
 795     fst <$> multiBuildHeapGraph limit [(rootD, initialBox)]
 796
 797 -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
 798 --   further than the given limit.
 799 --
 800 --   Returns the 'HeapGraph' and the indices of initial values. The arbitrary
 801 --   type @a@ can be used to make the connection between the input and the
 802 --   resulting list of indices, and to store additional data.
 803 multiBuildHeapGraph
 804     :: Monoid a
 805     => Int -- ^ Search limit
 806     -> [(a, Box)] -- ^ Starting values with associated data entry
 807     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
 808 multiBuildHeapGraph limit = generalBuildHeapGraph limit (HeapGraph M.empty)
 809
 810 -- | Adds an entry to an existing 'HeapGraph'.
 811 --
 812 --   Returns the updated 'HeapGraph' and the index of the added value.
 813 addHeapGraph
 814     :: Monoid a
 815     => Int -- ^ Search limit
 816     -> a -- ^ Data to be stored with the added value
 817     -> Box -- ^ Value to add to the graph
 818     -> HeapGraph a -- ^ Graph to extend
 819     -> IO (HeapGraphIndex, HeapGraph a)
 820 addHeapGraph limit d box hg = do
 821     (hg', [(_,i)]) <- generalBuildHeapGraph limit hg [(d,box)]
 822     return (i, hg')
 823
 824 -- | Adds the given annotation to the entry at the given index, using the
 825 -- 'mappend' operation of its 'Monoid' instance.
 826 annotateHeapGraph :: Monoid a => a -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
 827 annotateHeapGraph d i (HeapGraph hg) = HeapGraph $ M.update go i hg
 828   where
 829     go hge = Just $ hge { hgeData = hgeData hge <> d }
 830
 831 generalBuildHeapGraph
 832     :: Monoid a
 833     => Int
 834     -> HeapGraph a
 835     -> [(a,Box)]
 836     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
 837 generalBuildHeapGraph limit _ _ | limit <= 0 = error "buildHeapGraph: limit has to be positive"
 838 generalBuildHeapGraph limit (HeapGraph hg) addBoxes = do
 839     -- First collect all boxes from the existing heap graph
 840     let boxList = [ (hgeBox hge, i) | (i, hge) <- M.toList hg ]
 841         indices | M.null hg = [0..]
 842                 | otherwise = [1 + fst (M.findMax hg)..]
 843
 844         initialState = (boxList, indices, [])
 845     -- It is ok to use the Monoid (IntMap a) instance here, because
 846     -- we will, besides the first time, use 'tell' only to add singletons not
 847     -- already there
 848     (is, hg') <- runWriterT (evalStateT run initialState)
 849     -- Now add the annotations of the root values
 850     let hg'' = foldl' (flip (uncurry annotateHeapGraph)) (HeapGraph hg') is
 851     return (hg'', is)
 852   where
 853     run = do
 854         lift $ tell hg -- Start with the initial map
 855         forM addBoxes $ \(d, b) -> do
 856             -- Cannot fail, as limit is not zero here
 857             Just i <- add limit b
 858             return (d, i)
 859
 860     add 0  _ = return Nothing
 861     add n b = do
 862         -- If the box is in the map, return the index
 863         (existing,_,_) <- get
 864         mbI <- liftIO $ findM (areBoxesEqual b . fst) existing
 865         case mbI of
 866             Just (_,i) -> return $ Just i
 867             Nothing -> do
 868                 -- Otherwise, allocate a new index
 869                 i <- nextI
 870                 -- And register it
 871                 modify (\(x,y,z) -> ((b,i):x, y, z))
 872                 -- Look up the closure
 873                 c <- liftIO $ getBoxedClosureData b
 874                 -- Find indicies for all boxes contained in the map
 875                 c' <- T.mapM (add (n-1)) c
 876                 -- Add add the resulting closure to the map
 877                 lift $ tell (M.singleton i (HeapGraphEntry b c' True mempty))
 878                 return $ Just i
 879     nextI = do
 880         i <- gets (head . (\(_,b,_) -> b))
 881         modify (\(a,b,c) -> (a, tail b, c))
 882         return i
 883
 884 -- | This function updates a heap graph to reflect the current state of
 885 -- closures on the heap, conforming to the following specification.
 886 --
 887 --  * Every entry whose value has been garbage collected by now is marked as
 888 --    dead by setting 'hgeLive' to @False@
 889 --  * Every entry whose value is still live gets the 'hgeClosure' field updated
 890 --    and newly referenced closures are, up to the given depth, added to the graph.
 891 --  * A map mapping previous indicies to the corresponding new indicies is returned as well.
 892 --  * The closure at 'heapGraphRoot' stays at 'heapGraphRoot'
 893 updateHeapGraph :: Monoid a => Int -> HeapGraph a -> IO (HeapGraph a, HeapGraphIndex -> HeapGraphIndex)
 894 updateHeapGraph limit (HeapGraph startHG) = do
 895     (hg', indexMap) <- runWriterT $ foldM go (HeapGraph M.empty) (M.toList startHG)
 896     return (hg', (M.!) indexMap)
 897   where
 898     go hg (i, hge) = do
 899         (j, hg') <- liftIO $ addHeapGraph limit (hgeData hge) (hgeBox hge) hg
 900         tell (M.singleton i j)
 901         return hg'
 902
 903 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
 904 -- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
 905 --
 906 -- >let x1 = "Ki"
 907 -- >    x6 = C# 'H' : C# 'o' : x6
 908 -- >in (x1,x1,x6)
 909 ppHeapGraph :: HeapGraph a -> String
 910 ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
 911   where
 912     -- All variables occuring more than once
 913     bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot]
 914
 915     letWrapper =
 916         if null bindings
 917         then ""
 918         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin "
 919
 920     bindingLetter i = case hgeClosure (iToE i) of
 921         ThunkClosure {..} -> 't'
 922         SelectorClosure {..} -> 't'
 923         APClosure {..} -> 't'
 924         PAPClosure {..} -> 'f'
 925         BCOClosure {..} -> 't'
 926         FunClosure {..} -> 'f'
 927         _ -> 'x'
 928
 929     ppBindingMap = M.fromList $
 930         concat $
 931         map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $
 932         groupBy ((==) `on` snd) $
 933         sortBy (compare `on` snd)
 934         [ (i, bindingLetter i) | i <- bindings ]
 935
 936     ppVar i = ppBindingMap M.! i
 937     ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)
 938
 939     ppEntry prec hge
 940         | Just s <- isString hge = show s
 941         | Just l <- isList hge   = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
 942         | Just bc <- disassembleBCO (fmap (hgeClosure . iToE)) (hgeClosure hge)
 943                                        = app ("_bco" : map (ppRef 10) (concatMap F.toList bc))
 944         | otherwise = ppClosure ppRef prec (hgeClosure hge)
 945       where
 946         app [a] = a  ++ "()"
 947         app xs = addBraces (10 <= prec) (intercalate " " xs)
 948
 949     ppRef _ Nothing = "..."
 950     ppRef prec (Just i) | i `elem` bindings = ppVar i
 951                         | otherwise = ppEntry prec (iToE i)
 952     iToE i = m M.! i
 953
 954     iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
 955
 956     isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
 957     isList hge =
 958         if isNil (hgeClosure hge)
 959           then return []
 960           else do
 961             (h,t) <- isCons (hgeClosure hge)
 962             ti <- t
 963             e <- iToUnboundE ti
 964             t' <- isList e
 965             return $ (:) h t'
 966
 967     isString :: HeapGraphEntry a -> Maybe String
 968     isString e = do
 969         list <- isList e
 970         -- We do not want to print empty lists as "" as we do not know that they
 971         -- are really strings.
 972         if (null list)
 973             then Nothing
 974             else mapM (isChar . hgeClosure <=< iToUnboundE <=< id) list
 975
 976
 977 -- | In the given HeapMap, list all indices that are used more than once. The
 978 -- second parameter adds external references, commonly @[heapGraphRoot]@.
 979 boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
 980 boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $
 981      roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m)
 982
 983 -- | This function integrates the disassembler in "GHC.Disassembler". The first
 984 -- argument should a function that dereferences the pointer in the closure to a
 985 -- closure.
 986 --
 987 -- If any of these return 'Nothing', then 'disassembleBCO' returns Nothing
 988 disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
 989 disassembleBCO deref (BCOClosure {..}) = do
 990     opsC <- deref instrs
 991     litsC <- deref literals
 992     ptrsC  <- deref bcoptrs
 993     return $ disassemble (mccPayload ptrsC) (arrWords litsC) (toBytes (bytes opsC) (arrWords opsC))
 994 disassembleBCO _ _ = Nothing
 995
 996 -- Utilities
 997
 998 findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
 999 findM _p [] = return Nothing
1000 findM p (x:xs) = do
1001     b <- p x
1002     if b then return (Just x) else findM p xs
1003
1004 addBraces :: Bool -> String -> String
1005 addBraces True t = "(" ++ t ++ ")"
1006 addBraces False t = t
1007
1008 braceize :: [String] -> String
1009 braceize [] = ""
1010 braceize xs = "{" ++ intercalate "," xs ++ "}"