0187e4c255a0fc62c52704672d05fe42dd63acb5
[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        ( intersperse, intercalate )
67 import Data.Maybe       ( isJust )
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     APClosure {
304         info         :: StgInfoTable 
305         , arity      :: HalfWord
306         , n_args     :: HalfWord
307         , fun        :: b
308         , payload    :: [b]
309     } |
310     PAPClosure {
311         info         :: StgInfoTable 
312         , arity      :: HalfWord
313         , n_args     :: HalfWord
314         , fun        :: b
315         , payload    :: [b]
316     } |
317     APStackClosure {
318         info         :: StgInfoTable 
319         , fun        :: b
320         , payload    :: [b]
321     } |
322     BCOClosure {
323         info         :: StgInfoTable 
324         , instrs     :: b
325         , literals   :: b
326         , bcoptrs    :: b
327         , arity      :: HalfWord
328         , size       :: HalfWord
329         , bitmap     :: Word
330     } |
331     ArrWordsClosure {
332         info         :: StgInfoTable 
333         , bytes      :: Word
334         , arrWords   :: [Word]
335     } |
336     MutArrClosure {
337         info         :: StgInfoTable 
338         , mccPtrs    :: Word
339         , mccSize    :: Word
340         , mccPayload :: [b]
341         -- Card table ignored
342     } |
343     MutVarClosure {
344         info         :: StgInfoTable 
345         , var        :: b
346     } |
347     MVarClosure {
348         info         :: StgInfoTable 
349         , queueHead  :: b
350         , queueTail  :: b
351         , value      :: b
352     } |
353     FunClosure {
354         info         :: StgInfoTable 
355         , ptrArgs    :: [b]
356         , dataArgs   :: [Word]
357     } |
358     BlockingQueueClosure {
359         info         :: StgInfoTable 
360         , link       :: b
361         , blackHole  :: b
362         , owner      :: b
363         , queue      :: b
364     } |
365     OtherClosure {
366         info         :: StgInfoTable 
367         , hvalues    :: [b]
368         , rawWords   :: [Word]
369     } |
370     UnsupportedClosure {
371         info         :: StgInfoTable 
372     }
373  deriving (Show, Functor, Foldable, Traversable)
374
375
376 type Closure = GenClosure Box
377
378 -- | For generic code, this function returns all referenced closures. 
379 allPtrs :: GenClosure b -> [b]
380 allPtrs (ConsClosure {..}) = ptrArgs
381 allPtrs (ThunkClosure {..}) = ptrArgs
382 allPtrs (SelectorClosure {..}) = [selectee]
383 allPtrs (IndClosure {..}) = [indirectee]
384 allPtrs (BlackholeClosure {..}) = [indirectee]
385 allPtrs (APClosure {..}) = fun:payload
386 allPtrs (PAPClosure {..}) = fun:payload
387 allPtrs (APStackClosure {..}) = fun:payload
388 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
389 allPtrs (ArrWordsClosure {..}) = []
390 allPtrs (MutArrClosure {..}) = mccPayload
391 allPtrs (MutVarClosure {..}) = [var]
392 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
393 allPtrs (FunClosure {..}) = ptrArgs
394 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
395 allPtrs (OtherClosure {..}) = hvalues
396 allPtrs (UnsupportedClosure {..}) = []
397
398
399
400 #ifdef PRIM_SUPPORTS_ANY
401 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
402 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
403 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
404 #else
405 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
406 -- accepted
407
408 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
409 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
410
411 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
412
413 -- This is a datatype that has the same layout as Ptr, so that by
414 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
415 data Ptr' a = Ptr' a
416
417 aToWord# :: Any -> Word#
418 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
419
420 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
421 slurpClosure# a = slurpClosure'# (aToWord# a)
422
423 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
424 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
425 #endif
426
427 --pClosure x = do
428 --    getClosure x >>= print
429
430 -- | This returns the raw representation of the given argument. The second
431 -- component of the triple are the words on the heap, and the third component
432 -- are those words that are actually pointers. Once back in Haskell word, the
433 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
434 -- 'Box' will still point to the correct value.
435 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
436 getClosureRaw x =
437     case slurpClosure# (unsafeCoerce# x) of
438         (# iptr, dat, ptrs #) -> do
439             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
440                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
441                 pelems = I# (sizeofArray# ptrs) 
442                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
443             ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList)
444
445 -- From compiler/ghci/RtClosureInspect.hs
446 amap' :: (t -> b) -> Array Int t -> [b]
447 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
448     where g (I# i#) = case indexArray# arr# i# of
449                           (# e #) -> f e
450
451 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
452 -- compiler/ghci/DebuggerUtils.hs
453 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
454 dataConInfoPtrToNames ptr = do
455     conDescAddress <- getConDescAddress ptr
456     wl <- peekArray0 0 conDescAddress
457     let (pkg, modl, name) = parse wl
458     return (b2s pkg, b2s modl, b2s name)
459   where
460     b2s :: [Word8] -> String
461     b2s = fmap (chr . fromIntegral)
462
463     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
464     getConDescAddress ptr'
465       | True = do
466           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
467           return $ (ptr' `plusPtr` stdInfoTableSizeB)
468                     `plusPtr` (fromIntegral (offsetToString :: Word))
469     -- This is code for !ghciTablesNextToCode: 
470     {-
471       | otherwise = peek . intPtrToPtr
472                       . (+ fromIntegral
473                             stdInfoTableSizeB)
474                         . ptrToIntPtr $ ptr
475     -}
476
477     -- hmmmmmm. Is there any way to tell this?
478     opt_SccProfilingOn = False
479
480     stdInfoTableSizeW :: Int
481     -- The size of a standard info table varies with profiling/ticky etc,
482     -- so we can't get it from Constants
483     -- It must vary in sync with mkStdInfoTable
484     stdInfoTableSizeW
485       = size_fixed + size_prof
486       where
487         size_fixed = 2  -- layout, type
488         size_prof | opt_SccProfilingOn = 2
489                   | otherwise    = 0
490
491     stdInfoTableSizeB :: Int
492     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
493
494 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
495 parse :: [Word8] -> ([Word8], [Word8], [Word8])
496 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
497                 --then (error . concat)
498                 --        ["getConDescAddress:parse:"
499                 --        ,"(not . all (>0) . fmap le"
500                 --        ,"ngth $ [pkg,modl,occ]"]
501                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
502                 else (pkg, modl, occ)
503 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
504   where
505         (pkg, rest1) = break (== fromIntegral (ord ':')) input
506         (modl, occ)
507             = (concat $ intersperse [dot] $ reverse modWords, occWord)
508             where
509             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
510                                     --then error "getConDescAddress:parse:length rest1 < 1"
511                                     then parseModOcc [] []
512                                     else parseModOcc [] (tail rest1)
513         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
514         dot = fromIntegral (ord '.')
515         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
516         parseModOcc acc str
517             = case break (== dot) str of
518                 (top, []) -> (acc, top)
519                 (top, _:bot) -> parseModOcc (top : acc) bot
520
521
522 -- | This function returns parsed heap representation of the argument _at this
523 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
524 -- Beware when passing something to this function, the same caveats as for
525 -- 'asBox' apply.
526 getClosureData :: a -> IO Closure
527 getClosureData x = do
528     (iptr, wds, ptrs) <- getClosureRaw x
529     itbl <- peek iptr
530     case tipe itbl of 
531         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
532             (pkg, modl, name) <- dataConInfoPtrToNames iptr
533             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
534
535         t | t >= THUNK && t <= THUNK_STATIC -> do
536             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
537
538         t | t >= FUN && t <= FUN_STATIC -> do
539             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
540
541         AP ->
542             return $ APClosure itbl 
543                 (fromIntegral $ wds !! 2)
544                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
545                 (head ptrs) (tail ptrs)
546
547         PAP ->
548             return $ PAPClosure itbl 
549                 (fromIntegral $ wds !! 2)
550                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
551                 (head ptrs) (tail ptrs)
552
553         AP_STACK ->
554             return $ APStackClosure itbl (head ptrs) (tail ptrs)
555
556         THUNK_SELECTOR ->
557             return $ SelectorClosure itbl (head ptrs)
558
559         IND ->
560             return $ IndClosure itbl (head ptrs)
561         IND_STATIC ->
562             return $ IndClosure itbl (head ptrs)
563         BLACKHOLE ->
564             return $ BlackholeClosure itbl (head ptrs)
565
566         BCO ->
567             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
568                 (fromIntegral $ wds !! 4)
569                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
570                 (wds !! 5)
571
572         ARR_WORDS ->
573             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
574
575         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
576             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
577
578         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
579             return $ MutVarClosure itbl (head ptrs)
580
581         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
582             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
583
584         BLOCKING_QUEUE ->
585             return $ OtherClosure itbl ptrs wds
586         --    return $ BlockingQueueClosure itbl
587         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
588
589         --  return $ OtherClosure itbl ptrs wds
590         --
591         _ ->
592             return $ UnsupportedClosure itbl
593
594 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
595 getBoxedClosureData :: Box -> IO Closure
596 getBoxedClosureData (Box a) = getClosureData a
597
598
599 isChar :: GenClosure b -> Maybe Char
600 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
601 isChar _ = Nothing
602
603 isCons :: GenClosure b -> Maybe (b, b)
604 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
605 isCons _ = Nothing
606
607 isNil :: GenClosure b -> Bool
608 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
609 isNil _ = False
610
611 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
612 -- It assumes that for the included boxes, you already replaced them by Strings
613 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
614 --
615 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
616 ppPrintClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
617 ppPrintClosure showBox prec c = case c of
618     _ | Just ch <- isChar c -> app $
619         ["C#", show ch]
620     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
621         showBox 5 h ++ " : " ++ showBox 4 t
622     ConsClosure {..} -> app $
623         name : map (showBox 10) ptrArgs ++ map show dataArgs
624     ThunkClosure {..} -> app $
625         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
626     SelectorClosure {..} -> app
627         ["_sel", showBox 10 selectee]
628     IndClosure {..} -> app
629         ["_ind", showBox 10 indirectee]
630     BlackholeClosure {..} -> app
631         ["_bh",  showBox 10 indirectee]
632     APClosure {..} -> app $ map (showBox 10) $
633         fun : payload
634     PAPClosure {..} -> app $ map (showBox 10) $
635         fun : payload
636     APStackClosure {..} -> app $ map (showBox 10) $
637         fun : payload
638     BCOClosure {..} -> app
639         ["_bco"]
640     ArrWordsClosure {..} -> app
641         ["toArray", intercalate "," (map show arrWords) ]
642     MutArrClosure {..} -> app
643         ["toMutArray", intercalate "," (map (showBox 10) mccPayload)]
644     MutVarClosure {..} -> app $
645         ["_mutVar", (showBox 10) var]
646     MVarClosure {..} -> app $
647         ["MVar", (showBox 10) value]
648     FunClosure {..} -> 
649         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
650     BlockingQueueClosure {..} -> 
651         "_blockingQueue"
652     OtherClosure {..} ->
653         "_other"
654     UnsupportedClosure {..} ->
655         "_unsupported"
656   where
657     addBraces True t = "(" ++ t ++ ")"
658     addBraces False t = t
659     app [] = "()"
660     app [a] = a 
661     app xs = addBraces (10 <= prec) (intercalate " " xs)
662     braceize [] = ""
663     braceize xs = "{" ++ intercalate "," xs ++ "}"
664     
665 -- $heapmap
666 -- For more global views of the heap, you can use heap maps. These come in
667 -- variations, either a trees or as graphs, depending on
668 -- whether you want to detect cycles and sharing or not.
669
670 -- | Heap maps as tree, i.e. no sharing, no cycles.
671 data HeapTree = HeapTree WeakBox (GenClosure HeapTree) | EndOfHeapTree
672
673 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
674 heapTreeClosure (HeapTree _ c) = Just c
675 heapTreeClosure EndOfHeapTree = Nothing
676
677 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
678 -- that prevents it from running ad infinitum for cyclic or infinite
679 -- structures.
680 buildHeapTree :: Int -> Box -> IO HeapTree
681 buildHeapTree 0 _ = do
682     return $ EndOfHeapTree
683 buildHeapTree n b = do
684     w <- weakBox b
685     c <- getBoxedClosureData b
686     c' <- T.mapM (buildHeapTree (n-1)) c
687     return $ HeapTree w c'
688
689 -- | Pretty-Printing a heap Tree
690 -- 
691 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
692 -- unevaluated expression depending on the command line argument.
693 --
694 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
695 ppHeapTree :: HeapTree -> String
696 ppHeapTree = go 0
697   where
698     go _ EndOfHeapTree = "..."
699     go prec t@(HeapTree _ c')
700         | Just s <- isHeapTreeString t = show s
701         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
702         | otherwise                    =  ppPrintClosure go prec c'
703
704 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
705 isHeapTreeList tree = do
706     c <- heapTreeClosure tree
707     if isNil c
708       then return []
709       else do
710         (h,t) <- isCons c
711         t' <- isHeapTreeList t
712         return $ (:) h t'
713
714 isHeapTreeString :: HeapTree -> Maybe String
715 isHeapTreeString t = do
716     list <- isHeapTreeList t
717     -- We do not want to print empty lists as "" as we do not know that they
718     -- are really strings.
719     if (null list)
720         then Nothing
721         else mapM (isChar <=< heapTreeClosure) list
722
723 -- | For heap graphs, i.e. data structures that also represent sharing and
724 -- cyclic structures, these are the entries. If the referenced value is
725 -- @Nothing@, then we do not have that value in the map, most likely due to
726 -- exceeding the recursion bound passed to 'buildHeapGraph'.
727 data HeapGraphEntry = HeapGraphEntry WeakBox (GenClosure (Maybe HeapGraphIndex))
728     deriving (Show)
729 type HeapGraphIndex = Int
730
731 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
732 -- as the internal representation may change. Nevertheless, we export it here:
733 -- Sometimes the user knows better what he needs than we do.
734 newtype HeapGraph = HeapGraph (M.IntMap HeapGraphEntry)
735     deriving (Show)
736
737 lookupHeapGraph :: HeapGraphIndex -> HeapGraph -> Maybe HeapGraphEntry
738 lookupHeapGraph i (HeapGraph m) = M.lookup i m
739
740 heapGraphRoot :: HeapGraphIndex
741 heapGraphRoot = 0
742
743 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
744 -- than the given limit. The initial value has index 'heapGraphRoot'.
745 buildHeapGraph :: Int -> Box -> IO HeapGraph
746 buildHeapGraph limit initialBox = do
747     let initialState = ([], [0..])
748     HeapGraph <$> execWriterT (runStateT (add limit initialBox) initialState)
749   where
750     add 0 _ = return Nothing
751     add n b = do
752         -- If the box is in the map, return the index
753         (existing,_) <- get
754         case lookup b existing of
755             Just i -> return $ Just i
756             Nothing -> do
757                 -- Otherwise, allocate a new index
758                 i <- nextI
759                 -- And register it
760                 modify (first ((b,i):))
761                 c <- liftIO $ getBoxedClosureData b
762                 -- Find indicies for all boxes contained in the map
763                 c' <- T.mapM (add (n-1)) c
764                 w <- liftIO $ weakBox b
765                 -- Add add the resulting closure to the map
766                 lift $ tell (M.singleton i (HeapGraphEntry w c'))
767                 return $ Just i
768     nextI = do
769         i <- gets (head . snd)
770         modify (second tail)
771         return i
772
773 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example for @repeat "Ho"@:
774 --
775 -- >let x0 = x1 : x2
776 -- >    x1 = C# 'H'
777 -- >    x2 = x3 : x0
778 -- >    x3 = C# 'o'
779 -- >in x0
780 ppHeapGraph :: HeapGraph -> String
781 ppHeapGraph (HeapGraph m) = "let " ++ intercalate "\n    " (map ppEntry (M.assocs m)) ++ "\nin x" ++ show heapGraphRoot
782   where
783     ppEntry (i,HeapGraphEntry _ c) = "x" ++ show i ++ " = " ++ ppPrintClosure go 0 c
784     go _ Nothing = "..."
785     go _ (Just i) = "x" ++ show i
786
787 -- | An a variant of 'Box' that does not keep the value alive.
788 -- 
789 -- Like 'Box', its 'Show' instance is highly unsafe.
790 newtype WeakBox = WeakBox (Weak Box)
791
792
793 type WeakClosure = GenClosure WeakBox
794
795 instance Show WeakBox where
796     showsPrec p (WeakBox w) rs = case unsafePerformIO (deRefWeak w) of
797         Nothing -> let txt = "(freed)" in
798                    replicate (2*wORD_SIZE - length txt) ' ' ++ txt ++ rs
799         Just b -> showsPrec p b rs
800
801 {-|
802   Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
803   collected.
804 -}
805 weakBox :: Box -> IO WeakBox
806 weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
807
808 {-|
809   Checks whether the value referenced by a weak box is still alive
810 -}
811 isAlive :: WeakBox -> IO Bool
812 isAlive (WeakBox w) = isJust `fmap` deRefWeak w
813
814 {-|
815   Dereferences the weak box
816 -}
817 derefWeakBox :: WeakBox -> IO (Maybe Box)
818 derefWeakBox (WeakBox w) = deRefWeak w
819
820 weakenClosure :: Closure -> IO WeakClosure
821 weakenClosure = T.mapM weakBox