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