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