Give variable names in :printHeap better letters
[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     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
405 #ifdef PRIM_SUPPORTS_ANY
406 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
407 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
408 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
409 #else
410 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
411 -- accepted
412
413 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
414 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
415
416 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
417
418 -- This is a datatype that has the same layout as Ptr, so that by
419 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
420 data Ptr' a = Ptr' a
421
422 aToWord# :: Any -> Word#
423 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
424
425 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
426 slurpClosure# a = slurpClosure'# (aToWord# a)
427
428 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
429 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
430 #endif
431
432 --pClosure x = do
433 --    getClosure x >>= print
434
435 -- | This returns the raw representation of the given argument. The second
436 -- component of the triple are the words on the heap, and the third component
437 -- are those words that are actually pointers. Once back in Haskell word, the
438 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
439 -- 'Box' will still point to the correct value.
440 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
441 getClosureRaw x =
442     case slurpClosure# (unsafeCoerce# x) of
443         (# iptr, dat, ptrs #) -> do
444             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
445                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
446                 pelems = I# (sizeofArray# ptrs) 
447                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
448             ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList)
449
450 -- From compiler/ghci/RtClosureInspect.hs
451 amap' :: (t -> b) -> Array Int t -> [b]
452 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
453     where g (I# i#) = case indexArray# arr# i# of
454                           (# e #) -> f e
455
456 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
457 -- compiler/ghci/DebuggerUtils.hs
458 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
459 dataConInfoPtrToNames ptr = do
460     conDescAddress <- getConDescAddress ptr
461     wl <- peekArray0 0 conDescAddress
462     let (pkg, modl, name) = parse wl
463     return (b2s pkg, b2s modl, b2s name)
464   where
465     b2s :: [Word8] -> String
466     b2s = fmap (chr . fromIntegral)
467
468     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
469     getConDescAddress ptr'
470       | True = do
471           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
472           return $ (ptr' `plusPtr` stdInfoTableSizeB)
473                     `plusPtr` (fromIntegral (offsetToString :: Word))
474     -- This is code for !ghciTablesNextToCode: 
475     {-
476       | otherwise = peek . intPtrToPtr
477                       . (+ fromIntegral
478                             stdInfoTableSizeB)
479                         . ptrToIntPtr $ ptr
480     -}
481
482     -- hmmmmmm. Is there any way to tell this?
483     opt_SccProfilingOn = False
484
485     stdInfoTableSizeW :: Int
486     -- The size of a standard info table varies with profiling/ticky etc,
487     -- so we can't get it from Constants
488     -- It must vary in sync with mkStdInfoTable
489     stdInfoTableSizeW
490       = size_fixed + size_prof
491       where
492         size_fixed = 2  -- layout, type
493         size_prof | opt_SccProfilingOn = 2
494                   | otherwise    = 0
495
496     stdInfoTableSizeB :: Int
497     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
498
499 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
500 parse :: [Word8] -> ([Word8], [Word8], [Word8])
501 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
502                 --then (error . concat)
503                 --        ["getConDescAddress:parse:"
504                 --        ,"(not . all (>0) . fmap le"
505                 --        ,"ngth $ [pkg,modl,occ]"]
506                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
507                 else (pkg, modl, occ)
508 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
509   where
510         (pkg, rest1) = break (== fromIntegral (ord ':')) input
511         (modl, occ)
512             = (concat $ intersperse [dot] $ reverse modWords, occWord)
513             where
514             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
515                                     --then error "getConDescAddress:parse:length rest1 < 1"
516                                     then parseModOcc [] []
517                                     else parseModOcc [] (tail rest1)
518         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
519         dot = fromIntegral (ord '.')
520         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
521         parseModOcc acc str
522             = case break (== dot) str of
523                 (top, []) -> (acc, top)
524                 (top, _:bot) -> parseModOcc (top : acc) bot
525
526
527 -- | This function returns parsed heap representation of the argument _at this
528 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
529 -- Beware when passing something to this function, the same caveats as for
530 -- 'asBox' apply.
531 getClosureData :: a -> IO Closure
532 getClosureData x = do
533     (iptr, wds, ptrs) <- getClosureRaw x
534     itbl <- peek iptr
535     case tipe itbl of 
536         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
537             (pkg, modl, name) <- dataConInfoPtrToNames iptr
538             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
539
540         t | t >= THUNK && t <= THUNK_STATIC -> do
541             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
542
543         t | t >= FUN && t <= FUN_STATIC -> do
544             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
545
546         AP ->
547             return $ APClosure itbl 
548                 (fromIntegral $ wds !! 2)
549                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
550                 (head ptrs) (tail ptrs)
551
552         PAP ->
553             return $ PAPClosure itbl 
554                 (fromIntegral $ wds !! 2)
555                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
556                 (head ptrs) (tail ptrs)
557
558         AP_STACK ->
559             return $ APStackClosure itbl (head ptrs) (tail ptrs)
560
561         THUNK_SELECTOR ->
562             return $ SelectorClosure itbl (head ptrs)
563
564         IND ->
565             return $ IndClosure itbl (head ptrs)
566         IND_STATIC ->
567             return $ IndClosure itbl (head ptrs)
568         BLACKHOLE ->
569             return $ BlackholeClosure itbl (head ptrs)
570
571         BCO ->
572             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
573                 (fromIntegral $ wds !! 4)
574                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
575                 (wds !! 5)
576
577         ARR_WORDS ->
578             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
579
580         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
581             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
582
583         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
584             return $ MutVarClosure itbl (head ptrs)
585
586         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
587             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
588
589         BLOCKING_QUEUE ->
590             return $ OtherClosure itbl ptrs wds
591         --    return $ BlockingQueueClosure itbl
592         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
593
594         --  return $ OtherClosure itbl ptrs wds
595         --
596         _ ->
597             return $ UnsupportedClosure itbl
598
599 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
600 getBoxedClosureData :: Box -> IO Closure
601 getBoxedClosureData (Box a) = getClosureData a
602
603
604 isChar :: GenClosure b -> Maybe Char
605 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
606 isChar _ = Nothing
607
608 isCons :: GenClosure b -> Maybe (b, b)
609 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
610 isCons _ = Nothing
611
612 isTup :: GenClosure b -> Maybe [b]
613 isTup (ConsClosure { dataArgs = [], ..}) =
614     if length name >= 3 &&
615        head name == '(' && last name == ')' &&
616        all (==',') (tail (init name))
617     then Just ptrArgs else Nothing
618 isTup _ = Nothing
619
620
621 isNil :: GenClosure b -> Bool
622 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
623 isNil _ = False
624
625 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
626 -- It assumes that for the included boxes, you already replaced them by Strings
627 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
628 --
629 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
630 ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
631 ppClosure showBox prec c = case c of
632     _ | Just ch <- isChar c -> app $
633         ["C#", show ch]
634     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
635         showBox 5 h ++ " : " ++ showBox 4 t
636     _ | Just vs <- isTup c ->
637         "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"
638     ConsClosure {..} -> app $
639         name : map (showBox 10) ptrArgs ++ map show dataArgs
640     ThunkClosure {..} -> app $
641         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
642     SelectorClosure {..} -> app
643         ["_sel", showBox 10 selectee]
644     IndClosure {..} -> app
645         ["_ind", showBox 10 indirectee]
646     BlackholeClosure {..} -> app
647         ["_bh",  showBox 10 indirectee]
648     APClosure {..} -> app $ map (showBox 10) $
649         fun : payload
650     PAPClosure {..} -> app $ map (showBox 10) $
651         fun : payload
652     APStackClosure {..} -> app $ map (showBox 10) $
653         fun : payload
654     BCOClosure {..} -> app
655         ["_bco"]
656     ArrWordsClosure {..} -> app
657         ["toArray", intercalate "," (map show arrWords) ]
658     MutArrClosure {..} -> app
659         ["toMutArray", intercalate "," (map (showBox 10) mccPayload)]
660     MutVarClosure {..} -> app $
661         ["_mutVar", (showBox 10) var]
662     MVarClosure {..} -> app $
663         ["MVar", (showBox 10) value]
664     FunClosure {..} -> 
665         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
666     BlockingQueueClosure {..} -> 
667         "_blockingQueue"
668     OtherClosure {..} ->
669         "_other"
670     UnsupportedClosure {..} ->
671         "_unsupported"
672   where
673     addBraces True t = "(" ++ t ++ ")"
674     addBraces False t = t
675     app [] = "()"
676     app [a] = a 
677     app xs = addBraces (10 <= prec) (intercalate " " xs)
678     braceize [] = ""
679     braceize xs = "{" ++ intercalate "," xs ++ "}"
680     
681 -- $heapmap
682 -- For more global views of the heap, you can use heap maps. These come in
683 -- variations, either a trees or as graphs, depending on
684 -- whether you want to detect cycles and sharing or not.
685
686 -- | Heap maps as tree, i.e. no sharing, no cycles.
687 data HeapTree = HeapTree WeakBox (GenClosure HeapTree) | EndOfHeapTree
688
689 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
690 heapTreeClosure (HeapTree _ c) = Just c
691 heapTreeClosure EndOfHeapTree = Nothing
692
693 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
694 -- that prevents it from running ad infinitum for cyclic or infinite
695 -- structures.
696 buildHeapTree :: Int -> Box -> IO HeapTree
697 buildHeapTree 0 _ = do
698     return $ EndOfHeapTree
699 buildHeapTree n b = do
700     w <- weakBox b
701     c <- getBoxedClosureData b
702     c' <- T.mapM (buildHeapTree (n-1)) c
703     return $ HeapTree w c'
704
705 -- | Pretty-Printing a heap Tree
706 -- 
707 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
708 -- unevaluated expression depending on the command line argument.
709 --
710 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
711 ppHeapTree :: HeapTree -> String
712 ppHeapTree = go 0
713   where
714     go _ EndOfHeapTree = "..."
715     go prec t@(HeapTree _ c')
716         | Just s <- isHeapTreeString t = show s
717         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
718         | otherwise                    =  ppClosure go prec c'
719
720 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
721 isHeapTreeList tree = do
722     c <- heapTreeClosure tree
723     if isNil c
724       then return []
725       else do
726         (h,t) <- isCons c
727         t' <- isHeapTreeList t
728         return $ (:) h t'
729
730 isHeapTreeString :: HeapTree -> Maybe String
731 isHeapTreeString t = do
732     list <- isHeapTreeList t
733     -- We do not want to print empty lists as "" as we do not know that they
734     -- are really strings.
735     if (null list)
736         then Nothing
737         else mapM (isChar <=< heapTreeClosure) list
738
739 -- | For heap graphs, i.e. data structures that also represent sharing and
740 -- cyclic structures, these are the entries. If the referenced value is
741 -- @Nothing@, then we do not have that value in the map, most likely due to
742 -- exceeding the recursion bound passed to 'buildHeapGraph'.
743 data HeapGraphEntry = HeapGraphEntry WeakBox (GenClosure (Maybe HeapGraphIndex))
744     deriving (Show)
745 type HeapGraphIndex = Int
746
747 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
748 -- as the internal representation may change. Nevertheless, we export it here:
749 -- Sometimes the user knows better what he needs than we do.
750 newtype HeapGraph = HeapGraph (M.IntMap HeapGraphEntry)
751     deriving (Show)
752
753 lookupHeapGraph :: HeapGraphIndex -> HeapGraph -> Maybe HeapGraphEntry
754 lookupHeapGraph i (HeapGraph m) = M.lookup i m
755
756 heapGraphRoot :: HeapGraphIndex
757 heapGraphRoot = 0
758
759 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
760 -- than the given limit. The initial value has index 'heapGraphRoot'.
761 buildHeapGraph :: Int -> Box -> IO HeapGraph
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     ppBinbingMap = 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 = ppBinbingMap 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