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