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