69f89d2779d5a1add5012d7aa06d16f1a4f1d42a
[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     annotateHeapGraph,
41     updateHeapGraph,
42     ppHeapGraph,
43     -- * Boxes
44     Box(..),
45     asBox,
46     areBoxesEqual,
47     -- * Disassembler
48     disassembleBCO,
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 Foreign          hiding ( unsafePerformIO )
62 import Numeric          ( showHex )
63 import Data.Char
64 import Data.List
65 import Data.Maybe       ( catMaybes )
66 import Data.Monoid      ( Monoid, (<>), mempty )
67 import Data.Functor
68 import Data.Function
69 import Data.Foldable    ( Foldable )
70 import qualified Data.Foldable as F
71 import Data.Traversable ( Traversable )
72 import qualified Data.Traversable as T
73 import qualified Data.IntMap as M
74 import Control.Monad
75 import Control.Monad.Trans.State
76 import Control.Monad.Trans.Class
77 import Control.Monad.IO.Class
78 import Control.Monad.Trans.Writer.Strict
79 import Control.Exception.Base (evaluate)
80
81 import GHC.Disassembler
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 -- | Boxes can be compared, but this is not pure, as different heap objects can,
111 -- after garbage collection, become the same object.
112 areBoxesEqual :: Box -> Box -> IO Bool
113 areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
114     0# -> return False
115     _  -> return True
116
117
118 {-|
119   This takes an arbitrary value and puts it into a box. Note that calls like
120
121   > asBox (head list) 
122
123   will put the thunk \"head list\" into the box, /not/ the element at the head
124   of the list. For that, use careful case expressions:
125
126   > case list of x:_ -> asBox x
127 -}
128 asBox :: a -> Box
129 asBox x = Box (unsafeCoerce# x)
130
131 {-
132    StgInfoTable parsing derived from ByteCodeItbls.lhs
133    Removed the code parameter for now
134    Replaced Type by an enumeration
135    Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
136  -}
137
138 {-| This is a somewhat faithful representation of an info table. See
139    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>
140    for more details on this data structure. Note that the 'Storable' instance
141    provided here does _not_ support writing.
142  -}
143 data StgInfoTable = StgInfoTable {
144    ptrs   :: HalfWord,
145    nptrs  :: HalfWord,
146    tipe   :: ClosureType,
147    srtlen :: HalfWord
148   }
149   deriving (Show)
150
151 instance Storable StgInfoTable where
152
153    sizeOf itbl 
154       = sum
155         [
156          fieldSz ptrs itbl,
157          fieldSz nptrs itbl,
158          sizeOf (undefined :: HalfWord),
159          fieldSz srtlen itbl
160         ]
161
162    alignment _ 
163       = wORD_SIZE
164
165    poke _a0 _itbl
166       = error "Storable StgInfoTable is read-only"
167
168    peek a0
169       = flip (evalStateT) (castPtr a0)
170       $ do
171            ptrs'   <- load
172            nptrs'  <- load
173            tipe'   <- load
174            srtlen' <- load
175            return 
176               StgInfoTable { 
177                  ptrs   = ptrs',
178                  nptrs  = nptrs',
179                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
180                  srtlen = srtlen'
181               }
182
183 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
184 fieldSz sel x = sizeOf (sel x)
185
186 load :: Storable a => PtrIO a
187 load = do addr <- advance
188           lift (peek addr)
189
190 type PtrIO = StateT (Ptr Word8) IO
191
192 advance :: Storable a => PtrIO (Ptr a)
193 advance = StateT adv where
194     adv addr = case castPtr addr of { addrCast -> return
195         (addrCast, addr `plusPtr` sizeOfPointee addrCast) }
196
197 sizeOfPointee :: (Storable a) => Ptr a -> Int
198 sizeOfPointee addr = sizeOf (typeHack addr)
199     where typeHack = undefined :: Ptr a -> a
200
201 {-
202    Data Type representing Closures
203  -}
204
205
206 {-| A closure type enumeration, in order matching the actual value on the heap.
207    Needs to be synchronized with
208    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>
209  -}
210 data ClosureType =
211           INVALID_OBJECT
212         | CONSTR
213         | CONSTR_1_0
214         | CONSTR_0_1
215         | CONSTR_2_0
216         | CONSTR_1_1
217         | CONSTR_0_2
218         | CONSTR_STATIC
219         | CONSTR_NOCAF_STATIC
220         | FUN
221         | FUN_1_0
222         | FUN_0_1
223         | FUN_2_0
224         | FUN_1_1
225         | FUN_0_2
226         | FUN_STATIC
227         | THUNK
228         | THUNK_1_0
229         | THUNK_0_1
230         | THUNK_2_0
231         | THUNK_1_1
232         | THUNK_0_2
233         | THUNK_STATIC
234         | THUNK_SELECTOR
235         | BCO
236         | AP
237         | PAP
238         | AP_STACK
239         | IND
240         | IND_PERM
241         | IND_STATIC
242         | RET_BCO
243         | RET_SMALL
244         | RET_BIG
245         | RET_DYN
246         | RET_FUN
247         | UPDATE_FRAME
248         | CATCH_FRAME
249         | UNDERFLOW_FRAME
250         | STOP_FRAME
251         | BLOCKING_QUEUE
252         | BLACKHOLE
253         | MVAR_CLEAN
254         | MVAR_DIRTY
255         | ARR_WORDS
256         | MUT_ARR_PTRS_CLEAN
257         | MUT_ARR_PTRS_DIRTY
258         | MUT_ARR_PTRS_FROZEN0
259         | MUT_ARR_PTRS_FROZEN
260         | MUT_VAR_CLEAN
261         | MUT_VAR_DIRTY
262         | WEAK
263         | PRIM
264         | MUT_PRIM
265         | TSO
266         | STACK
267         | TREC_CHUNK
268         | ATOMICALLY_FRAME
269         | CATCH_RETRY_FRAME
270         | CATCH_STM_FRAME
271         | WHITEHOLE
272  deriving (Show, Eq, Enum, Ord)
273
274 {-| This is the main data type of this module, representing a Haskell value on
275   the heap. This reflects
276   <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
277
278   The data type is parametrized by the type to store references in, which
279   is usually a 'Box' with appropriate type synonym 'Closure'.
280  -}
281 data GenClosure b =
282     ConsClosure {
283         info         :: StgInfoTable 
284         , ptrArgs    :: [b]
285         , dataArgs   :: [Word]
286         , pkg        :: String
287         , modl       :: String
288         , name       :: String
289     } |
290     ThunkClosure {
291         info         :: StgInfoTable 
292         , ptrArgs    :: [b]
293         , dataArgs   :: [Word]
294     } |
295     SelectorClosure {
296         info         :: StgInfoTable 
297         , selectee   :: b
298     } |
299     IndClosure {
300         info         :: StgInfoTable 
301         , indirectee   :: b
302     } |
303     BlackholeClosure {
304         info         :: StgInfoTable 
305         , indirectee   :: b
306     } |
307     -- In GHCi, if Linker.h would allow a reverse looup, we could for exported
308     -- functions fun actually find the name here.
309     -- At least the other direction works via "lookupSymbol
310     -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
311     APClosure {
312         info         :: StgInfoTable 
313         , arity      :: HalfWord
314         , n_args     :: HalfWord
315         , fun        :: b
316         , payload    :: [b]
317     } |
318     PAPClosure {
319         info         :: StgInfoTable 
320         , arity      :: HalfWord
321         , n_args     :: HalfWord
322         , fun        :: b
323         , payload    :: [b]
324     } |
325     APStackClosure {
326         info         :: StgInfoTable 
327         , fun        :: b
328         , payload    :: [b]
329     } |
330     BCOClosure {
331         info         :: StgInfoTable 
332         , instrs     :: b
333         , literals   :: b
334         , bcoptrs    :: b
335         , arity      :: HalfWord
336         , size       :: HalfWord
337         , bitmap     :: Word
338     } |
339     ArrWordsClosure {
340         info         :: StgInfoTable 
341         , bytes      :: Word
342         , arrWords   :: [Word]
343     } |
344     MutArrClosure {
345         info         :: StgInfoTable 
346         , mccPtrs    :: Word
347         , mccSize    :: Word
348         , mccPayload :: [b]
349         -- Card table ignored
350     } |
351     MutVarClosure {
352         info         :: StgInfoTable 
353         , var        :: b
354     } |
355     MVarClosure {
356         info         :: StgInfoTable 
357         , queueHead  :: b
358         , queueTail  :: b
359         , value      :: b
360     } |
361     FunClosure {
362         info         :: StgInfoTable 
363         , ptrArgs    :: [b]
364         , dataArgs   :: [Word]
365     } |
366     BlockingQueueClosure {
367         info         :: StgInfoTable 
368         , link       :: b
369         , blackHole  :: b
370         , owner      :: b
371         , queue      :: b
372     } |
373     OtherClosure {
374         info         :: StgInfoTable 
375         , hvalues    :: [b]
376         , rawWords   :: [Word]
377     } |
378     UnsupportedClosure {
379         info         :: StgInfoTable 
380     }
381  deriving (Show, Functor, Foldable, Traversable)
382
383
384 type Closure = GenClosure Box
385
386 -- | For generic code, this function returns all referenced closures. 
387 allPtrs :: GenClosure b -> [b]
388 allPtrs (ConsClosure {..}) = ptrArgs
389 allPtrs (ThunkClosure {..}) = ptrArgs
390 allPtrs (SelectorClosure {..}) = [selectee]
391 allPtrs (IndClosure {..}) = [indirectee]
392 allPtrs (BlackholeClosure {..}) = [indirectee]
393 allPtrs (APClosure {..}) = fun:payload
394 allPtrs (PAPClosure {..}) = fun:payload
395 allPtrs (APStackClosure {..}) = fun:payload
396 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
397 allPtrs (ArrWordsClosure {..}) = []
398 allPtrs (MutArrClosure {..}) = mccPayload
399 allPtrs (MutVarClosure {..}) = [var]
400 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
401 allPtrs (FunClosure {..}) = ptrArgs
402 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
403 allPtrs (OtherClosure {..}) = hvalues
404 allPtrs (UnsupportedClosure {..}) = []
405
406
407 #ifdef PRIM_SUPPORTS_ANY
408 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
409 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
410 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
411 #else
412 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
413 -- accepted
414
415 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
416 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
417
418 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
419
420 -- This is a datatype that has the same layout as Ptr, so that by
421 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
422 data Ptr' a = Ptr' a
423
424 aToWord# :: Any -> Word#
425 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
426
427 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
428 slurpClosure# a = slurpClosure'# (aToWord# a)
429
430 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
431 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
432 #endif
433
434 --pClosure x = do
435 --    getClosure x >>= print
436
437 -- | This returns the raw representation of the given argument. The second
438 -- component of the triple are the words on the heap, and the third component
439 -- are those words that are actually pointers. Once back in Haskell word, the
440 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
441 -- 'Box' will still point to the correct value.
442 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
443 getClosureRaw x =
444     case slurpClosure# (unsafeCoerce# x) of
445         (# iptr, dat, ptrs #) -> do
446             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
447                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
448                 pelems = I# (sizeofArray# ptrs) 
449                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
450             -- This is just for good measure, and seems to be not important.
451             mapM_ evaluate ptrList
452             -- The following deep evaluation is crucial to avoid crashes (but why)?
453             mapM_ evaluate rawWords
454             return (Ptr iptr, rawWords, ptrList)
455
456 -- From compiler/ghci/RtClosureInspect.hs
457 amap' :: (t -> b) -> Array Int t -> [b]
458 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
459     where g (I# i#) = case indexArray# arr# i# of
460                           (# e #) -> f e
461
462 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
463 -- compiler/ghci/DebuggerUtils.hs
464 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
465 dataConInfoPtrToNames ptr = do
466     conDescAddress <- getConDescAddress ptr
467     wl <- peekArray0 0 conDescAddress
468     let (pkg, modl, name) = parse wl
469     return (b2s pkg, b2s modl, b2s name)
470   where
471     b2s :: [Word8] -> String
472     b2s = fmap (chr . fromIntegral)
473
474     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
475     getConDescAddress ptr'
476       | True = do
477           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
478           return $ (ptr' `plusPtr` stdInfoTableSizeB)
479                     `plusPtr` (fromIntegral (offsetToString :: Word))
480     -- This is code for !ghciTablesNextToCode: 
481     {-
482       | otherwise = peek . intPtrToPtr
483                       . (+ fromIntegral
484                             stdInfoTableSizeB)
485                         . ptrToIntPtr $ ptr
486     -}
487
488     -- hmmmmmm. Is there any way to tell this?
489     opt_SccProfilingOn = False
490
491     stdInfoTableSizeW :: Int
492     -- The size of a standard info table varies with profiling/ticky etc,
493     -- so we can't get it from Constants
494     -- It must vary in sync with mkStdInfoTable
495     stdInfoTableSizeW
496       = size_fixed + size_prof
497       where
498         size_fixed = 2  -- layout, type
499         size_prof | opt_SccProfilingOn = 2
500                   | otherwise    = 0
501
502     stdInfoTableSizeB :: Int
503     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
504
505 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
506 parse :: [Word8] -> ([Word8], [Word8], [Word8])
507 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
508                 --then (error . concat)
509                 --        ["getConDescAddress:parse:"
510                 --        ,"(not . all (>0) . fmap le"
511                 --        ,"ngth $ [pkg,modl,occ]"]
512                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
513                 else (pkg, modl, occ)
514 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
515   where
516         (pkg, rest1) = break (== fromIntegral (ord ':')) input
517         (modl, occ)
518             = (concat $ intersperse [dot] $ reverse modWords, occWord)
519             where
520             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
521                                     --then error "getConDescAddress:parse:length rest1 < 1"
522                                     then parseModOcc [] []
523                                     else parseModOcc [] (tail rest1)
524         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
525         dot = fromIntegral (ord '.')
526         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
527         parseModOcc acc str
528             = case break (== dot) str of
529                 (top, []) -> (acc, top)
530                 (top, _:bot) -> parseModOcc (top : acc) bot
531
532
533 -- | This function returns parsed heap representation of the argument _at this
534 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
535 -- Beware when passing something to this function, the same caveats as for
536 -- 'asBox' apply.
537 getClosureData :: a -> IO Closure
538 getClosureData x = do
539     (iptr, wds, ptrs) <- getClosureRaw x
540     itbl <- peek iptr
541     case tipe itbl of 
542         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
543             (pkg, modl, name) <- dataConInfoPtrToNames iptr
544             if modl == "ByteCodeInstr" && name == "BreakInfo"
545               then return $ UnsupportedClosure itbl
546               else return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
547
548         t | t >= THUNK && t <= THUNK_STATIC -> do
549             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
550
551         t | t >= FUN && t <= FUN_STATIC -> do
552             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
553
554         AP ->
555             return $ APClosure itbl 
556                 (fromIntegral $ wds !! 2)
557                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
558                 (head ptrs) (tail ptrs)
559
560         PAP ->
561             return $ PAPClosure itbl 
562                 (fromIntegral $ wds !! 2)
563                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
564                 (head ptrs) (tail ptrs)
565
566         AP_STACK ->
567             return $ APStackClosure itbl (head ptrs) (tail ptrs)
568
569         THUNK_SELECTOR ->
570             return $ SelectorClosure itbl (head ptrs)
571
572         IND ->
573             return $ IndClosure itbl (head ptrs)
574         IND_STATIC ->
575             return $ IndClosure itbl (head ptrs)
576         BLACKHOLE ->
577             return $ BlackholeClosure itbl (head ptrs)
578
579         BCO ->
580             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
581                 (fromIntegral $ wds !! 4)
582                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
583                 (wds !! 5)
584
585         ARR_WORDS ->
586             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
587
588         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
589             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
590
591         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
592             return $ MutVarClosure itbl (head ptrs)
593
594         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
595             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
596
597         BLOCKING_QUEUE ->
598             return $ OtherClosure itbl ptrs wds
599         --    return $ BlockingQueueClosure itbl
600         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
601
602         --  return $ OtherClosure itbl ptrs wds
603         --
604         _ ->
605             return $ UnsupportedClosure itbl
606
607 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
608 getBoxedClosureData :: Box -> IO Closure
609 getBoxedClosureData (Box a) = getClosureData a
610
611
612 isChar :: GenClosure b -> Maybe Char
613 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
614 isChar _ = Nothing
615
616 isCons :: GenClosure b -> Maybe (b, b)
617 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
618 isCons _ = Nothing
619
620 isTup :: GenClosure b -> Maybe [b]
621 isTup (ConsClosure { dataArgs = [], ..}) =
622     if length name >= 3 &&
623        head name == '(' && last name == ')' &&
624        all (==',') (tail (init name))
625     then Just ptrArgs else Nothing
626 isTup _ = Nothing
627
628
629 isNil :: GenClosure b -> Bool
630 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
631 isNil _ = False
632
633 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
634 -- It assumes that for the included boxes, you already replaced them by Strings
635 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
636 --
637 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
638 ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
639 ppClosure showBox prec c = case c of
640     _ | Just ch <- isChar c -> app $
641         ["C#", show ch]
642     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
643         showBox 5 h ++ " : " ++ showBox 4 t
644     _ | Just vs <- isTup c ->
645         "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"
646     ConsClosure {..} -> app $
647         name : map (showBox 10) ptrArgs ++ map show dataArgs
648     ThunkClosure {..} -> app $
649         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
650     SelectorClosure {..} -> app
651         ["_sel", showBox 10 selectee]
652     IndClosure {..} -> app
653         ["_ind", showBox 10 indirectee]
654     BlackholeClosure {..} -> app
655         ["_bh",  showBox 10 indirectee]
656     APClosure {..} -> app $ map (showBox 10) $
657         fun : payload
658     PAPClosure {..} -> app $ map (showBox 10) $
659         fun : payload
660     APStackClosure {..} -> app $ map (showBox 10) $
661         fun : payload
662     BCOClosure {..} -> app
663         ["_bco"]
664     ArrWordsClosure {..} -> app
665         ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ]
666     MutArrClosure {..} -> app 
667         ["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
668     MutVarClosure {..} -> app $
669         ["_mutVar", (showBox 10) var]
670     MVarClosure {..} -> app $
671         ["MVar", (showBox 10) value]
672     FunClosure {..} -> 
673         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
674     BlockingQueueClosure {..} -> 
675         "_blockingQueue"
676     OtherClosure {..} ->
677         "_other"
678     UnsupportedClosure {..} ->
679         "_unsupported"
680   where
681     app [a] = a  ++ "()"
682     app xs = addBraces (10 <= prec) (intercalate " " xs)
683
684     shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs
685     
686 {- $heapmap
687
688    For more global views of the heap, you can use heap maps. These come in
689    variations, either a trees or as graphs, depending on
690    whether you want to detect cycles and sharing or not.
691
692    The entries of a 'HeapGraph' can be annotated with arbitrary values. Most
693    operations expect this to be in the 'Monoid' class: They use 'mempty' to
694    annotate closures added because the passed values reference them, and they
695    use 'mappend' to combine the annotations when two values conincide, e.g. 
696    during 'updateHeapGraph'.
697 -}
698
699 -- | Heap maps as tree, i.e. no sharing, no cycles.
700 data HeapTree = HeapTree Box (GenClosure HeapTree) | EndOfHeapTree
701
702 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
703 heapTreeClosure (HeapTree _ c) = Just c
704 heapTreeClosure EndOfHeapTree = Nothing
705
706 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
707 -- that prevents it from running ad infinitum for cyclic or infinite
708 -- structures.
709 buildHeapTree :: Int -> Box -> IO HeapTree
710 buildHeapTree 0 _ = do
711     return $ EndOfHeapTree
712 buildHeapTree n b = do
713     c <- getBoxedClosureData b
714     c' <- T.mapM (buildHeapTree (n-1)) c
715     return $ HeapTree b c'
716
717 -- | Pretty-Printing a heap Tree
718 -- 
719 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
720 -- unevaluated expression depending on the command line argument.
721 --
722 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
723 ppHeapTree :: HeapTree -> String
724 ppHeapTree = go 0
725   where
726     go _ EndOfHeapTree = "..."
727     go prec t@(HeapTree _ c')
728         | Just s <- isHeapTreeString t = show s
729         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
730         | Just bc <- disassembleBCO heapTreeClosure c'
731                                        = app ("_bco" : map (go 10) (concatMap F.toList bc))
732         | otherwise                    = ppClosure go prec c'
733       where 
734         app [a] = a ++ "()"
735         app xs = addBraces (10 <= prec) (intercalate " " xs)
736
737 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
738 isHeapTreeList tree = do
739     c <- heapTreeClosure tree
740     if isNil c
741       then return []
742       else do
743         (h,t) <- isCons c
744         t' <- isHeapTreeList t
745         return $ (:) h t'
746
747 isHeapTreeString :: HeapTree -> Maybe String
748 isHeapTreeString t = do
749     list <- isHeapTreeList t
750     -- We do not want to print empty lists as "" as we do not know that they
751     -- are really strings.
752     if (null list)
753         then Nothing
754         else mapM (isChar <=< heapTreeClosure) list
755
756 -- | For heap graphs, i.e. data structures that also represent sharing and
757 -- cyclic structures, these are the entries. If the referenced value is
758 -- @Nothing@, then we do not have that value in the map, most likely due to
759 -- exceeding the recursion bound passed to 'buildHeapGraph'.
760 --
761 -- Besides a pointer to the stored value and the closure representation we
762 -- also keep track of whether the value was still alive at the last update of the 
763 -- heap graph. In addition we have a slot for arbitrary data, for the user's convenience.
764 data HeapGraphEntry a = HeapGraphEntry {
765         hgeBox :: Box,
766         hgeClosure :: GenClosure (Maybe HeapGraphIndex),
767         hgeLive :: Bool,
768         hgeData :: a}
769     deriving (Show, Functor)
770 type HeapGraphIndex = Int
771
772 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
773 -- as the internal representation may change. Nevertheless, we export it here:
774 -- Sometimes the user knows better what he needs than we do.
775 newtype HeapGraph a = HeapGraph (M.IntMap (HeapGraphEntry a))
776     deriving (Show)
777
778 lookupHeapGraph :: HeapGraphIndex -> (HeapGraph a) -> Maybe (HeapGraphEntry a)
779 lookupHeapGraph i (HeapGraph m) = M.lookup i m
780
781 heapGraphRoot :: HeapGraphIndex
782 heapGraphRoot = 0
783
784 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
785 -- than the given limit. The initial value has index 'heapGraphRoot'.
786 buildHeapGraph
787    :: Monoid a
788    => Int -- ^ Search limit
789    -> a -- ^ Data value for the root
790    -> Box -- ^ The value to start with
791    -> IO (HeapGraph a)
792 buildHeapGraph limit rootD initialBox =
793     fst <$> multiBuildHeapGraph limit [(rootD, initialBox)]
794
795 -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
796 --   further than the given limit.
797 --
798 --   Returns the 'HeapGraph' and the indices of initial values. The arbitrary
799 --   type @a@ can be used to make the connection between the input and the
800 --   resulting list of indices, and to store additional data.
801 multiBuildHeapGraph
802     :: Monoid a
803     => Int -- ^ Search limit
804     -> [(a, Box)] -- ^ Starting values with associated data entry
805     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
806 multiBuildHeapGraph limit = generalBuildHeapGraph limit (HeapGraph M.empty)
807
808 -- | Adds an entry to an existing 'HeapGraph'.
809 --
810 --   Returns the updated 'HeapGraph' and the index of the added value.
811 addHeapGraph
812     :: Monoid a 
813     => Int -- ^ Search limit
814     -> a -- ^ Data to be stored with the added value
815     -> Box -- ^ Value to add to the graph
816     -> HeapGraph a -- ^ Graph to extend
817     -> IO (HeapGraphIndex, HeapGraph a)
818 addHeapGraph limit d box hg = do
819     (hg', [(_,i)]) <- generalBuildHeapGraph limit hg [(d,box)]
820     return (i, hg')
821
822 -- | Adds the given annotation to the entry at the given index, using the
823 -- 'mappend' operation of its 'Monoid' instance.
824 annotateHeapGraph :: Monoid a => a -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
825 annotateHeapGraph d i (HeapGraph hg) = HeapGraph $ M.update go i hg
826   where
827     go hge = Just $ hge { hgeData = hgeData hge <> d }
828
829 generalBuildHeapGraph 
830     :: Monoid a
831     => Int
832     -> HeapGraph a
833     -> [(a,Box)]
834     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
835 generalBuildHeapGraph limit _ _ | limit <= 0 = error "buildHeapGraph: limit has to be positive"
836 generalBuildHeapGraph limit (HeapGraph hg) addBoxes = do
837     -- First collect all boxes from the existing heap graph
838     let boxList = [ (hgeBox hge, i) | (i, hge) <- M.toList hg ]
839         indices | M.null hg = [0..]
840                 | otherwise = [1 + fst (M.findMax hg)..]
841         
842         initialState = (boxList, indices, [])
843     -- It is ok to use the Monoid (IntMap a) instance here, because
844     -- we will, besides the first time, use 'tell' only to add singletons not
845     -- already there
846     (is, hg') <- runWriterT (evalStateT run initialState)
847     -- Now add the annotations of the root values
848     let hg'' = foldl' (flip (uncurry annotateHeapGraph)) (HeapGraph hg') is
849     return (hg'', is)
850   where
851     run = do
852         lift $ tell hg -- Start with the initial map
853         forM addBoxes $ \(d, b) -> do
854             -- Cannot fail, as limit is not zero here
855             Just i <- add limit b
856             return (d, i)
857
858     add 0  _ = return Nothing
859     add n b = do
860         -- If the box is in the map, return the index
861         (existing,_,_) <- get
862         mbI <- liftIO $ findM (areBoxesEqual b . fst) existing
863         case mbI of
864             Just (_,i) -> return $ Just i
865             Nothing -> do
866                 -- Otherwise, allocate a new index
867                 i <- nextI
868                 -- And register it
869                 modify (\(x,y,z) -> ((b,i):x, y, z))
870                 -- Look up the closure
871                 c <- liftIO $ getBoxedClosureData b
872                 -- Find indicies for all boxes contained in the map
873                 c' <- T.mapM (add (n-1)) c
874                 -- Add add the resulting closure to the map
875                 lift $ tell (M.singleton i (HeapGraphEntry b c' True mempty))
876                 return $ Just i
877     nextI = do
878         i <- gets (head . (\(_,b,_) -> b))
879         modify (\(a,b,c) -> (a, tail b, c))
880         return i
881
882 -- | This function updates a heap graph to reflect the current state of
883 -- closures on the heap, conforming to the following specification.
884 --
885 --  * Every entry whose value has been garbage collected by now is marked as
886 --    dead by setting 'hgeLive' to @False@
887 --  * Every entry whose value is still live gets the 'hgeClosure' field updated
888 --    and newly referenced closures are, up to the given depth, added to the graph.
889 --  * A map mapping previous indicies to the corresponding new indicies is returned as well.
890 --  * The closure at 'heapGraphRoot' stays at 'heapGraphRoot'
891 updateHeapGraph :: Monoid a => Int -> HeapGraph a -> IO (HeapGraph a, HeapGraphIndex -> HeapGraphIndex)
892 updateHeapGraph limit (HeapGraph startHG) = do
893     (hg', indexMap) <- runWriterT $ foldM go (HeapGraph M.empty) (M.toList startHG)
894     return (hg', (M.!) indexMap)
895   where
896     go hg (i, hge) = do
897         (j, hg') <- liftIO $ addHeapGraph limit (hgeData hge) (hgeBox hge) hg
898         tell (M.singleton i j)
899         return hg'
900                 
901 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
902 -- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
903 --
904 -- >let x1 = "Ki"
905 -- >    x6 = C# 'H' : C# 'o' : x6
906 -- >in (x1,x1,x6)
907 ppHeapGraph :: HeapGraph a -> String
908 ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
909   where
910     -- All variables occuring more than once
911     bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot] 
912
913     letWrapper =
914         if null bindings
915         then ""
916         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin "
917
918     bindingLetter i = case hgeClosure (iToE i) of
919         ThunkClosure {..} -> 't'
920         SelectorClosure {..} -> 't'
921         APClosure {..} -> 't'
922         PAPClosure {..} -> 'f'
923         BCOClosure {..} -> 't'
924         FunClosure {..} -> 'f'
925         _ -> 'x'
926
927     ppBindingMap = M.fromList $
928         concat $
929         map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $
930         groupBy ((==) `on` snd) $ 
931         sortBy (compare `on` snd)
932         [ (i, bindingLetter i) | i <- bindings ]
933
934     ppVar i = ppBindingMap M.! i
935     ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)
936
937     ppEntry prec hge
938         | Just s <- isString hge = show s
939         | Just l <- isList hge   = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
940         | Just bc <- disassembleBCO (fmap (hgeClosure . iToE)) (hgeClosure hge)
941                                        = app ("_bco" : map (ppRef 10) (concatMap F.toList bc))
942         | otherwise = ppClosure ppRef prec (hgeClosure hge)
943       where
944         app [a] = a  ++ "()"
945         app xs = addBraces (10 <= prec) (intercalate " " xs)
946
947     ppRef _ Nothing = "..."
948     ppRef prec (Just i) | i `elem` bindings = ppVar i
949                         | otherwise = ppEntry prec (iToE i) 
950     iToE i = m M.! i
951
952     iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
953
954     isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
955     isList hge = 
956         if isNil (hgeClosure hge)
957           then return []
958           else do
959             (h,t) <- isCons (hgeClosure hge)
960             ti <- t
961             e <- iToUnboundE ti
962             t' <- isList e
963             return $ (:) h t'
964
965     isString :: HeapGraphEntry a -> Maybe String
966     isString e = do
967         list <- isList e
968         -- We do not want to print empty lists as "" as we do not know that they
969         -- are really strings.
970         if (null list)
971             then Nothing
972             else mapM (isChar . hgeClosure <=< iToUnboundE <=< id) list
973
974
975 -- | In the given HeapMap, list all indices that are used more than once. The
976 -- second parameter adds external references, commonly @[heapGraphRoot]@.
977 boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
978 boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $
979      roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m)
980
981 -- | This function integrates the disassembler in "GHC.Disassembler". The first
982 -- argument should a function that dereferences the pointer in the closure to a
983 -- closure.
984 --
985 -- If any of these return 'Nothing', then 'disassembleBCO' returns Nothing
986 disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
987 disassembleBCO deref (BCOClosure {..}) = do
988     opsC <- deref instrs
989     litsC <- deref literals
990     ptrsC  <- deref bcoptrs
991     return $ disassemble (mccPayload ptrsC) (arrWords litsC) (toBytes (bytes opsC) (arrWords opsC))
992 disassembleBCO _ _ = Nothing
993
994 -- Utilities
995
996 findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
997 findM _p [] = return Nothing
998 findM p (x:xs) = do
999     b <- p x
1000     if b then return (Just x) else findM p xs
1001
1002 addBraces :: Bool -> String -> String
1003 addBraces True t = "(" ++ t ++ ")"
1004 addBraces False t = t
1005
1006 braceize :: [String] -> String
1007 braceize [] = ""
1008 braceize xs = "{" ++ intercalate "," xs ++ "}"