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