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