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