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