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