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