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