Fix some warnings
[ghc-heap-view.git] / src / GHC / HeapView.hs
1 {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-}
2 {-|
3 Module      :  GHC.HeapView
4 Copyright   :  (c) 2012 Joachim Breitner
5 License     :  BSD3
6 Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>
7
8 With this module, you can investigate the heap representation of Haskell
9 values, i.e. to investigate sharing and lazy evaluation.
10 -}
11
12
13 module GHC.HeapView (
14     -- * Heap data types
15     GenClosure(..),
16     Closure,
17     allPtrs,
18     ClosureType(..),
19     StgInfoTable(..),
20     HalfWord,
21     -- * Reading from the heap
22     getClosureData,
23     getBoxedClosureData,
24     getClosureRaw,
25     -- * Pretty printing
26     ppClosure,
27     -- * Heap maps
28     -- $heapmap
29     HeapTree(..),
30     buildHeapTree,
31     ppHeapTree,
32     HeapGraphEntry(..),
33     HeapGraphIndex,
34     HeapGraph(..),
35     lookupHeapGraph,
36     heapGraphRoot,
37     buildHeapGraph,
38     ppHeapGraph,
39     -- * Boxes
40     Box(..),
41     asBox,
42     -- * Weak boxes
43     WeakBox,
44     weakBox,
45     isAlive,
46     derefWeakBox,
47     WeakClosure,
48     weakenClosure,
49     )
50     where
51
52 import GHC.Exts         ( Any,
53                           Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,
54                           ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
55                           unsafeCoerce# )
56
57 import GHC.Arr          (Array(..))
58
59 import GHC.Constants    ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
60
61 import System.IO.Unsafe ( unsafePerformIO )
62
63 import Foreign          hiding ( unsafePerformIO )
64 import Numeric          ( showHex )
65 import Data.Char
66 import Data.List
67 import Data.Maybe       ( isJust, catMaybes )
68 import System.Mem.Weak
69 import Data.Functor
70 import Data.Function
71 import Data.Foldable    ( Foldable )
72 import Data.Traversable ( Traversable )
73 import qualified Data.Traversable as T
74 import qualified Data.IntMap as M
75 import Control.Monad
76 import Control.Monad.Trans.State
77 import Control.Monad.Trans.Class
78 import Control.Monad.IO.Class
79 import Control.Monad.Trans.Writer.Strict
80 import Control.Arrow    ( first, second )
81
82 #include "ghcautoconf.h"
83
84 -- | An arbitrarily Haskell value in a safe Box. The point is that even
85 -- unevaluated thunks can safely be moved around inside the Box, and when
86 -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
87 -- to evalue the argument.
88 data Box = Box Any
89
90 #if SIZEOF_VOID_P == 8
91 type HalfWord = Word32
92 #else
93 type HalfWord = Word16
94 #endif
95
96 instance Show Box where
97 -- From libraries/base/GHC/Ptr.lhs
98    showsPrec _ (Box a) rs =
99     -- unsafePerformIO (print "↓" >> pClosure a) `seq`    
100     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
101      where
102        ptr  = W# (aToWord# a)
103        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
104        addr = ptr - tag
105         -- want 0s prefixed to pad it out to a fixed length.
106        pad_out ls = 
107           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
108
109 instance Eq Box where
110   Box a == Box b = case reallyUnsafePtrEqualityUpToTag# a b of
111     0# -> False
112     _  -> True
113
114 {-|
115   This takes an arbitrary value and puts it into a box. Note that calls like
116
117   > asBox (head list) 
118
119   will put the thunk \"head list\" into the box, /not/ the element at the head
120   of the list. For that, use careful case expressions:
121
122   > case list of x:_ -> asBox x
123 -}
124 asBox :: a -> Box
125 asBox x = Box (unsafeCoerce# x)
126
127 {-
128    StgInfoTable parsing derived from ByteCodeItbls.lhs
129    Removed the code parameter for now
130    Replaced Type by an enumeration
131    Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
132  -}
133
134 {-| This is a somewhat faithful representation of an info table. See
135    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>
136    for more details on this data structure. Note that the 'Storable' instance
137    provided here does _not_ support writing.
138  -}
139 data StgInfoTable = StgInfoTable {
140    ptrs   :: HalfWord,
141    nptrs  :: HalfWord,
142    tipe   :: ClosureType,
143    srtlen :: HalfWord
144   }
145   deriving (Show)
146
147 instance Storable StgInfoTable where
148
149    sizeOf itbl 
150       = sum
151         [
152          fieldSz ptrs itbl,
153          fieldSz nptrs itbl,
154          sizeOf (undefined :: HalfWord),
155          fieldSz srtlen itbl
156         ]
157
158    alignment _ 
159       = wORD_SIZE
160
161    poke _a0 _itbl
162       = error "Storable StgInfoTable is read-only"
163
164    peek a0
165       = flip (evalStateT) (castPtr a0)
166       $ do
167            ptrs'   <- load
168            nptrs'  <- load
169            tipe'   <- load
170            srtlen' <- load
171            return 
172               StgInfoTable { 
173                  ptrs   = ptrs',
174                  nptrs  = nptrs',
175                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
176                  srtlen = srtlen'
177               }
178
179 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
180 fieldSz sel x = sizeOf (sel x)
181
182 load :: Storable a => PtrIO a
183 load = do addr <- advance
184           lift (peek addr)
185
186 type PtrIO = StateT (Ptr Word8) IO
187
188 advance :: Storable a => PtrIO (Ptr a)
189 advance = StateT adv where
190     adv addr = case castPtr addr of { addrCast -> return
191         (addrCast, addr `plusPtr` sizeOfPointee addrCast) }
192
193 sizeOfPointee :: (Storable a) => Ptr a -> Int
194 sizeOfPointee addr = sizeOf (typeHack addr)
195     where typeHack = undefined :: Ptr a -> a
196
197 {-
198    Data Type representing Closures
199  -}
200
201
202 {-| A closure type enumeration, in order matching the actual value on the heap.
203    Needs to be synchronized with
204    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>
205  -}
206 data ClosureType =
207           INVALID_OBJECT
208         | CONSTR
209         | CONSTR_1_0
210         | CONSTR_0_1
211         | CONSTR_2_0
212         | CONSTR_1_1
213         | CONSTR_0_2
214         | CONSTR_STATIC
215         | CONSTR_NOCAF_STATIC
216         | FUN
217         | FUN_1_0
218         | FUN_0_1
219         | FUN_2_0
220         | FUN_1_1
221         | FUN_0_2
222         | FUN_STATIC
223         | THUNK
224         | THUNK_1_0
225         | THUNK_0_1
226         | THUNK_2_0
227         | THUNK_1_1
228         | THUNK_0_2
229         | THUNK_STATIC
230         | THUNK_SELECTOR
231         | BCO
232         | AP
233         | PAP
234         | AP_STACK
235         | IND
236         | IND_PERM
237         | IND_STATIC
238         | RET_BCO
239         | RET_SMALL
240         | RET_BIG
241         | RET_DYN
242         | RET_FUN
243         | UPDATE_FRAME
244         | CATCH_FRAME
245         | UNDERFLOW_FRAME
246         | STOP_FRAME
247         | BLOCKING_QUEUE
248         | BLACKHOLE
249         | MVAR_CLEAN
250         | MVAR_DIRTY
251         | ARR_WORDS
252         | MUT_ARR_PTRS_CLEAN
253         | MUT_ARR_PTRS_DIRTY
254         | MUT_ARR_PTRS_FROZEN0
255         | MUT_ARR_PTRS_FROZEN
256         | MUT_VAR_CLEAN
257         | MUT_VAR_DIRTY
258         | WEAK
259         | PRIM
260         | MUT_PRIM
261         | TSO
262         | STACK
263         | TREC_CHUNK
264         | ATOMICALLY_FRAME
265         | CATCH_RETRY_FRAME
266         | CATCH_STM_FRAME
267         | WHITEHOLE
268  deriving (Show, Eq, Enum, Ord)
269
270 {-| This is the main data type of this module, representing a Haskell value on
271   the heap. This reflects
272   <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
273
274   The data type is parametrized by the type to store references in, which
275   should be either 'Box' or 'WeakBox', with appropriate type synonyms 'Closure'
276   and 'WeakClosure'.
277  -}
278 data GenClosure b =
279     ConsClosure {
280         info         :: StgInfoTable 
281         , ptrArgs    :: [b]
282         , dataArgs   :: [Word]
283         , pkg        :: String
284         , modl       :: String
285         , name       :: String
286     } |
287     ThunkClosure {
288         info         :: StgInfoTable 
289         , ptrArgs    :: [b]
290         , dataArgs   :: [Word]
291     } |
292     SelectorClosure {
293         info         :: StgInfoTable 
294         , selectee   :: b
295     } |
296     IndClosure {
297         info         :: StgInfoTable 
298         , indirectee   :: b
299     } |
300     BlackholeClosure {
301         info         :: StgInfoTable 
302         , indirectee   :: b
303     } |
304     -- In GHCi, if Linker.h would allow a reverse looup, we could for exported
305     -- functions fun actually find the name here.
306     -- At least the other direction works via "lookupSymbol
307     -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
308     APClosure {
309         info         :: StgInfoTable 
310         , arity      :: HalfWord
311         , n_args     :: HalfWord
312         , fun        :: b
313         , payload    :: [b]
314     } |
315     PAPClosure {
316         info         :: StgInfoTable 
317         , arity      :: HalfWord
318         , n_args     :: HalfWord
319         , fun        :: b
320         , payload    :: [b]
321     } |
322     APStackClosure {
323         info         :: StgInfoTable 
324         , fun        :: b
325         , payload    :: [b]
326     } |
327     BCOClosure {
328         info         :: StgInfoTable 
329         , instrs     :: b
330         , literals   :: b
331         , bcoptrs    :: b
332         , arity      :: HalfWord
333         , size       :: HalfWord
334         , bitmap     :: Word
335     } |
336     ArrWordsClosure {
337         info         :: StgInfoTable 
338         , bytes      :: Word
339         , arrWords   :: [Word]
340     } |
341     MutArrClosure {
342         info         :: StgInfoTable 
343         , mccPtrs    :: Word
344         , mccSize    :: Word
345         , mccPayload :: [b]
346         -- Card table ignored
347     } |
348     MutVarClosure {
349         info         :: StgInfoTable 
350         , var        :: b
351     } |
352     MVarClosure {
353         info         :: StgInfoTable 
354         , queueHead  :: b
355         , queueTail  :: b
356         , value      :: b
357     } |
358     FunClosure {
359         info         :: StgInfoTable 
360         , ptrArgs    :: [b]
361         , dataArgs   :: [Word]
362     } |
363     BlockingQueueClosure {
364         info         :: StgInfoTable 
365         , link       :: b
366         , blackHole  :: b
367         , owner      :: b
368         , queue      :: b
369     } |
370     OtherClosure {
371         info         :: StgInfoTable 
372         , hvalues    :: [b]
373         , rawWords   :: [Word]
374     } |
375     UnsupportedClosure {
376         info         :: StgInfoTable 
377     }
378  deriving (Show, Functor, Foldable, Traversable)
379
380
381 type Closure = GenClosure Box
382
383 -- | For generic code, this function returns all referenced closures. 
384 allPtrs :: GenClosure b -> [b]
385 allPtrs (ConsClosure {..}) = ptrArgs
386 allPtrs (ThunkClosure {..}) = ptrArgs
387 allPtrs (SelectorClosure {..}) = [selectee]
388 allPtrs (IndClosure {..}) = [indirectee]
389 allPtrs (BlackholeClosure {..}) = [indirectee]
390 allPtrs (APClosure {..}) = fun:payload
391 allPtrs (PAPClosure {..}) = fun:payload
392 allPtrs (APStackClosure {..}) = fun:payload
393 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
394 allPtrs (ArrWordsClosure {..}) = []
395 allPtrs (MutArrClosure {..}) = mccPayload
396 allPtrs (MutVarClosure {..}) = [var]
397 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
398 allPtrs (FunClosure {..}) = ptrArgs
399 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
400 allPtrs (OtherClosure {..}) = hvalues
401 allPtrs (UnsupportedClosure {..}) = []
402
403
404 #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 ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
630 ppClosure 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                    =  ppClosure 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 _ | limit <= 0 = error "buildHeapGraph: First argument has to be positive"
762 buildHeapGraph limit initialBox = do
763     let initialState = ([], [0..])
764     HeapGraph <$> execWriterT (runStateT (add limit initialBox) initialState)
765   where
766     add 0 _ = return Nothing
767     add n b = do
768         -- If the box is in the map, return the index
769         (existing,_) <- get
770         case lookup b existing of
771             Just i -> return $ Just i
772             Nothing -> do
773                 -- Otherwise, allocate a new index
774                 i <- nextI
775                 -- And register it
776                 modify (first ((b,i):))
777                 c <- liftIO $ getBoxedClosureData b
778                 -- Find indicies for all boxes contained in the map
779                 c' <- T.mapM (add (n-1)) c
780                 w <- liftIO $ weakBox b
781                 -- Add add the resulting closure to the map
782                 lift $ tell (M.singleton i (HeapGraphEntry w c'))
783                 return $ Just i
784     nextI = do
785         i <- gets (head . snd)
786         modify (second tail)
787         return i
788
789 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
790 -- for @let s = "Ki" in (s, s, cycle "Ho")@:
791 --
792 -- >let x1 = "Ki"
793 -- >    x6 = C# 'H' : C# 'o' : x6
794 -- >in (x1,x1,x6)
795 ppHeapGraph :: HeapGraph -> String
796 ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
797   where
798     -- All variables occuring more than once
799     bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot] 
800
801     letWrapper =
802         if null bindings
803         then ""
804         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin "
805
806     bindingLetter i = case iToE i of
807         HeapGraphEntry _ c -> case c of 
808             ThunkClosure {..} -> 't'
809             SelectorClosure {..} -> 't'
810             APClosure {..} -> 't'
811             PAPClosure {..} -> 'f'
812             BCOClosure {..} -> 't'
813             FunClosure {..} -> 'f'
814             _ -> 'x'
815
816     ppBindingMap = M.fromList $
817         concat $
818         map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $
819         groupBy ((==) `on` snd) $ 
820         sortBy (compare `on` snd)
821         [ (i, bindingLetter i) | i <- bindings ]
822
823     ppVar i = ppBindingMap M.! i
824     ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)
825
826     ppEntry prec e@(HeapGraphEntry _ c)
827         | Just s <- isString e = show s
828         | Just l <- isList e = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
829         | otherwise = ppClosure ppRef prec c
830
831     ppRef _ Nothing = "..."
832     ppRef prec (Just i) | i `elem` bindings = ppVar i
833                         | otherwise = ppEntry prec (iToE i) 
834     iToE i = m M.! i
835
836     iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
837
838     isList :: HeapGraphEntry -> Maybe ([Maybe HeapGraphIndex])
839     isList (HeapGraphEntry _ c) = 
840         if isNil c
841           then return []
842           else do
843             (h,t) <- isCons c
844             ti <- t
845             e <- iToUnboundE ti
846             t' <- isList e
847             return $ (:) h t'
848
849     isString :: HeapGraphEntry -> Maybe String
850     isString e = do
851         list <- isList e
852         -- We do not want to print empty lists as "" as we do not know that they
853         -- are really strings.
854         if (null list)
855             then Nothing
856             else mapM (isChar . (\(HeapGraphEntry _ c) -> c) <=< iToUnboundE <=< id) list
857
858
859 -- | In the given HeapMap, list all indices that are used more than once. The
860 -- second parameter adds external references, commonly @[heapGraphRoot]@.
861 boundMultipleTimes :: HeapGraph -> [HeapGraphIndex] -> [HeapGraphIndex]
862 boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $
863      roots ++ concatMap (\(HeapGraphEntry _ c) -> catMaybes (allPtrs c)) (M.elems m)
864
865 -- | An a variant of 'Box' that does not keep the value alive.
866 -- 
867 -- Like 'Box', its 'Show' instance is highly unsafe.
868 newtype WeakBox = WeakBox (Weak Box)
869
870
871 type WeakClosure = GenClosure WeakBox
872
873 instance Show WeakBox where
874     showsPrec p (WeakBox w) rs = case unsafePerformIO (deRefWeak w) of
875         Nothing -> let txt = "(freed)" in
876                    replicate (2*wORD_SIZE - length txt) ' ' ++ txt ++ rs
877         Just b -> showsPrec p b rs
878
879 {-|
880   Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
881   collected.
882 -}
883 weakBox :: Box -> IO WeakBox
884 weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
885
886 {-|
887   Checks whether the value referenced by a weak box is still alive
888 -}
889 isAlive :: WeakBox -> IO Bool
890 isAlive (WeakBox w) = isJust `fmap` deRefWeak w
891
892 {-|
893   Dereferences the weak box
894 -}
895 derefWeakBox :: WeakBox -> IO (Maybe Box)
896 derefWeakBox (WeakBox w) = deRefWeak w
897
898 weakenClosure :: Closure -> IO WeakClosure
899 weakenClosure = T.mapM weakBox