Pretty-Print lists and strings in ppHeapGraph
[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     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 isTup :: GenClosure b -> Maybe [b]
608 isTup (ConsClosure { dataArgs = [], ..}) =
609     if length name >= 3 &&
610        head name == '(' && last name == ')' &&
611        all (==',') (tail (init name))
612     then Just ptrArgs else Nothing
613 isTup _ = Nothing
614
615
616 isNil :: GenClosure b -> Bool
617 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
618 isNil _ = False
619
620 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
621 -- It assumes that for the included boxes, you already replaced them by Strings
622 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
623 --
624 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
625 ppPrintClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
626 ppPrintClosure showBox prec c = case c of
627     _ | Just ch <- isChar c -> app $
628         ["C#", show ch]
629     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
630         showBox 5 h ++ " : " ++ showBox 4 t
631     _ | Just vs <- isTup c ->
632         "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"
633     ConsClosure {..} -> app $
634         name : map (showBox 10) ptrArgs ++ map show dataArgs
635     ThunkClosure {..} -> app $
636         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
637     SelectorClosure {..} -> app
638         ["_sel", showBox 10 selectee]
639     IndClosure {..} -> app
640         ["_ind", showBox 10 indirectee]
641     BlackholeClosure {..} -> app
642         ["_bh",  showBox 10 indirectee]
643     APClosure {..} -> app $ map (showBox 10) $
644         fun : payload
645     PAPClosure {..} -> app $ map (showBox 10) $
646         fun : payload
647     APStackClosure {..} -> app $ map (showBox 10) $
648         fun : payload
649     BCOClosure {..} -> app
650         ["_bco"]
651     ArrWordsClosure {..} -> app
652         ["toArray", intercalate "," (map show arrWords) ]
653     MutArrClosure {..} -> app
654         ["toMutArray", intercalate "," (map (showBox 10) mccPayload)]
655     MutVarClosure {..} -> app $
656         ["_mutVar", (showBox 10) var]
657     MVarClosure {..} -> app $
658         ["MVar", (showBox 10) value]
659     FunClosure {..} -> 
660         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
661     BlockingQueueClosure {..} -> 
662         "_blockingQueue"
663     OtherClosure {..} ->
664         "_other"
665     UnsupportedClosure {..} ->
666         "_unsupported"
667   where
668     addBraces True t = "(" ++ t ++ ")"
669     addBraces False t = t
670     app [] = "()"
671     app [a] = a 
672     app xs = addBraces (10 <= prec) (intercalate " " xs)
673     braceize [] = ""
674     braceize xs = "{" ++ intercalate "," xs ++ "}"
675     
676 -- $heapmap
677 -- For more global views of the heap, you can use heap maps. These come in
678 -- variations, either a trees or as graphs, depending on
679 -- whether you want to detect cycles and sharing or not.
680
681 -- | Heap maps as tree, i.e. no sharing, no cycles.
682 data HeapTree = HeapTree WeakBox (GenClosure HeapTree) | EndOfHeapTree
683
684 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
685 heapTreeClosure (HeapTree _ c) = Just c
686 heapTreeClosure EndOfHeapTree = Nothing
687
688 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
689 -- that prevents it from running ad infinitum for cyclic or infinite
690 -- structures.
691 buildHeapTree :: Int -> Box -> IO HeapTree
692 buildHeapTree 0 _ = do
693     return $ EndOfHeapTree
694 buildHeapTree n b = do
695     w <- weakBox b
696     c <- getBoxedClosureData b
697     c' <- T.mapM (buildHeapTree (n-1)) c
698     return $ HeapTree w c'
699
700 -- | Pretty-Printing a heap Tree
701 -- 
702 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
703 -- unevaluated expression depending on the command line argument.
704 --
705 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
706 ppHeapTree :: HeapTree -> String
707 ppHeapTree = go 0
708   where
709     go _ EndOfHeapTree = "..."
710     go prec t@(HeapTree _ c')
711         | Just s <- isHeapTreeString t = show s
712         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
713         | otherwise                    =  ppPrintClosure go prec c'
714
715 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
716 isHeapTreeList tree = do
717     c <- heapTreeClosure tree
718     if isNil c
719       then return []
720       else do
721         (h,t) <- isCons c
722         t' <- isHeapTreeList t
723         return $ (:) h t'
724
725 isHeapTreeString :: HeapTree -> Maybe String
726 isHeapTreeString t = do
727     list <- isHeapTreeList t
728     -- We do not want to print empty lists as "" as we do not know that they
729     -- are really strings.
730     if (null list)
731         then Nothing
732         else mapM (isChar <=< heapTreeClosure) list
733
734 -- | For heap graphs, i.e. data structures that also represent sharing and
735 -- cyclic structures, these are the entries. If the referenced value is
736 -- @Nothing@, then we do not have that value in the map, most likely due to
737 -- exceeding the recursion bound passed to 'buildHeapGraph'.
738 data HeapGraphEntry = HeapGraphEntry WeakBox (GenClosure (Maybe HeapGraphIndex))
739     deriving (Show)
740 type HeapGraphIndex = Int
741
742 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
743 -- as the internal representation may change. Nevertheless, we export it here:
744 -- Sometimes the user knows better what he needs than we do.
745 newtype HeapGraph = HeapGraph (M.IntMap HeapGraphEntry)
746     deriving (Show)
747
748 lookupHeapGraph :: HeapGraphIndex -> HeapGraph -> Maybe HeapGraphEntry
749 lookupHeapGraph i (HeapGraph m) = M.lookup i m
750
751 heapGraphRoot :: HeapGraphIndex
752 heapGraphRoot = 0
753
754 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
755 -- than the given limit. The initial value has index 'heapGraphRoot'.
756 buildHeapGraph :: Int -> Box -> IO HeapGraph
757 buildHeapGraph limit initialBox = do
758     let initialState = ([], [0..])
759     HeapGraph <$> execWriterT (runStateT (add limit initialBox) initialState)
760   where
761     add 0 _ = return Nothing
762     add n b = do
763         -- If the box is in the map, return the index
764         (existing,_) <- get
765         case lookup b existing of
766             Just i -> return $ Just i
767             Nothing -> do
768                 -- Otherwise, allocate a new index
769                 i <- nextI
770                 -- And register it
771                 modify (first ((b,i):))
772                 c <- liftIO $ getBoxedClosureData b
773                 -- Find indicies for all boxes contained in the map
774                 c' <- T.mapM (add (n-1)) c
775                 w <- liftIO $ weakBox b
776                 -- Add add the resulting closure to the map
777                 lift $ tell (M.singleton i (HeapGraphEntry w c'))
778                 return $ Just i
779     nextI = do
780         i <- gets (head . snd)
781         modify (second tail)
782         return i
783
784 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
785 -- for @let s = "Ki" in (s, s, cycle "Ho")@:
786 --
787 -- >let x1 = "Ki"
788 -- >    x6 = C# 'H' : C# 'o' : x6
789 -- >in (x1,x1,x6)
790 ppHeapGraph :: HeapGraph -> String
791 ppHeapGraph (HeapGraph m) =
792     "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\n" ++
793     "in " ++ ppRef 0 (Just heapGraphRoot)
794   where
795     -- All variables occuring more than once
796     bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot] 
797     ppBinding i = "x" ++ show i ++ " = " ++ ppEntry 0 (iToE i)
798
799     ppEntry prec e@(HeapGraphEntry _ c)
800         | Just s <- isString e = show s
801         | Just l <- isList e = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
802         | otherwise = ppPrintClosure ppRef prec c
803
804     ppRef _ Nothing = "..."
805     ppRef prec (Just i) | i `elem` bindings = "x" ++ show i
806                         | otherwise = ppEntry prec (iToE i) 
807     iToE i = fromJust (M.lookup i m)
808
809     iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
810                   
811         
812
813     isList :: HeapGraphEntry -> Maybe ([Maybe HeapGraphIndex])
814     isList (HeapGraphEntry _ c) = 
815         if isNil c
816           then return []
817           else do
818             (h,t) <- isCons c
819             ti <- t
820             e <- iToUnboundE ti
821             t' <- isList e
822             return $ (:) h t'
823
824     isString :: HeapGraphEntry -> Maybe String
825     isString e = do
826         list <- isList e
827         -- We do not want to print empty lists as "" as we do not know that they
828         -- are really strings.
829         if (null list)
830             then Nothing
831             else mapM (isChar . (\(HeapGraphEntry _ c) -> c) <=< iToUnboundE <=< id) list
832
833
834 -- | In the given HeapMap, list all indices that are used more than once. The
835 -- second parameter adds external references, commonly @[heapGraphRoot]@.
836 boundMultipleTimes :: HeapGraph -> [HeapGraphIndex] -> [HeapGraphIndex]
837 boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $
838      roots ++ concatMap (\(HeapGraphEntry _ c) -> catMaybes (allPtrs c)) (M.elems m)
839
840 -- | An a variant of 'Box' that does not keep the value alive.
841 -- 
842 -- Like 'Box', its 'Show' instance is highly unsafe.
843 newtype WeakBox = WeakBox (Weak Box)
844
845
846 type WeakClosure = GenClosure WeakBox
847
848 instance Show WeakBox where
849     showsPrec p (WeakBox w) rs = case unsafePerformIO (deRefWeak w) of
850         Nothing -> let txt = "(freed)" in
851                    replicate (2*wORD_SIZE - length txt) ' ' ++ txt ++ rs
852         Just b -> showsPrec p b rs
853
854 {-|
855   Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
856   collected.
857 -}
858 weakBox :: Box -> IO WeakBox
859 weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
860
861 {-|
862   Checks whether the value referenced by a weak box is still alive
863 -}
864 isAlive :: WeakBox -> IO Bool
865 isAlive (WeakBox w) = isJust `fmap` deRefWeak w
866
867 {-|
868   Dereferences the weak box
869 -}
870 derefWeakBox :: WeakBox -> IO (Maybe Box)
871 derefWeakBox (WeakBox w) = deRefWeak w
872
873 weakenClosure :: Closure -> IO WeakClosure
874 weakenClosure = T.mapM weakBox