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