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 )
  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             -- The following deep evaluation is crucial to avoid crashes (but why)?
 453             mapM_ evaluate rawWords
 454             return (Ptr iptr, rawWords, ptrList)
 455
 456 -- From compiler/ghci/RtClosureInspect.hs
 457 amap' :: (t -> b) -> Array Int t -> [b]
 458 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
 459     where g (I# i#) = case indexArray# arr# i# of
 460                           (# e #) -> f e
 461
 462 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
 463 -- compiler/ghci/DebuggerUtils.hs
 464 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
 465 dataConInfoPtrToNames ptr = do
 466     conDescAddress <- getConDescAddress ptr
 467     wl <- peekArray0 0 conDescAddress
 468     let (pkg, modl, name) = parse wl
 469     return (b2s pkg, b2s modl, b2s name)
 470   where
 471     b2s :: [Word8] -> String
 472     b2s = fmap (chr . fromIntegral)
 473
 474     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
 475     getConDescAddress ptr'
 476       | True = do
 477           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
 478           return $ (ptr' `plusPtr` stdInfoTableSizeB)
 479                     `plusPtr` (fromIntegral (offsetToString :: Word))
 480     -- This is code for !ghciTablesNextToCode:
 481     {-
 482       | otherwise = peek . intPtrToPtr
 483                       . (+ fromIntegral
 484                             stdInfoTableSizeB)
 485                         . ptrToIntPtr $ ptr
 486     -}
 487
 488     -- hmmmmmm. Is there any way to tell this?
 489     opt_SccProfilingOn = False
 490
 491     stdInfoTableSizeW :: Int
 492     -- The size of a standard info table varies with profiling/ticky etc,
 493     -- so we can't get it from Constants
 494     -- It must vary in sync with mkStdInfoTable
 495     stdInfoTableSizeW
 496       = size_fixed + size_prof
 497       where
 498         size_fixed = 2  -- layout, type
 499         size_prof | opt_SccProfilingOn = 2
 500                   | otherwise    = 0
 501
 502     stdInfoTableSizeB :: Int
 503     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
 504
 505 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
 506 parse :: [Word8] -> ([Word8], [Word8], [Word8])
 507 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
 508                 --then (error . concat)
 509                 --        ["getConDescAddress:parse:"
 510                 --        ,"(not . all (>0) . fmap le"
 511                 --        ,"ngth $ [pkg,modl,occ]"]
 512                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
 513                 else (pkg, modl, occ)
 514 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
 515   where
 516         (pkg, rest1) = break (== fromIntegral (ord ':')) input
 517         (modl, occ)
 518             = (concat $ intersperse [dot] $ reverse modWords, occWord)
 519             where
 520             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
 521                                     --then error "getConDescAddress:parse:length rest1 < 1"
 522                                     then parseModOcc [] []
 523                                     else parseModOcc [] (tail rest1)
 524         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
 525         dot = fromIntegral (ord '.')
 526         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
 527         parseModOcc acc str
 528             = case break (== dot) str of
 529                 (top, []) -> (acc, top)
 530                 (top, _:bot) -> parseModOcc (top : acc) bot
 531
 532
 533 -- | This function returns parsed heap representation of the argument _at this
 534 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
 535 -- Beware when passing something to this function, the same caveats as for
 536 -- 'asBox' apply.
 537 getClosureData :: a -> IO Closure
 538 getClosureData x = do
 539     (iptr, wds, ptrs) <- getClosureRaw x
 540     itbl <- peek iptr
 541     case tipe itbl of
 542         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
 543             (pkg, modl, name) <- dataConInfoPtrToNames iptr
 544             if modl == "ByteCodeInstr" && name == "BreakInfo"
 545               then return $ UnsupportedClosure itbl
 546               else return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
 547
 548         t | t >= THUNK && t <= THUNK_STATIC -> do
 549             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
 550
 551         t | t >= FUN && t <= FUN_STATIC -> do
 552             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
 553
 554         AP ->
 555             return $ APClosure itbl
 556                 (fromIntegral $ wds !! 2)
 557                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
 558                 (head ptrs) (tail ptrs)
 559
 560         PAP ->
 561             return $ PAPClosure itbl
 562                 (fromIntegral $ wds !! 2)
 563                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
 564                 (head ptrs) (tail ptrs)
 565
 566         AP_STACK ->
 567             return $ APStackClosure itbl (head ptrs) (tail ptrs)
 568
 569         THUNK_SELECTOR ->
 570             return $ SelectorClosure itbl (head ptrs)
 571
 572         IND ->
 573             return $ IndClosure itbl (head ptrs)
 574         IND_STATIC ->
 575             return $ IndClosure itbl (head ptrs)
 576         BLACKHOLE ->
 577             return $ BlackholeClosure itbl (head ptrs)
 578
 579         BCO ->
 580             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
 581                 (fromIntegral $ wds !! 4)
 582                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
 583                 (wds !! 5)
 584
 585         ARR_WORDS ->
 586             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
 587
 588         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
 589             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
 590
 591         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
 592             return $ MutVarClosure itbl (head ptrs)
 593
 594         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
 595             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
 596
 597         BLOCKING_QUEUE ->
 598             return $ OtherClosure itbl ptrs wds
 599         --    return $ BlockingQueueClosure itbl
 600         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
 601
 602         --  return $ OtherClosure itbl ptrs wds
 603         --
 604         _ ->
 605             return $ UnsupportedClosure itbl
 606
 607 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
 608 getBoxedClosureData :: Box -> IO Closure
 609 getBoxedClosureData (Box a) = getClosureData a
 610
 611
 612 isChar :: GenClosure b -> Maybe Char
 613 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
 614 isChar _ = Nothing
 615
 616 isCons :: GenClosure b -> Maybe (b, b)
 617 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
 618 isCons _ = Nothing
 619
 620 isTup :: GenClosure b -> Maybe [b]
 621 isTup (ConsClosure { dataArgs = [], ..}) =
 622     if length name >= 3 &&
 623        head name == '(' && last name == ')' &&
 624        all (==',') (tail (init name))
 625     then Just ptrArgs else Nothing
 626 isTup _ = Nothing
 627
 628
 629 isNil :: GenClosure b -> Bool
 630 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
 631 isNil _ = False
 632
 633 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
 634 -- It assumes that for the included boxes, you already replaced them by Strings
 635 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
 636 --
 637 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
 638 ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
 639 ppClosure showBox prec c = case c of
 640     _ | Just ch <- isChar c -> app $
 641         ["C#", show ch]
 642     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
 643         showBox 5 h ++ " : " ++ showBox 4 t
 644     _ | Just vs <- isTup c ->
 645         "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"
 646     ConsClosure {..} -> app $
 647         name : map (showBox 10) ptrArgs ++ map show dataArgs
 648     ThunkClosure {..} -> app $
 649         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
 650     SelectorClosure {..} -> app
 651         ["_sel", showBox 10 selectee]
 652     IndClosure {..} -> app
 653         ["_ind", showBox 10 indirectee]
 654     BlackholeClosure {..} -> app
 655         ["_bh",  showBox 10 indirectee]
 656     APClosure {..} -> app $ map (showBox 10) $
 657         fun : payload
 658     PAPClosure {..} -> app $ map (showBox 10) $
 659         fun : payload
 660     APStackClosure {..} -> app $ map (showBox 10) $
 661         fun : payload
 662     BCOClosure {..} -> app
 663         ["_bco"]
 664     ArrWordsClosure {..} -> app
 665         ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ]
 666     MutArrClosure {..} -> app
 667         ["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
 668     MutVarClosure {..} -> app $
 669         ["_mutVar", (showBox 10) var]
 670     MVarClosure {..} -> app $
 671         ["MVar", (showBox 10) value]
 672     FunClosure {..} ->
 673         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
 674     BlockingQueueClosure {..} ->
 675         "_blockingQueue"
 676     OtherClosure {..} ->
 677         "_other"
 678     UnsupportedClosure {..} ->
 679         "_unsupported"
 680   where
 681     app [a] = a  ++ "()"
 682     app xs = addBraces (10 <= prec) (intercalate " " xs)
 683
 684     shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs
 685
 686 {- $heapmap
 687
 688    For more global views of the heap, you can use heap maps. These come in
 689    variations, either a trees or as graphs, depending on
 690    whether you want to detect cycles and sharing or not.
 691
 692    The entries of a 'HeapGraph' can be annotated with arbitrary values. Most
 693    operations expect this to be in the 'Monoid' class: They use 'mempty' to
 694    annotate closures added because the passed values reference them, and they
 695    use 'mappend' to combine the annotations when two values conincide, e.g.
 696    during 'updateHeapGraph'.
 697 -}
 698
 699 -- | Heap maps as tree, i.e. no sharing, no cycles.
 700 data HeapTree = HeapTree Box (GenClosure HeapTree) | EndOfHeapTree
 701
 702 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
 703 heapTreeClosure (HeapTree _ c) = Just c
 704 heapTreeClosure EndOfHeapTree = Nothing
 705
 706 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
 707 -- that prevents it from running ad infinitum for cyclic or infinite
 708 -- structures.
 709 buildHeapTree :: Int -> Box -> IO HeapTree
 710 buildHeapTree 0 _ = do
 711     return $ EndOfHeapTree
 712 buildHeapTree n b = do
 713     c <- getBoxedClosureData b
 714     c' <- T.mapM (buildHeapTree (n-1)) c
 715     return $ HeapTree b c'
 716
 717 -- | Pretty-Printing a heap Tree
 718 --
 719 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
 720 -- unevaluated expression depending on the command line argument.
 721 --
 722 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
 723 ppHeapTree :: HeapTree -> String
 724 ppHeapTree = go 0
 725   where
 726     go _ EndOfHeapTree = "..."
 727     go prec t@(HeapTree _ c')
 728         | Just s <- isHeapTreeString t = show s
 729         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
 730         | Just bc <- disassembleBCO heapTreeClosure c'
 731                                        = app ("_bco" : map (go 10) (concatMap F.toList bc))
 732         | otherwise                    = ppClosure go prec c'
 733       where
 734         app [a] = a ++ "()"
 735         app xs = addBraces (10 <= prec) (intercalate " " xs)
 736
 737 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
 738 isHeapTreeList tree = do
 739     c <- heapTreeClosure tree
 740     if isNil c
 741       then return []
 742       else do
 743         (h,t) <- isCons c
 744         t' <- isHeapTreeList t
 745         return $ (:) h t'
 746
 747 isHeapTreeString :: HeapTree -> Maybe String
 748 isHeapTreeString t = do
 749     list <- isHeapTreeList t
 750     -- We do not want to print empty lists as "" as we do not know that they
 751     -- are really strings.
 752     if (null list)
 753         then Nothing
 754         else mapM (isChar <=< heapTreeClosure) list
 755
 756 -- | For heap graphs, i.e. data structures that also represent sharing and
 757 -- cyclic structures, these are the entries. If the referenced value is
 758 -- @Nothing@, then we do not have that value in the map, most likely due to
 759 -- exceeding the recursion bound passed to 'buildHeapGraph'.
 760 --
 761 -- Besides a pointer to the stored value and the closure representation we
 762 -- also keep track of whether the value was still alive at the last update of the
 763 -- heap graph. In addition we have a slot for arbitrary data, for the user's convenience.
 764 data HeapGraphEntry a = HeapGraphEntry {
 765         hgeBox :: Box,
 766         hgeClosure :: GenClosure (Maybe HeapGraphIndex),
 767         hgeLive :: Bool,
 768         hgeData :: a}
 769     deriving (Show, Functor)
 770 type HeapGraphIndex = Int
 771
 772 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
 773 -- as the internal representation may change. Nevertheless, we export it here:
 774 -- Sometimes the user knows better what he needs than we do.
 775 newtype HeapGraph a = HeapGraph (M.IntMap (HeapGraphEntry a))
 776     deriving (Show)
 777
 778 lookupHeapGraph :: HeapGraphIndex -> (HeapGraph a) -> Maybe (HeapGraphEntry a)
 779 lookupHeapGraph i (HeapGraph m) = M.lookup i m
 780
 781 heapGraphRoot :: HeapGraphIndex
 782 heapGraphRoot = 0
 783
 784 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
 785 -- than the given limit. The initial value has index 'heapGraphRoot'.
 786 buildHeapGraph
 787    :: Monoid a
 788    => Int -- ^ Search limit
 789    -> a -- ^ Data value for the root
 790    -> Box -- ^ The value to start with
 791    -> IO (HeapGraph a)
 792 buildHeapGraph limit rootD initialBox =
 793     fst <$> multiBuildHeapGraph limit [(rootD, initialBox)]
 794
 795 -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
 796 --   further than the given limit.
 797 --
 798 --   Returns the 'HeapGraph' and the indices of initial values. The arbitrary
 799 --   type @a@ can be used to make the connection between the input and the
 800 --   resulting list of indices, and to store additional data.
 801 multiBuildHeapGraph
 802     :: Monoid a
 803     => Int -- ^ Search limit
 804     -> [(a, Box)] -- ^ Starting values with associated data entry
 805     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
 806 multiBuildHeapGraph limit = generalBuildHeapGraph limit (HeapGraph M.empty)
 807
 808 -- | Adds an entry to an existing 'HeapGraph'.
 809 --
 810 --   Returns the updated 'HeapGraph' and the index of the added value.
 811 addHeapGraph
 812     :: Monoid a
 813     => Int -- ^ Search limit
 814     -> a -- ^ Data to be stored with the added value
 815     -> Box -- ^ Value to add to the graph
 816     -> HeapGraph a -- ^ Graph to extend
 817     -> IO (HeapGraphIndex, HeapGraph a)
 818 addHeapGraph limit d box hg = do
 819     (hg', [(_,i)]) <- generalBuildHeapGraph limit hg [(d,box)]
 820     return (i, hg')
 821
 822 -- | Adds the given annotation to the entry at the given index, using the
 823 -- 'mappend' operation of its 'Monoid' instance.
 824 annotateHeapGraph :: Monoid a => a -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
 825 annotateHeapGraph d i (HeapGraph hg) = HeapGraph $ M.update go i hg
 826   where
 827     go hge = Just $ hge { hgeData = hgeData hge <> d }
 828
 829 generalBuildHeapGraph
 830     :: Monoid a
 831     => Int
 832     -> HeapGraph a
 833     -> [(a,Box)]
 834     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
 835 generalBuildHeapGraph limit _ _ | limit <= 0 = error "buildHeapGraph: limit has to be positive"
 836 generalBuildHeapGraph limit (HeapGraph hg) addBoxes = do
 837     -- First collect all boxes from the existing heap graph
 838     let boxList = [ (hgeBox hge, i) | (i, hge) <- M.toList hg ]
 839         indices | M.null hg = [0..]
 840                 | otherwise = [1 + fst (M.findMax hg)..]
 841
 842         initialState = (boxList, indices, [])
 843     -- It is ok to use the Monoid (IntMap a) instance here, because
 844     -- we will, besides the first time, use 'tell' only to add singletons not
 845     -- already there
 846     (is, hg') <- runWriterT (evalStateT run initialState)
 847     -- Now add the annotations of the root values
 848     let hg'' = foldl' (flip (uncurry annotateHeapGraph)) (HeapGraph hg') is
 849     return (hg'', is)
 850   where
 851     run = do
 852         lift $ tell hg -- Start with the initial map
 853         forM addBoxes $ \(d, b) -> do
 854             -- Cannot fail, as limit is not zero here
 855             Just i <- add limit b
 856             return (d, i)
 857
 858     add 0  _ = return Nothing
 859     add n b = do
 860         -- If the box is in the map, return the index
 861         (existing,_,_) <- get
 862         mbI <- liftIO $ findM (areBoxesEqual b . fst) existing
 863         case mbI of
 864             Just (_,i) -> return $ Just i
 865             Nothing -> do
 866                 -- Otherwise, allocate a new index
 867                 i <- nextI
 868                 -- And register it
 869                 modify (\(x,y,z) -> ((b,i):x, y, z))
 870                 -- Look up the closure
 871                 c <- liftIO $ getBoxedClosureData b
 872                 -- Find indicies for all boxes contained in the map
 873                 c' <- T.mapM (add (n-1)) c
 874                 -- Add add the resulting closure to the map
 875                 lift $ tell (M.singleton i (HeapGraphEntry b c' True mempty))
 876                 return $ Just i
 877     nextI = do
 878         i <- gets (head . (\(_,b,_) -> b))
 879         modify (\(a,b,c) -> (a, tail b, c))
 880         return i
 881
 882 -- | This function updates a heap graph to reflect the current state of
 883 -- closures on the heap, conforming to the following specification.
 884 --
 885 --  * Every entry whose value has been garbage collected by now is marked as
 886 --    dead by setting 'hgeLive' to @False@
 887 --  * Every entry whose value is still live gets the 'hgeClosure' field updated
 888 --    and newly referenced closures are, up to the given depth, added to the graph.
 889 --  * A map mapping previous indicies to the corresponding new indicies is returned as well.
 890 --  * The closure at 'heapGraphRoot' stays at 'heapGraphRoot'
 891 updateHeapGraph :: Monoid a => Int -> HeapGraph a -> IO (HeapGraph a, HeapGraphIndex -> HeapGraphIndex)
 892 updateHeapGraph limit (HeapGraph startHG) = do
 893     (hg', indexMap) <- runWriterT $ foldM go (HeapGraph M.empty) (M.toList startHG)
 894     return (hg', (M.!) indexMap)
 895   where
 896     go hg (i, hge) = do
 897         (j, hg') <- liftIO $ addHeapGraph limit (hgeData hge) (hgeBox hge) hg
 898         tell (M.singleton i j)
 899         return hg'
 900
 901 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
 902 -- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
 903 --
 904 -- >let x1 = "Ki"
 905 -- >    x6 = C# 'H' : C# 'o' : x6
 906 -- >in (x1,x1,x6)
 907 ppHeapGraph :: HeapGraph a -> String
 908 ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
 909   where
 910     -- All variables occuring more than once
 911     bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot]
 912
 913     letWrapper =
 914         if null bindings
 915         then ""
 916         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin "
 917
 918     bindingLetter i = case hgeClosure (iToE i) of
 919         ThunkClosure {..} -> 't'
 920         SelectorClosure {..} -> 't'
 921         APClosure {..} -> 't'
 922         PAPClosure {..} -> 'f'
 923         BCOClosure {..} -> 't'
 924         FunClosure {..} -> 'f'
 925         _ -> 'x'
 926
 927     ppBindingMap = M.fromList $
 928         concat $
 929         map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $
 930         groupBy ((==) `on` snd) $
 931         sortBy (compare `on` snd)
 932         [ (i, bindingLetter i) | i <- bindings ]
 933
 934     ppVar i = ppBindingMap M.! i
 935     ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)
 936
 937     ppEntry prec hge
 938         | Just s <- isString hge = show s
 939         | Just l <- isList hge   = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
 940         | Just bc <- disassembleBCO (fmap (hgeClosure . iToE)) (hgeClosure hge)
 941                                        = app ("_bco" : map (ppRef 10) (concatMap F.toList bc))
 942         | otherwise = ppClosure ppRef prec (hgeClosure hge)
 943       where
 944         app [a] = a  ++ "()"
 945         app xs = addBraces (10 <= prec) (intercalate " " xs)
 946
 947     ppRef _ Nothing = "..."
 948     ppRef prec (Just i) | i `elem` bindings = ppVar i
 949                         | otherwise = ppEntry prec (iToE i)
 950     iToE i = m M.! i
 951
 952     iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
 953
 954     isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
 955     isList hge =
 956         if isNil (hgeClosure hge)
 957           then return []
 958           else do
 959             (h,t) <- isCons (hgeClosure hge)
 960             ti <- t
 961             e <- iToUnboundE ti
 962             t' <- isList e
 963             return $ (:) h t'
 964
 965     isString :: HeapGraphEntry a -> Maybe String
 966     isString e = do
 967         list <- isList e
 968         -- We do not want to print empty lists as "" as we do not know that they
 969         -- are really strings.
 970         if (null list)
 971             then Nothing
 972             else mapM (isChar . hgeClosure <=< iToUnboundE <=< id) list
 973
 974
 975 -- | In the given HeapMap, list all indices that are used more than once. The
 976 -- second parameter adds external references, commonly @[heapGraphRoot]@.
 977 boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
 978 boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $
 979      roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m)
 980
 981 -- | This function integrates the disassembler in "GHC.Disassembler". The first
 982 -- argument should a function that dereferences the pointer in the closure to a
 983 -- closure.
 984 --
 985 -- If any of these return 'Nothing', then 'disassembleBCO' returns Nothing
 986 disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
 987 disassembleBCO deref (BCOClosure {..}) = do
 988     opsC <- deref instrs
 989     litsC <- deref literals
 990     ptrsC  <- deref bcoptrs
 991     return $ disassemble (mccPayload ptrsC) (arrWords litsC) (toBytes (bytes opsC) (arrWords opsC))
 992 disassembleBCO _ _ = Nothing
 993
 994 -- Utilities
 995
 996 findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
 997 findM _p [] = return Nothing
 998 findM p (x:xs) = do
 999     b <- p x
1000     if b then return (Just x) else findM p xs
1001
1002 addBraces :: Bool -> String -> String
1003 addBraces True t = "(" ++ t ++ ")"
1004 addBraces False t = t
1005
1006 braceize :: [String] -> String
1007 braceize [] = ""
1008 braceize xs = "{" ++ intercalate "," xs ++ "}"