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