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