735425ae946097fac472a105d575b4b9e55ee98a
[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 where
14
15 import System.IO.Unsafe
16 import GHC.Exts
17 import GHC.Prim 
18 import System.Environment
19 import GHC.Arr ((!), Array(..), elems)
20
21 import GHC.Constants ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
22
23 import System.Mem
24 import System.Mem.StableName
25 import Foreign
26 import Foreign.C
27 import Foreign.Ptr 
28 import Foreign.Storable 
29 import Foreign.Marshal.Array
30 import Numeric          ( showHex )
31 import Data.Word
32 import Data.Bits
33 import Data.Char
34 import Control.Monad
35
36 newtype HValue = HValue Any
37
38 -- A Safegard of HValues
39 data Box = Box HValue
40
41 type HalfWord = Word32
42
43 instance Show Box where
44 -- From libraries/base/GHC/Ptr.lhs
45    showsPrec _ (Box (HValue any)) rs =
46     -- unsafePerformIO (print "↓" >> pClosure any) `seq`    
47     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
48      where
49        ptr  = W# (aToWord# any)
50        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
51        addr = ptr - tag
52         -- want 0s prefixed to pad it out to a fixed length.
53        pad_out ls = 
54           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
55
56 asBox :: a -> Box
57 asBox x = Box (unsafeCoerce# x)
58
59 {-
60  - StgInfoTable parsing derived from ByteCodeItbls.lhs
61  - Removed the code parameter for now
62  - Replaced Type by an enumeration
63  - Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
64  -}
65
66
67 data StgInfoTable = StgInfoTable {
68    ptrs   :: HalfWord,
69    nptrs  :: HalfWord,
70    tipe   :: ClosureType,
71    srtlen :: HalfWord
72   }
73   deriving (Show)
74
75 instance Storable StgInfoTable where
76
77    sizeOf itbl 
78       = sum
79         [
80          fieldSz ptrs itbl,
81          fieldSz nptrs itbl,
82          sizeOf (undefined :: HalfWord),
83          fieldSz srtlen itbl
84         ]
85
86    alignment _ 
87       = wORD_SIZE
88
89    poke a0 itbl
90       = error "Storable StgInfoTable is read-only"
91
92    peek a0
93       = runState (castPtr a0)
94       $ do
95            ptrs'   <- load
96            nptrs'  <- load
97            tipe'   <- load
98            srtlen' <- load
99            return 
100               StgInfoTable { 
101                  ptrs   = ptrs',
102                  nptrs  = nptrs',
103                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
104                  srtlen = srtlen'
105               }
106
107 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
108 fieldSz sel x = sizeOf (sel x)
109
110 load :: Storable a => PtrIO a
111 load = do addr <- advance
112           lift (peek addr)
113
114 type PtrIO = State (Ptr Word8) IO
115
116 advance :: Storable a => PtrIO (Ptr a)
117 advance = State adv where
118     adv addr = case castPtr addr of { addrCast -> return
119         (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
120
121 sizeOfPointee :: (Storable a) => Ptr a -> Int
122 sizeOfPointee addr = sizeOf (typeHack addr)
123     where typeHack = undefined :: Ptr a -> a
124
125 store :: Storable a => a -> PtrIO ()
126 store x = do addr <- advance
127              lift (poke addr x)
128
129 {-
130  - Embedded StateT, also from ByteCodeItbls
131  -}
132
133 newtype State s m a = State (s -> m (s, a))
134
135 instance Monad m => Monad (State s m) where
136   return a      = State (\s -> return (s, a))
137   State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
138   fail str      = State (\_ -> fail str)
139
140 lift m = State (\s -> m >>= \a -> return (s, a))
141
142 runState :: (Monad m) => s -> State s m a -> m a
143 runState s (State m) = m s >>= return . snd
144
145 {-
146  - Data Type representing Closures
147  -}
148
149
150 data ClosureType =
151           INVALID_OBJECT
152         | CONSTR
153         | CONSTR_1_0
154         | CONSTR_0_1
155         | CONSTR_2_0
156         | CONSTR_1_1
157         | CONSTR_0_2
158         | CONSTR_STATIC
159         | CONSTR_NOCAF_STATIC
160         | FUN
161         | FUN_1_0
162         | FUN_0_1
163         | FUN_2_0
164         | FUN_1_1
165         | FUN_0_2
166         | FUN_STATIC
167         | THUNK
168         | THUNK_1_0
169         | THUNK_0_1
170         | THUNK_2_0
171         | THUNK_1_1
172         | THUNK_0_2
173         | THUNK_STATIC
174         | THUNK_SELECTOR
175         | BCO
176         | AP
177         | PAP
178         | AP_STACK
179         | IND
180         | IND_PERM
181         | IND_STATIC
182         | RET_BCO
183         | RET_SMALL
184         | RET_BIG
185         | RET_DYN
186         | RET_FUN
187         | UPDATE_FRAME
188         | CATCH_FRAME
189         | UNDERFLOW_FRAME
190         | STOP_FRAME
191         | BLOCKING_QUEUE
192         | BLACKHOLE
193         | MVAR_CLEAN
194         | MVAR_DIRTY
195         | ARR_WORDS
196         | MUT_ARR_PTRS_CLEAN
197         | MUT_ARR_PTRS_DIRTY
198         | MUT_ARR_PTRS_FROZEN0
199         | MUT_ARR_PTRS_FROZEN
200         | MUT_VAR_CLEAN
201         | MUT_VAR_DIRTY
202         | WEAK
203         | PRIM
204         | MUT_PRIM
205         | TSO
206         | STACK
207         | TREC_CHUNK
208         | ATOMICALLY_FRAME
209         | CATCH_RETRY_FRAME
210         | CATCH_STM_FRAME
211         | WHITEHOLE
212  deriving (Show, Eq, Enum, Ord)
213
214 data Closure =
215     ConsClosure {
216         info         :: StgInfoTable 
217         , ptrArgs    :: [Box]
218         , dataArgs   :: [Word]
219         , descr      :: String
220     } |
221     ThunkClosure {
222         info         :: StgInfoTable 
223         , ptrArgs    :: [Box]
224         , dataArgs   :: [Word]
225     } |
226     SelectorClosure {
227         info         :: StgInfoTable 
228         , selectee   :: Box
229     } |
230     IndClosure {
231         info         :: StgInfoTable 
232         , indirectee   :: Box
233     } |
234     APClosure {
235         info         :: StgInfoTable 
236         , arity      :: HalfWord
237         , n_args     :: HalfWord
238         , fun        :: Box
239         , payload    :: [Box]
240     } |
241     PAPClosure {
242         info         :: StgInfoTable 
243         , arity      :: HalfWord
244         , n_args     :: HalfWord
245         , fun        :: Box
246         , payload    :: [Box]
247     } |
248     BCOClosure {
249         info         :: StgInfoTable 
250         , instrs     :: Box
251         , literals   :: Box
252         , bcoptrs    :: Box
253         , arity      :: HalfWord
254         , size       :: HalfWord
255         , bitmap     :: Word
256     } |
257     ArrWordsClosure {
258         info         :: StgInfoTable 
259         , bytes      :: Word
260         , words      :: [Word]
261     } |
262     MutArrClosure {
263         info         :: StgInfoTable 
264         , mccPtrs    :: Word
265         , mccSize    :: Word
266         , mccPayload :: [Box]
267         -- Card table ignored
268     } |
269     FunClosure {
270         info         :: StgInfoTable 
271         , ptrArgs    :: [Box]
272         , dataArgs   :: [Word]
273     } |
274     BlockingQueueClosure {
275         info         :: StgInfoTable 
276         , link       :: Box
277         , blackHole  :: Box
278         , owner      :: Box
279         , queue      :: Box
280     } |
281     OtherClosure {
282         info         :: StgInfoTable 
283         , hvalues    :: [Box]
284         , words      :: [Word]
285     }
286  deriving (Show)
287
288 allPtrs (ConsClosure {..}) = ptrArgs
289 allPtrs (ThunkClosure {..}) = ptrArgs
290 allPtrs (SelectorClosure {..}) = [selectee]
291 allPtrs (IndClosure {..}) = [indirectee]
292 allPtrs (APClosure {..}) = fun:payload
293 allPtrs (PAPClosure {..}) = fun:payload
294 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
295 allPtrs (ArrWordsClosure {..}) = []
296 allPtrs (MutArrClosure {..}) = mccPayload
297 allPtrs (FunClosure {..}) = ptrArgs
298 allPtrs (OtherClosure {..}) = hvalues
299
300
301
302 #ifdef PRIM_SUPPORTS_ANY
303 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
304 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
305 #else
306 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
307 -- accepted
308
309 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
310 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
311
312 -- This is a datatype that has the same layout as Ptr, so that by
313 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
314 data Ptr' a = Ptr' a
315
316 aToWord# :: Any -> Word#
317 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
318
319 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
320 slurpClosure# a = slurpClosure'# (aToWord# a)
321 #endif
322
323 --pClosure x = do
324 --    getClosure x >>= print
325
326 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
327 getClosureRaw x =
328     case slurpClosure# (unsafeCoerce# x) of
329         (# iptr, dat, ptrs #) -> do
330             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
331                 words = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
332                 pelems = I# (sizeofArray# ptrs) 
333                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
334             ptrList `seq` words `seq` return (Ptr iptr, words, ptrList)
335
336 -- From compiler/ghci/RtClosureInspect.hs
337 amap' :: (t -> b) -> Array Int t -> [b]
338 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
339     where g (I# i#) = case indexArray# arr# i# of
340                           (# e #) -> f e
341
342
343
344 -- #include "../includes/rts/storage/ClosureTypes.h"
345
346 getHValueClosureData :: Box -> IO Closure
347 getHValueClosureData b@(Box a) = getClosureData a
348
349 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
350 -- compiler/ghci/DebuggerUtils.hs
351 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO String
352 dataConInfoPtrToNames ptr = do
353     conDescAddress <- getConDescAddress ptr
354     wl <- peekArray0 0 conDescAddress
355     return $ fmap (chr . fromIntegral) wl
356   where
357     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
358     getConDescAddress ptr
359       | True = do
360           offsetToString <- peek (ptr `plusPtr` (negate wORD_SIZE))
361           return $ (ptr `plusPtr` stdInfoTableSizeB)
362                     `plusPtr` (fromIntegral (offsetToString :: Word))
363     -- This is code for !ghciTablesNextToCode: 
364     {-
365       | otherwise = peek . intPtrToPtr
366                       . (+ fromIntegral
367                             stdInfoTableSizeB)
368                         . ptrToIntPtr $ ptr
369     -}
370
371     -- hmmmmmm. Is there any way to tell this?
372     opt_SccProfilingOn = False
373
374     stdInfoTableSizeW :: Int
375     -- The size of a standard info table varies with profiling/ticky etc,
376     -- so we can't get it from Constants
377     -- It must vary in sync with mkStdInfoTable
378     stdInfoTableSizeW
379       = size_fixed + size_prof
380       where
381         size_fixed = 2  -- layout, type
382         size_prof | opt_SccProfilingOn = 2
383                   | otherwise    = 0
384
385     stdInfoTableSizeB :: Int
386     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
387     
388
389 getClosureData :: a -> IO Closure
390 getClosureData x = do
391     (iptr, words, ptrs) <- getClosureRaw x
392     itbl <- peek iptr
393     case tipe itbl of 
394         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
395             name <- dataConInfoPtrToNames iptr
396             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) words) name
397
398         t | t >= THUNK && t <= THUNK_STATIC -> do
399             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) words)
400
401         t | t >= FUN && t <= FUN_STATIC -> do
402             return $ FunClosure itbl ptrs (drop (length ptrs + 1) words)
403
404         AP ->
405             return $ APClosure itbl 
406                 (fromIntegral $ words !! 2)
407                 (fromIntegral $ shiftR (words !! 2) (wORD_SIZE_IN_BITS `div` 2))
408                 (head ptrs) (tail ptrs)
409
410         PAP ->
411             return $ PAPClosure itbl 
412                 (fromIntegral $ words !! 2)
413                 (fromIntegral $ shiftR (words !! 2) (wORD_SIZE_IN_BITS `div` 2))
414                 (head ptrs) (tail ptrs)
415
416         THUNK_SELECTOR ->
417             return $ SelectorClosure itbl (head ptrs)
418
419         IND ->
420             return $ IndClosure itbl (head ptrs)
421         IND_STATIC ->
422             return $ IndClosure itbl (head ptrs)
423         BLACKHOLE ->
424             return $ IndClosure itbl (head ptrs)
425
426         BCO ->
427             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
428                 (fromIntegral $ words !! 4)
429                 (fromIntegral $ shiftR (words !! 4) (wORD_SIZE_IN_BITS `div` 2))
430                 (words !! 5)
431
432         ARR_WORDS ->
433             return $ ArrWordsClosure itbl (words !! 1) (drop 2 words)
434         MUT_ARR_PTRS_FROZEN ->
435             return $ MutArrClosure itbl (words !! 2) (words !! 3) ptrs
436
437         BLOCKING_QUEUE ->
438           return $ OtherClosure itbl ptrs words
439         --    return $ BlockingQueueClosure itbl
440         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
441
442         --  return $ OtherClosure itbl ptrs words
443         x -> error $ "getClosureData: Cannot handle closure type " ++ show x