Also evaluation nelems seems to help some more
[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, void )
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             -- This seems to be required to avoid crashes as well
453             void $ evaluate nelems
454             -- The following deep evaluation is crucial to avoid crashes (but why)?
455             mapM_ evaluate rawWords
456             return (Ptr iptr, rawWords, ptrList)
457
458 -- From compiler/ghci/RtClosureInspect.hs
459 amap' :: (t -> b) -> Array Int t -> [b]
460 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
461     where g (I# i#) = case indexArray# arr# i# of
462                           (# e #) -> f e
463
464 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
465 -- compiler/ghci/DebuggerUtils.hs
466 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
467 dataConInfoPtrToNames ptr = do
468     conDescAddress <- getConDescAddress ptr
469     wl <- peekArray0 0 conDescAddress
470     let (pkg, modl, name) = parse wl
471     return (b2s pkg, b2s modl, b2s name)
472   where
473     b2s :: [Word8] -> String
474     b2s = fmap (chr . fromIntegral)
475
476     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
477     getConDescAddress ptr'
478       | True = do
479           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
480           return $ (ptr' `plusPtr` stdInfoTableSizeB)
481                     `plusPtr` (fromIntegral (offsetToString :: Word))
482     -- This is code for !ghciTablesNextToCode: 
483     {-
484       | otherwise = peek . intPtrToPtr
485                       . (+ fromIntegral
486                             stdInfoTableSizeB)
487                         . ptrToIntPtr $ ptr
488     -}
489
490     -- hmmmmmm. Is there any way to tell this?
491     opt_SccProfilingOn = False
492
493     stdInfoTableSizeW :: Int
494     -- The size of a standard info table varies with profiling/ticky etc,
495     -- so we can't get it from Constants
496     -- It must vary in sync with mkStdInfoTable
497     stdInfoTableSizeW
498       = size_fixed + size_prof
499       where
500         size_fixed = 2  -- layout, type
501         size_prof | opt_SccProfilingOn = 2
502                   | otherwise    = 0
503
504     stdInfoTableSizeB :: Int
505     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
506
507 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
508 parse :: [Word8] -> ([Word8], [Word8], [Word8])
509 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
510                 --then (error . concat)
511                 --        ["getConDescAddress:parse:"
512                 --        ,"(not . all (>0) . fmap le"
513                 --        ,"ngth $ [pkg,modl,occ]"]
514                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
515                 else (pkg, modl, occ)
516 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
517   where
518         (pkg, rest1) = break (== fromIntegral (ord ':')) input
519         (modl, occ)
520             = (concat $ intersperse [dot] $ reverse modWords, occWord)
521             where
522             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
523                                     --then error "getConDescAddress:parse:length rest1 < 1"
524                                     then parseModOcc [] []
525                                     else parseModOcc [] (tail rest1)
526         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
527         dot = fromIntegral (ord '.')
528         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
529         parseModOcc acc str
530             = case break (== dot) str of
531                 (top, []) -> (acc, top)
532                 (top, _:bot) -> parseModOcc (top : acc) bot
533
534
535 -- | This function returns parsed heap representation of the argument _at this
536 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
537 -- Beware when passing something to this function, the same caveats as for
538 -- 'asBox' apply.
539 getClosureData :: a -> IO Closure
540 getClosureData x = do
541     (iptr, wds, ptrs) <- getClosureRaw x
542     itbl <- peek iptr
543     case tipe itbl of 
544         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
545             (pkg, modl, name) <- dataConInfoPtrToNames iptr
546             if modl == "ByteCodeInstr" && name == "BreakInfo"
547               then return $ UnsupportedClosure itbl
548               else return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
549
550         t | t >= THUNK && t <= THUNK_STATIC -> do
551             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
552
553         t | t >= FUN && t <= FUN_STATIC -> do
554             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
555
556         AP ->
557             return $ APClosure itbl 
558                 (fromIntegral $ wds !! 2)
559                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
560                 (head ptrs) (tail ptrs)
561
562         PAP ->
563             return $ PAPClosure itbl 
564                 (fromIntegral $ wds !! 2)
565                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
566                 (head ptrs) (tail ptrs)
567
568         AP_STACK ->
569             return $ APStackClosure itbl (head ptrs) (tail ptrs)
570
571         THUNK_SELECTOR ->
572             return $ SelectorClosure itbl (head ptrs)
573
574         IND ->
575             return $ IndClosure itbl (head ptrs)
576         IND_STATIC ->
577             return $ IndClosure itbl (head ptrs)
578         BLACKHOLE ->
579             return $ BlackholeClosure itbl (head ptrs)
580
581         BCO ->
582             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
583                 (fromIntegral $ wds !! 4)
584                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
585                 (wds !! 5)
586
587         ARR_WORDS ->
588             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
589
590         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
591             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
592
593         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
594             return $ MutVarClosure itbl (head ptrs)
595
596         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
597             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
598
599         BLOCKING_QUEUE ->
600             return $ OtherClosure itbl ptrs wds
601         --    return $ BlockingQueueClosure itbl
602         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
603
604         --  return $ OtherClosure itbl ptrs wds
605         --
606         _ ->
607             return $ UnsupportedClosure itbl
608
609 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
610 getBoxedClosureData :: Box -> IO Closure
611 getBoxedClosureData (Box a) = getClosureData a
612
613
614 isChar :: GenClosure b -> Maybe Char
615 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
616 isChar _ = Nothing
617
618 isCons :: GenClosure b -> Maybe (b, b)
619 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
620 isCons _ = Nothing
621
622 isTup :: GenClosure b -> Maybe [b]
623 isTup (ConsClosure { dataArgs = [], ..}) =
624     if length name >= 3 &&
625        head name == '(' && last name == ')' &&
626        all (==',') (tail (init name))
627     then Just ptrArgs else Nothing
628 isTup _ = Nothing
629
630
631 isNil :: GenClosure b -> Bool
632 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
633 isNil _ = False
634
635 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
636 -- It assumes that for the included boxes, you already replaced them by Strings
637 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
638 --
639 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
640 ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
641 ppClosure showBox prec c = case c of
642     _ | Just ch <- isChar c -> app $
643         ["C#", show ch]
644     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
645         showBox 5 h ++ " : " ++ showBox 4 t
646     _ | Just vs <- isTup c ->
647         "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"
648     ConsClosure {..} -> app $
649         name : map (showBox 10) ptrArgs ++ map show dataArgs
650     ThunkClosure {..} -> app $
651         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
652     SelectorClosure {..} -> app
653         ["_sel", showBox 10 selectee]
654     IndClosure {..} -> app
655         ["_ind", showBox 10 indirectee]
656     BlackholeClosure {..} -> app
657         ["_bh",  showBox 10 indirectee]
658     APClosure {..} -> app $ map (showBox 10) $
659         fun : payload
660     PAPClosure {..} -> app $ map (showBox 10) $
661         fun : payload
662     APStackClosure {..} -> app $ map (showBox 10) $
663         fun : payload
664     BCOClosure {..} -> app
665         ["_bco"]
666     ArrWordsClosure {..} -> app
667         ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ]
668     MutArrClosure {..} -> app 
669         ["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
670     MutVarClosure {..} -> app $
671         ["_mutVar", (showBox 10) var]
672     MVarClosure {..} -> app $
673         ["MVar", (showBox 10) value]
674     FunClosure {..} -> 
675         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
676     BlockingQueueClosure {..} -> 
677         "_blockingQueue"
678     OtherClosure {..} ->
679         "_other"
680     UnsupportedClosure {..} ->
681         "_unsupported"
682   where
683     app [a] = a  ++ "()"
684     app xs = addBraces (10 <= prec) (intercalate " " xs)
685
686     shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs
687     
688 {- $heapmap
689
690    For more global views of the heap, you can use heap maps. These come in
691    variations, either a trees or as graphs, depending on
692    whether you want to detect cycles and sharing or not.
693
694    The entries of a 'HeapGraph' can be annotated with arbitrary values. Most
695    operations expect this to be in the 'Monoid' class: They use 'mempty' to
696    annotate closures added because the passed values reference them, and they
697    use 'mappend' to combine the annotations when two values conincide, e.g. 
698    during 'updateHeapGraph'.
699 -}
700
701 -- | Heap maps as tree, i.e. no sharing, no cycles.
702 data HeapTree = HeapTree Box (GenClosure HeapTree) | EndOfHeapTree
703
704 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
705 heapTreeClosure (HeapTree _ c) = Just c
706 heapTreeClosure EndOfHeapTree = Nothing
707
708 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
709 -- that prevents it from running ad infinitum for cyclic or infinite
710 -- structures.
711 buildHeapTree :: Int -> Box -> IO HeapTree
712 buildHeapTree 0 _ = do
713     return $ EndOfHeapTree
714 buildHeapTree n b = do
715     c <- getBoxedClosureData b
716     c' <- T.mapM (buildHeapTree (n-1)) c
717     return $ HeapTree b c'
718
719 -- | Pretty-Printing a heap Tree
720 -- 
721 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
722 -- unevaluated expression depending on the command line argument.
723 --
724 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
725 ppHeapTree :: HeapTree -> String
726 ppHeapTree = go 0
727   where
728     go _ EndOfHeapTree = "..."
729     go prec t@(HeapTree _ c')
730         | Just s <- isHeapTreeString t = show s
731         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
732         | Just bc <- disassembleBCO heapTreeClosure c'
733                                        = app ("_bco" : map (go 10) (concatMap F.toList bc))
734         | otherwise                    = ppClosure go prec c'
735       where 
736         app [a] = a ++ "()"
737         app xs = addBraces (10 <= prec) (intercalate " " xs)
738
739 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
740 isHeapTreeList tree = do
741     c <- heapTreeClosure tree
742     if isNil c
743       then return []
744       else do
745         (h,t) <- isCons c
746         t' <- isHeapTreeList t
747         return $ (:) h t'
748
749 isHeapTreeString :: HeapTree -> Maybe String
750 isHeapTreeString t = do
751     list <- isHeapTreeList t
752     -- We do not want to print empty lists as "" as we do not know that they
753     -- are really strings.
754     if (null list)
755         then Nothing
756         else mapM (isChar <=< heapTreeClosure) list
757
758 -- | For heap graphs, i.e. data structures that also represent sharing and
759 -- cyclic structures, these are the entries. If the referenced value is
760 -- @Nothing@, then we do not have that value in the map, most likely due to
761 -- exceeding the recursion bound passed to 'buildHeapGraph'.
762 --
763 -- Besides a pointer to the stored value and the closure representation we
764 -- also keep track of whether the value was still alive at the last update of the 
765 -- heap graph. In addition we have a slot for arbitrary data, for the user's convenience.
766 data HeapGraphEntry a = HeapGraphEntry {
767         hgeBox :: Box,
768         hgeClosure :: GenClosure (Maybe HeapGraphIndex),
769         hgeLive :: Bool,
770         hgeData :: a}
771     deriving (Show, Functor)
772 type HeapGraphIndex = Int
773
774 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
775 -- as the internal representation may change. Nevertheless, we export it here:
776 -- Sometimes the user knows better what he needs than we do.
777 newtype HeapGraph a = HeapGraph (M.IntMap (HeapGraphEntry a))
778     deriving (Show)
779
780 lookupHeapGraph :: HeapGraphIndex -> (HeapGraph a) -> Maybe (HeapGraphEntry a)
781 lookupHeapGraph i (HeapGraph m) = M.lookup i m
782
783 heapGraphRoot :: HeapGraphIndex
784 heapGraphRoot = 0
785
786 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
787 -- than the given limit. The initial value has index 'heapGraphRoot'.
788 buildHeapGraph
789    :: Monoid a
790    => Int -- ^ Search limit
791    -> a -- ^ Data value for the root
792    -> Box -- ^ The value to start with
793    -> IO (HeapGraph a)
794 buildHeapGraph limit rootD initialBox =
795     fst <$> multiBuildHeapGraph limit [(rootD, initialBox)]
796
797 -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
798 --   further than the given limit.
799 --
800 --   Returns the 'HeapGraph' and the indices of initial values. The arbitrary
801 --   type @a@ can be used to make the connection between the input and the
802 --   resulting list of indices, and to store additional data.
803 multiBuildHeapGraph
804     :: Monoid a
805     => Int -- ^ Search limit
806     -> [(a, Box)] -- ^ Starting values with associated data entry
807     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
808 multiBuildHeapGraph limit = generalBuildHeapGraph limit (HeapGraph M.empty)
809
810 -- | Adds an entry to an existing 'HeapGraph'.
811 --
812 --   Returns the updated 'HeapGraph' and the index of the added value.
813 addHeapGraph
814     :: Monoid a 
815     => Int -- ^ Search limit
816     -> a -- ^ Data to be stored with the added value
817     -> Box -- ^ Value to add to the graph
818     -> HeapGraph a -- ^ Graph to extend
819     -> IO (HeapGraphIndex, HeapGraph a)
820 addHeapGraph limit d box hg = do
821     (hg', [(_,i)]) <- generalBuildHeapGraph limit hg [(d,box)]
822     return (i, hg')
823
824 -- | Adds the given annotation to the entry at the given index, using the
825 -- 'mappend' operation of its 'Monoid' instance.
826 annotateHeapGraph :: Monoid a => a -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
827 annotateHeapGraph d i (HeapGraph hg) = HeapGraph $ M.update go i hg
828   where
829     go hge = Just $ hge { hgeData = hgeData hge <> d }
830
831 generalBuildHeapGraph 
832     :: Monoid a
833     => Int
834     -> HeapGraph a
835     -> [(a,Box)]
836     -> IO (HeapGraph a, [(a, HeapGraphIndex)])
837 generalBuildHeapGraph limit _ _ | limit <= 0 = error "buildHeapGraph: limit has to be positive"
838 generalBuildHeapGraph limit (HeapGraph hg) addBoxes = do
839     -- First collect all boxes from the existing heap graph
840     let boxList = [ (hgeBox hge, i) | (i, hge) <- M.toList hg ]
841         indices | M.null hg = [0..]
842                 | otherwise = [1 + fst (M.findMax hg)..]
843         
844         initialState = (boxList, indices, [])
845     -- It is ok to use the Monoid (IntMap a) instance here, because
846     -- we will, besides the first time, use 'tell' only to add singletons not
847     -- already there
848     (is, hg') <- runWriterT (evalStateT run initialState)
849     -- Now add the annotations of the root values
850     let hg'' = foldl' (flip (uncurry annotateHeapGraph)) (HeapGraph hg') is
851     return (hg'', is)
852   where
853     run = do
854         lift $ tell hg -- Start with the initial map
855         forM addBoxes $ \(d, b) -> do
856             -- Cannot fail, as limit is not zero here
857             Just i <- add limit b
858             return (d, i)
859
860     add 0  _ = return Nothing
861     add n b = do
862         -- If the box is in the map, return the index
863         (existing,_,_) <- get
864         mbI <- liftIO $ findM (areBoxesEqual b . fst) existing
865         case mbI of
866             Just (_,i) -> return $ Just i
867             Nothing -> do
868                 -- Otherwise, allocate a new index
869                 i <- nextI
870                 -- And register it
871                 modify (\(x,y,z) -> ((b,i):x, y, z))
872                 -- Look up the closure
873                 c <- liftIO $ getBoxedClosureData b
874                 -- Find indicies for all boxes contained in the map
875                 c' <- T.mapM (add (n-1)) c
876                 -- Add add the resulting closure to the map
877                 lift $ tell (M.singleton i (HeapGraphEntry b c' True mempty))
878                 return $ Just i
879     nextI = do
880         i <- gets (head . (\(_,b,_) -> b))
881         modify (\(a,b,c) -> (a, tail b, c))
882         return i
883
884 -- | This function updates a heap graph to reflect the current state of
885 -- closures on the heap, conforming to the following specification.
886 --
887 --  * Every entry whose value has been garbage collected by now is marked as
888 --    dead by setting 'hgeLive' to @False@
889 --  * Every entry whose value is still live gets the 'hgeClosure' field updated
890 --    and newly referenced closures are, up to the given depth, added to the graph.
891 --  * A map mapping previous indicies to the corresponding new indicies is returned as well.
892 --  * The closure at 'heapGraphRoot' stays at 'heapGraphRoot'
893 updateHeapGraph :: Monoid a => Int -> HeapGraph a -> IO (HeapGraph a, HeapGraphIndex -> HeapGraphIndex)
894 updateHeapGraph limit (HeapGraph startHG) = do
895     (hg', indexMap) <- runWriterT $ foldM go (HeapGraph M.empty) (M.toList startHG)
896     return (hg', (M.!) indexMap)
897   where
898     go hg (i, hge) = do
899         (j, hg') <- liftIO $ addHeapGraph limit (hgeData hge) (hgeBox hge) hg
900         tell (M.singleton i j)
901         return hg'
902                 
903 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
904 -- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
905 --
906 -- >let x1 = "Ki"
907 -- >    x6 = C# 'H' : C# 'o' : x6
908 -- >in (x1,x1,x6)
909 ppHeapGraph :: HeapGraph a -> String
910 ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
911   where
912     -- All variables occuring more than once
913     bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot] 
914
915     letWrapper =
916         if null bindings
917         then ""
918         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin "
919
920     bindingLetter i = case hgeClosure (iToE i) of
921         ThunkClosure {..} -> 't'
922         SelectorClosure {..} -> 't'
923         APClosure {..} -> 't'
924         PAPClosure {..} -> 'f'
925         BCOClosure {..} -> 't'
926         FunClosure {..} -> 'f'
927         _ -> 'x'
928
929     ppBindingMap = M.fromList $
930         concat $
931         map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $
932         groupBy ((==) `on` snd) $ 
933         sortBy (compare `on` snd)
934         [ (i, bindingLetter i) | i <- bindings ]
935
936     ppVar i = ppBindingMap M.! i
937     ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)
938
939     ppEntry prec hge
940         | Just s <- isString hge = show s
941         | Just l <- isList hge   = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
942         | Just bc <- disassembleBCO (fmap (hgeClosure . iToE)) (hgeClosure hge)
943                                        = app ("_bco" : map (ppRef 10) (concatMap F.toList bc))
944         | otherwise = ppClosure ppRef prec (hgeClosure hge)
945       where
946         app [a] = a  ++ "()"
947         app xs = addBraces (10 <= prec) (intercalate " " xs)
948
949     ppRef _ Nothing = "..."
950     ppRef prec (Just i) | i `elem` bindings = ppVar i
951                         | otherwise = ppEntry prec (iToE i) 
952     iToE i = m M.! i
953
954     iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
955
956     isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
957     isList hge = 
958         if isNil (hgeClosure hge)
959           then return []
960           else do
961             (h,t) <- isCons (hgeClosure hge)
962             ti <- t
963             e <- iToUnboundE ti
964             t' <- isList e
965             return $ (:) h t'
966
967     isString :: HeapGraphEntry a -> Maybe String
968     isString e = do
969         list <- isList e
970         -- We do not want to print empty lists as "" as we do not know that they
971         -- are really strings.
972         if (null list)
973             then Nothing
974             else mapM (isChar . hgeClosure <=< iToUnboundE <=< id) list
975
976
977 -- | In the given HeapMap, list all indices that are used more than once. The
978 -- second parameter adds external references, commonly @[heapGraphRoot]@.
979 boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
980 boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $
981      roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m)
982
983 -- | This function integrates the disassembler in "GHC.Disassembler". The first
984 -- argument should a function that dereferences the pointer in the closure to a
985 -- closure.
986 --
987 -- If any of these return 'Nothing', then 'disassembleBCO' returns Nothing
988 disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]
989 disassembleBCO deref (BCOClosure {..}) = do
990     opsC <- deref instrs
991     litsC <- deref literals
992     ptrsC  <- deref bcoptrs
993     return $ disassemble (mccPayload ptrsC) (arrWords litsC) (toBytes (bytes opsC) (arrWords opsC))
994 disassembleBCO _ _ = Nothing
995
996 -- Utilities
997
998 findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
999 findM _p [] = return Nothing
1000 findM p (x:xs) = do
1001     b <- p x
1002     if b then return (Just x) else findM p xs
1003
1004 addBraces :: Bool -> String -> String
1005 addBraces True t = "(" ++ t ++ ")"
1006 addBraces False t = t
1007
1008 braceize :: [String] -> String
1009 braceize [] = ""
1010 braceize xs = "{" ++ intercalate "," xs ++ "}"