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