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