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