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