Add BlackholeClosure
[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     BlackholeClosure {
263         info         :: StgInfoTable 
264         , indirectee   :: Box
265     } |
266     APClosure {
267         info         :: StgInfoTable 
268         , arity      :: HalfWord
269         , n_args     :: HalfWord
270         , fun        :: Box
271         , payload    :: [Box]
272     } |
273     PAPClosure {
274         info         :: StgInfoTable 
275         , arity      :: HalfWord
276         , n_args     :: HalfWord
277         , fun        :: Box
278         , payload    :: [Box]
279     } |
280     BCOClosure {
281         info         :: StgInfoTable 
282         , instrs     :: Box
283         , literals   :: Box
284         , bcoptrs    :: Box
285         , arity      :: HalfWord
286         , size       :: HalfWord
287         , bitmap     :: Word
288     } |
289     ArrWordsClosure {
290         info         :: StgInfoTable 
291         , bytes      :: Word
292         , arrWords   :: [Word]
293     } |
294     MutArrClosure {
295         info         :: StgInfoTable 
296         , mccPtrs    :: Word
297         , mccSize    :: Word
298         , mccPayload :: [Box]
299         -- Card table ignored
300     } |
301     MutVarClosure {
302         info         :: StgInfoTable 
303         , var        :: Box
304     } |
305     MVarClosure {
306         info         :: StgInfoTable 
307         , queueHead  :: Box
308         , queueTail  :: Box
309         , value      :: Box
310     } |
311     FunClosure {
312         info         :: StgInfoTable 
313         , ptrArgs    :: [Box]
314         , dataArgs   :: [Word]
315     } |
316     BlockingQueueClosure {
317         info         :: StgInfoTable 
318         , link       :: Box
319         , blackHole  :: Box
320         , owner      :: Box
321         , queue      :: Box
322     } |
323     OtherClosure {
324         info         :: StgInfoTable 
325         , hvalues    :: [Box]
326         , rawWords   :: [Word]
327     }
328  deriving (Show)
329
330 -- | For generic code, this function returns all referenced closures. 
331 allPtrs :: Closure -> [Box]
332 allPtrs (ConsClosure {..}) = ptrArgs
333 allPtrs (ThunkClosure {..}) = ptrArgs
334 allPtrs (SelectorClosure {..}) = [selectee]
335 allPtrs (IndClosure {..}) = [indirectee]
336 allPtrs (BlackholeClosure {..}) = [indirectee]
337 allPtrs (APClosure {..}) = fun:payload
338 allPtrs (PAPClosure {..}) = fun:payload
339 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
340 allPtrs (ArrWordsClosure {..}) = []
341 allPtrs (MutArrClosure {..}) = mccPayload
342 allPtrs (MutVarClosure {..}) = [var]
343 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
344 allPtrs (FunClosure {..}) = ptrArgs
345 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
346 allPtrs (OtherClosure {..}) = hvalues
347
348
349
350 #ifdef PRIM_SUPPORTS_ANY
351 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
352 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
353 #else
354 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
355 -- accepted
356
357 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
358 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
359
360 -- This is a datatype that has the same layout as Ptr, so that by
361 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
362 data Ptr' a = Ptr' a
363
364 aToWord# :: Any -> Word#
365 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
366
367 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
368 slurpClosure# a = slurpClosure'# (aToWord# a)
369 #endif
370
371 --pClosure x = do
372 --    getClosure x >>= print
373
374 -- | This returns the raw representation of the given argument. The second
375 -- component of the triple are the words on the heap, and the third component
376 -- are those words that are actually pointers. Once back in Haskell word, the
377 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
378 -- 'Box' will still point to the correct value.
379 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
380 getClosureRaw x =
381     case slurpClosure# (unsafeCoerce# x) of
382         (# iptr, dat, ptrs #) -> do
383             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
384                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
385                 pelems = I# (sizeofArray# ptrs) 
386                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
387             ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList)
388
389 -- From compiler/ghci/RtClosureInspect.hs
390 amap' :: (t -> b) -> Array Int t -> [b]
391 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
392     where g (I# i#) = case indexArray# arr# i# of
393                           (# e #) -> f e
394
395 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
396 -- compiler/ghci/DebuggerUtils.hs
397 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO String
398 dataConInfoPtrToNames ptr = do
399     conDescAddress <- getConDescAddress ptr
400     wl <- peekArray0 0 conDescAddress
401     return $ fmap (chr . fromIntegral) wl
402   where
403     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
404     getConDescAddress ptr'
405       | True = do
406           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
407           return $ (ptr' `plusPtr` stdInfoTableSizeB)
408                     `plusPtr` (fromIntegral (offsetToString :: Word))
409     -- This is code for !ghciTablesNextToCode: 
410     {-
411       | otherwise = peek . intPtrToPtr
412                       . (+ fromIntegral
413                             stdInfoTableSizeB)
414                         . ptrToIntPtr $ ptr
415     -}
416
417     -- hmmmmmm. Is there any way to tell this?
418     opt_SccProfilingOn = False
419
420     stdInfoTableSizeW :: Int
421     -- The size of a standard info table varies with profiling/ticky etc,
422     -- so we can't get it from Constants
423     -- It must vary in sync with mkStdInfoTable
424     stdInfoTableSizeW
425       = size_fixed + size_prof
426       where
427         size_fixed = 2  -- layout, type
428         size_prof | opt_SccProfilingOn = 2
429                   | otherwise    = 0
430
431     stdInfoTableSizeB :: Int
432     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
433     
434
435 -- | This function returns parsed heap representation of the argument _at this
436 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
437 -- Beware when passing something to this function, the same caveats as for
438 -- 'asBox' apply.
439 getClosureData :: a -> IO Closure
440 getClosureData x = do
441     (iptr, wds, ptrs) <- getClosureRaw x
442     itbl <- peek iptr
443     case tipe itbl of 
444         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
445             name <- dataConInfoPtrToNames iptr
446             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) name
447
448         t | t >= THUNK && t <= THUNK_STATIC -> do
449             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
450
451         t | t >= FUN && t <= FUN_STATIC -> do
452             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
453
454         AP ->
455             return $ APClosure itbl 
456                 (fromIntegral $ wds !! 2)
457                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
458                 (head ptrs) (tail ptrs)
459
460         PAP ->
461             return $ PAPClosure itbl 
462                 (fromIntegral $ wds !! 2)
463                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
464                 (head ptrs) (tail ptrs)
465
466         THUNK_SELECTOR ->
467             return $ SelectorClosure itbl (head ptrs)
468
469         IND ->
470             return $ IndClosure itbl (head ptrs)
471         IND_STATIC ->
472             return $ IndClosure itbl (head ptrs)
473         BLACKHOLE ->
474             return $ BlackholeClosure itbl (head ptrs)
475
476         BCO ->
477             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
478                 (fromIntegral $ wds !! 4)
479                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
480                 (wds !! 5)
481
482         ARR_WORDS ->
483             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
484
485         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
486             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
487
488         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
489             return $ MutVarClosure itbl (head ptrs)
490
491         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
492             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
493
494         BLOCKING_QUEUE ->
495           return $ OtherClosure itbl ptrs wds
496         --    return $ BlockingQueueClosure itbl
497         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
498
499         --  return $ OtherClosure itbl ptrs wds
500         closure -> error $ "getClosureData: Cannot handle closure type " ++ show closure
501
502 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
503 getBoxedClosureData :: Box -> IO Closure
504 getBoxedClosureData (Box a) = getClosureData a
505