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