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