6101f961e665ac629bc5df2a6a3cb0d6efa0d352
[ghc-heap-view.git] / src / GHC / HeapView.hs
1 {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
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     -- * Boxes
26     Box(..),
27     asBox,
28     -- * Weak boxes
29     WeakBox,
30     weakBox,
31     isAlive,
32     derefWeakBox,
33     WeakClosure,
34     weakenClosure,
35     )
36     where
37
38 import GHC.Exts         ( Any,
39                           Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,
40                           ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
41                           unsafeCoerce# )
42
43 import GHC.Arr          (Array(..))
44
45 import GHC.Constants    ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
46
47 import System.IO.Unsafe ( unsafePerformIO )
48
49 import Foreign          hiding ( unsafePerformIO )
50 import Numeric          ( showHex )
51 import Data.Char
52 import Data.List        ( intersperse )
53 import Data.Maybe       ( isJust )
54 import System.Mem.Weak
55 import Data.Foldable    ( Foldable )
56 import Data.Traversable ( Traversable )
57 import qualified Data.Traversable as T
58
59 #include "ghcautoconf.h"
60
61 -- | An arbitrarily Haskell value in a safe Box. The point is that even
62 -- unevaluated thunks can safely be moved around inside the Box, and when
63 -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
64 -- to evalue the argument.
65 data Box = Box Any
66
67 #if SIZEOF_VOID_P == 8
68 type HalfWord = Word32
69 #else
70 type HalfWord = Word16
71 #endif
72
73 instance Show Box where
74 -- From libraries/base/GHC/Ptr.lhs
75    showsPrec _ (Box a) rs =
76     -- unsafePerformIO (print "↓" >> pClosure a) `seq`    
77     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
78      where
79        ptr  = W# (aToWord# a)
80        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
81        addr = ptr - tag
82         -- want 0s prefixed to pad it out to a fixed length.
83        pad_out ls = 
84           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
85
86 instance Eq Box where
87   Box a == Box b = case reallyUnsafePtrEqualityUpToTag# a b of
88     0# -> False
89     _  -> True
90
91 {-|
92   This takes an arbitrary value and puts it into a box. Note that calls like
93
94   > asBox (head list) 
95
96   will put the thunk \"head list\" into the box, /not/ the element at the head
97   of the list. For that, use careful case expressions:
98
99   > case list of x:_ -> asBox x
100 -}
101 asBox :: a -> Box
102 asBox x = Box (unsafeCoerce# x)
103
104 {-
105    StgInfoTable parsing derived from ByteCodeItbls.lhs
106    Removed the code parameter for now
107    Replaced Type by an enumeration
108    Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
109  -}
110
111 {-| This is a somewhat faithful representation of an info table. See
112    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>
113    for more details on this data structure. Note that the 'Storable' instance
114    provided here does _not_ support writing.
115  -}
116 data StgInfoTable = StgInfoTable {
117    ptrs   :: HalfWord,
118    nptrs  :: HalfWord,
119    tipe   :: ClosureType,
120    srtlen :: HalfWord
121   }
122   deriving (Show)
123
124 instance Storable StgInfoTable where
125
126    sizeOf itbl 
127       = sum
128         [
129          fieldSz ptrs itbl,
130          fieldSz nptrs itbl,
131          sizeOf (undefined :: HalfWord),
132          fieldSz srtlen itbl
133         ]
134
135    alignment _ 
136       = wORD_SIZE
137
138    poke _a0 _itbl
139       = error "Storable StgInfoTable is read-only"
140
141    peek a0
142       = runState (castPtr a0)
143       $ do
144            ptrs'   <- load
145            nptrs'  <- load
146            tipe'   <- load
147            srtlen' <- load
148            return 
149               StgInfoTable { 
150                  ptrs   = ptrs',
151                  nptrs  = nptrs',
152                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
153                  srtlen = srtlen'
154               }
155
156 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
157 fieldSz sel x = sizeOf (sel x)
158
159 load :: Storable a => PtrIO a
160 load = do addr <- advance
161           lift (peek addr)
162
163 type PtrIO = State (Ptr Word8) IO
164
165 advance :: Storable a => PtrIO (Ptr a)
166 advance = State adv where
167     adv addr = case castPtr addr of { addrCast -> return
168         (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
169
170 sizeOfPointee :: (Storable a) => Ptr a -> Int
171 sizeOfPointee addr = sizeOf (typeHack addr)
172     where typeHack = undefined :: Ptr a -> a
173
174 {-
175    Embedded StateT, also from ByteCodeItbls
176  -}
177
178 newtype State s m a = State (s -> m (s, a))
179
180 instance Monad m => Monad (State s m) where
181   return a      = State (\s -> return (s, a))
182   State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
183   fail str      = State (\_ -> fail str)
184
185 lift :: Monad m => m a -> State s m a
186 lift m = State (\s -> m >>= \a -> return (s, a))
187
188 runState :: (Monad m) => s -> State s m a -> m a
189 runState s (State m) = m s >>= return . snd
190
191 {-
192    Data Type representing Closures
193  -}
194
195
196 {-| A closure type enumeration, in order matching the actual value on the heap.
197    Needs to be synchronized with
198    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>
199  -}
200 data ClosureType =
201           INVALID_OBJECT
202         | CONSTR
203         | CONSTR_1_0
204         | CONSTR_0_1
205         | CONSTR_2_0
206         | CONSTR_1_1
207         | CONSTR_0_2
208         | CONSTR_STATIC
209         | CONSTR_NOCAF_STATIC
210         | FUN
211         | FUN_1_0
212         | FUN_0_1
213         | FUN_2_0
214         | FUN_1_1
215         | FUN_0_2
216         | FUN_STATIC
217         | THUNK
218         | THUNK_1_0
219         | THUNK_0_1
220         | THUNK_2_0
221         | THUNK_1_1
222         | THUNK_0_2
223         | THUNK_STATIC
224         | THUNK_SELECTOR
225         | BCO
226         | AP
227         | PAP
228         | AP_STACK
229         | IND
230         | IND_PERM
231         | IND_STATIC
232         | RET_BCO
233         | RET_SMALL
234         | RET_BIG
235         | RET_DYN
236         | RET_FUN
237         | UPDATE_FRAME
238         | CATCH_FRAME
239         | UNDERFLOW_FRAME
240         | STOP_FRAME
241         | BLOCKING_QUEUE
242         | BLACKHOLE
243         | MVAR_CLEAN
244         | MVAR_DIRTY
245         | ARR_WORDS
246         | MUT_ARR_PTRS_CLEAN
247         | MUT_ARR_PTRS_DIRTY
248         | MUT_ARR_PTRS_FROZEN0
249         | MUT_ARR_PTRS_FROZEN
250         | MUT_VAR_CLEAN
251         | MUT_VAR_DIRTY
252         | WEAK
253         | PRIM
254         | MUT_PRIM
255         | TSO
256         | STACK
257         | TREC_CHUNK
258         | ATOMICALLY_FRAME
259         | CATCH_RETRY_FRAME
260         | CATCH_STM_FRAME
261         | WHITEHOLE
262  deriving (Show, Eq, Enum, Ord)
263
264 {-| This is the main data type of this module, representing a Haskell value on
265   the heap. This reflects
266   <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
267
268   The data type is parametrized by the type to store references in, which
269   should be either 'Box' or 'WeakBox', with appropriate type synonyms 'Closure'
270   and 'WeakClosure'.
271  -}
272 data GenClosure b =
273     ConsClosure {
274         info         :: StgInfoTable 
275         , ptrArgs    :: [b]
276         , dataArgs   :: [Word]
277         , pkg        :: String
278         , modl       :: String
279         , name       :: String
280     } |
281     ThunkClosure {
282         info         :: StgInfoTable 
283         , ptrArgs    :: [b]
284         , dataArgs   :: [Word]
285     } |
286     SelectorClosure {
287         info         :: StgInfoTable 
288         , selectee   :: b
289     } |
290     IndClosure {
291         info         :: StgInfoTable 
292         , indirectee   :: b
293     } |
294     BlackholeClosure {
295         info         :: StgInfoTable 
296         , indirectee   :: b
297     } |
298     APClosure {
299         info         :: StgInfoTable 
300         , arity      :: HalfWord
301         , n_args     :: HalfWord
302         , fun        :: b
303         , payload    :: [b]
304     } |
305     PAPClosure {
306         info         :: StgInfoTable 
307         , arity      :: HalfWord
308         , n_args     :: HalfWord
309         , fun        :: b
310         , payload    :: [b]
311     } |
312     APStackClosure {
313         info         :: StgInfoTable 
314         , fun        :: b
315         , payload    :: [b]
316     } |
317     BCOClosure {
318         info         :: StgInfoTable 
319         , instrs     :: b
320         , literals   :: b
321         , bcoptrs    :: b
322         , arity      :: HalfWord
323         , size       :: HalfWord
324         , bitmap     :: Word
325     } |
326     ArrWordsClosure {
327         info         :: StgInfoTable 
328         , bytes      :: Word
329         , arrWords   :: [Word]
330     } |
331     MutArrClosure {
332         info         :: StgInfoTable 
333         , mccPtrs    :: Word
334         , mccSize    :: Word
335         , mccPayload :: [b]
336         -- Card table ignored
337     } |
338     MutVarClosure {
339         info         :: StgInfoTable 
340         , var        :: b
341     } |
342     MVarClosure {
343         info         :: StgInfoTable 
344         , queueHead  :: b
345         , queueTail  :: b
346         , value      :: b
347     } |
348     FunClosure {
349         info         :: StgInfoTable 
350         , ptrArgs    :: [b]
351         , dataArgs   :: [Word]
352     } |
353     BlockingQueueClosure {
354         info         :: StgInfoTable 
355         , link       :: b
356         , blackHole  :: b
357         , owner      :: b
358         , queue      :: b
359     } |
360     OtherClosure {
361         info         :: StgInfoTable 
362         , hvalues    :: [b]
363         , rawWords   :: [Word]
364     } |
365     UnsupportedClosure {
366         info         :: StgInfoTable 
367     }
368  deriving (Show, Functor, Foldable, Traversable)
369
370
371 type Closure = GenClosure Box
372
373 -- | For generic code, this function returns all referenced closures. 
374 allPtrs :: GenClosure b -> [b]
375 allPtrs (ConsClosure {..}) = ptrArgs
376 allPtrs (ThunkClosure {..}) = ptrArgs
377 allPtrs (SelectorClosure {..}) = [selectee]
378 allPtrs (IndClosure {..}) = [indirectee]
379 allPtrs (BlackholeClosure {..}) = [indirectee]
380 allPtrs (APClosure {..}) = fun:payload
381 allPtrs (PAPClosure {..}) = fun:payload
382 allPtrs (APStackClosure {..}) = fun:payload
383 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
384 allPtrs (ArrWordsClosure {..}) = []
385 allPtrs (MutArrClosure {..}) = mccPayload
386 allPtrs (MutVarClosure {..}) = [var]
387 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
388 allPtrs (FunClosure {..}) = ptrArgs
389 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
390 allPtrs (OtherClosure {..}) = hvalues
391 allPtrs (UnsupportedClosure {..}) = []
392
393
394
395 #ifdef PRIM_SUPPORTS_ANY
396 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
397 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
398 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
399 #else
400 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
401 -- accepted
402
403 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
404 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
405
406 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
407
408 -- This is a datatype that has the same layout as Ptr, so that by
409 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
410 data Ptr' a = Ptr' a
411
412 aToWord# :: Any -> Word#
413 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
414
415 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
416 slurpClosure# a = slurpClosure'# (aToWord# a)
417
418 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
419 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
420 #endif
421
422 --pClosure x = do
423 --    getClosure x >>= print
424
425 -- | This returns the raw representation of the given argument. The second
426 -- component of the triple are the words on the heap, and the third component
427 -- are those words that are actually pointers. Once back in Haskell word, the
428 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
429 -- 'Box' will still point to the correct value.
430 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
431 getClosureRaw x =
432     case slurpClosure# (unsafeCoerce# x) of
433         (# iptr, dat, ptrs #) -> do
434             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
435                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
436                 pelems = I# (sizeofArray# ptrs) 
437                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
438             ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList)
439
440 -- From compiler/ghci/RtClosureInspect.hs
441 amap' :: (t -> b) -> Array Int t -> [b]
442 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
443     where g (I# i#) = case indexArray# arr# i# of
444                           (# e #) -> f e
445
446 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
447 -- compiler/ghci/DebuggerUtils.hs
448 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
449 dataConInfoPtrToNames ptr = do
450     conDescAddress <- getConDescAddress ptr
451     wl <- peekArray0 0 conDescAddress
452     let (pkg, modl, name) = parse wl
453     return (b2s pkg, b2s modl, b2s name)
454   where
455     b2s :: [Word8] -> String
456     b2s = fmap (chr . fromIntegral)
457
458     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
459     getConDescAddress ptr'
460       | True = do
461           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
462           return $ (ptr' `plusPtr` stdInfoTableSizeB)
463                     `plusPtr` (fromIntegral (offsetToString :: Word))
464     -- This is code for !ghciTablesNextToCode: 
465     {-
466       | otherwise = peek . intPtrToPtr
467                       . (+ fromIntegral
468                             stdInfoTableSizeB)
469                         . ptrToIntPtr $ ptr
470     -}
471
472     -- hmmmmmm. Is there any way to tell this?
473     opt_SccProfilingOn = False
474
475     stdInfoTableSizeW :: Int
476     -- The size of a standard info table varies with profiling/ticky etc,
477     -- so we can't get it from Constants
478     -- It must vary in sync with mkStdInfoTable
479     stdInfoTableSizeW
480       = size_fixed + size_prof
481       where
482         size_fixed = 2  -- layout, type
483         size_prof | opt_SccProfilingOn = 2
484                   | otherwise    = 0
485
486     stdInfoTableSizeB :: Int
487     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
488
489 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
490 parse :: [Word8] -> ([Word8], [Word8], [Word8])
491 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
492                 --then (error . concat)
493                 --        ["getConDescAddress:parse:"
494                 --        ,"(not . all (>0) . fmap le"
495                 --        ,"ngth $ [pkg,modl,occ]"]
496                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
497                 else (pkg, modl, occ)
498 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
499   where
500         (pkg, rest1) = break (== fromIntegral (ord ':')) input
501         (modl, occ)
502             = (concat $ intersperse [dot] $ reverse modWords, occWord)
503             where
504             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
505                                     --then error "getConDescAddress:parse:length rest1 < 1"
506                                     then parseModOcc [] []
507                                     else parseModOcc [] (tail rest1)
508         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
509         dot = fromIntegral (ord '.')
510         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
511         parseModOcc acc str
512             = case break (== dot) str of
513                 (top, []) -> (acc, top)
514                 (top, _:bot) -> parseModOcc (top : acc) bot
515
516
517 -- | This function returns parsed heap representation of the argument _at this
518 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
519 -- Beware when passing something to this function, the same caveats as for
520 -- 'asBox' apply.
521 getClosureData :: a -> IO Closure
522 getClosureData x = do
523     (iptr, wds, ptrs) <- getClosureRaw x
524     itbl <- peek iptr
525     case tipe itbl of 
526         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
527             (pkg, modl, name) <- dataConInfoPtrToNames iptr
528             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
529
530         t | t >= THUNK && t <= THUNK_STATIC -> do
531             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
532
533         t | t >= FUN && t <= FUN_STATIC -> do
534             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
535
536         AP ->
537             return $ APClosure itbl 
538                 (fromIntegral $ wds !! 2)
539                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
540                 (head ptrs) (tail ptrs)
541
542         PAP ->
543             return $ PAPClosure itbl 
544                 (fromIntegral $ wds !! 2)
545                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
546                 (head ptrs) (tail ptrs)
547
548         AP_STACK ->
549             return $ APStackClosure itbl (head ptrs) (tail ptrs)
550
551         THUNK_SELECTOR ->
552             return $ SelectorClosure itbl (head ptrs)
553
554         IND ->
555             return $ IndClosure itbl (head ptrs)
556         IND_STATIC ->
557             return $ IndClosure itbl (head ptrs)
558         BLACKHOLE ->
559             return $ BlackholeClosure itbl (head ptrs)
560
561         BCO ->
562             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
563                 (fromIntegral $ wds !! 4)
564                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
565                 (wds !! 5)
566
567         ARR_WORDS ->
568             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
569
570         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
571             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
572
573         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
574             return $ MutVarClosure itbl (head ptrs)
575
576         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
577             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
578
579         BLOCKING_QUEUE ->
580             return $ OtherClosure itbl ptrs wds
581         --    return $ BlockingQueueClosure itbl
582         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
583
584         --  return $ OtherClosure itbl ptrs wds
585         --
586         _ ->
587             return $ UnsupportedClosure itbl
588
589 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
590 getBoxedClosureData :: Box -> IO Closure
591 getBoxedClosureData (Box a) = getClosureData a
592
593
594 -- | An a variant of 'Box' that does not keep the value alive.
595 -- 
596 -- Like 'Box', its 'Show' instance is highly unsafe.
597 newtype WeakBox = WeakBox (Weak Box)
598
599
600 type WeakClosure = GenClosure WeakBox
601
602 instance Show WeakBox where
603     showsPrec p (WeakBox w) rs = case unsafePerformIO (deRefWeak w) of
604         Nothing -> let txt = "(freed)" in
605                    replicate (2*wORD_SIZE - length txt) ' ' ++ txt ++ rs
606         Just b -> showsPrec p b rs
607
608 {-|
609   Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
610   collected.
611 -}
612 weakBox :: Box -> IO WeakBox
613 weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
614
615 {-|
616   Checks whether the value referenced by a weak box is still alive
617 -}
618 isAlive :: WeakBox -> IO Bool
619 isAlive (WeakBox w) = isJust `fmap` deRefWeak w
620
621 {-|
622   Dereferences the weak box
623 -}
624 derefWeakBox :: WeakBox -> IO (Maybe Box)
625 derefWeakBox (WeakBox w) = deRefWeak w
626
627 weakenClosure :: Closure -> IO WeakClosure
628 weakenClosure = T.mapM weakBox