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