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