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