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