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