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