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