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