85e3843a4148fa2dd58f0e112678083aa9464de1
[ghc-heap-view.git] / src / GHC / Disassembler.hs
1 {-# LANGUAGE CPP, ScopedTypeVariables #-}
2 -- | A disassembler for ByteCode objects as used by GHCi.
3 module GHC.Disassembler (
4     toBytes,
5     disassemble,
6     BCI(..) ) where
7
8 import qualified Data.ByteString.Lazy as BS
9 import Data.ByteString.Lazy (ByteString)
10 import Data.ByteString.Lazy.Builder
11 import Data.ByteString.Lazy.Builder.Extras
12 import Data.Binary.Get
13 import Data.Word
14 import Data.Int
15 import Data.Monoid
16 import Data.Bits
17 import Debug.Trace
18 import Data.Functor
19
20 #include "ghcautoconf.h"
21 #include "rts/Bytecodes.h"
22
23 -- | Converts the first @n@ bytes of this list of Words to a ByteString.
24 toBytes :: Word -> [Word] -> ByteString
25 toBytes n =
26     BS.take (fromIntegral n) .
27     toLazyByteString .
28     mconcat .
29 #if SIZEOF_VOID_P == 8
30     map (word64Host . fromIntegral)
31 #else
32     map (word32Host . fromIntegral)
33 #endif
34
35 -- | Given a list of pointers, a list of literals and a ByteString containing
36 -- byte code instructions, disassembles them into a list of byte code instructions.
37 disassemble :: forall box. [box] -> [Word] -> ByteString -> [BCI box]
38 disassemble ptrs lits = runGet $ do
39     -- Ignore length tag. Needs to be skipped with GHC versions with
40     -- http://hackage.haskell.org/trac/ghc/ticket/7518 included
41     getWord16host
42 #if SIZEOF_VOID_P == 8
43     getWord16host
44     getWord16host
45 #endif
46     n <- getWord16host
47     nextInst
48   where
49     getLiteral :: Get Word
50     getLiteral = ((!!) lits) . fromIntegral <$> getWord16host
51
52     getLiterals = do
53         p <- fromIntegral <$> getWord16host
54         n <- fromIntegral <$> getWord16host
55         return $ take n (drop p lits)
56
57     getAddr :: Int -> box
58     getAddr p = ptrs !! p
59
60     getPtr :: Get box
61     getPtr = getAddr . fromIntegral <$> getWord16host
62
63     nextInst :: Get [BCI box]
64     nextInst = do
65         e <- isEmpty
66         if e then return [] else do
67         w <- getWord16host
68         let large = 0 /= w .&. 0x8000
69
70         let getLarge = if large then getWordhost else fromIntegral `fmap` getWord16host
71         let getLargeInt = if large then getInthost else fromIntegral `fmap` getInt16host
72
73         i <- case w .&. 0xff of
74             bci_STKCHECK -> do
75                 n <- getLarge
76                 return $ BCISTKCHECK (n + 1)
77             bci_PUSH_L -> do
78                 return BCIPUSH_L
79                 o1 <- getWord16host
80                 return $ BCIPUSH_L o1
81             bci_PUSH_LL -> do
82                 o1 <- getWord16host
83                 o2 <- getWord16host
84                 return $ BCIPUSH_LL o1 o2
85             bci_PUSH_LLL -> do
86                 return BCIPUSH_LLL
87                 o1 <- getWord16host
88                 o2 <- getWord16host
89                 o3 <- getWord16host
90                 return $ BCIPUSH_LLL o1 o2 o3
91             bci_PUSH_G -> do
92                 p <- getPtr
93                 return $ BCIPUSH_G p
94             bci_PUSH_ALTS -> do
95                 p <- getPtr
96                 return $ BCIPUSH_ALTS p
97             bci_PUSH_ALTS_P -> do
98                 p <- getPtr
99                 return $ BCIPUSH_ALTS_P p
100             bci_PUSH_ALTS_N -> do
101                 p <- getPtr
102                 return $ BCIPUSH_ALTS_N p
103             bci_PUSH_ALTS_F -> do
104                 p <- getPtr
105                 return $ BCIPUSH_ALTS_F p
106             bci_PUSH_ALTS_D -> do
107                 p <- getPtr
108                 return $ BCIPUSH_ALTS_D p
109             bci_PUSH_ALTS_L -> do
110                 p <- getPtr
111                 return $ BCIPUSH_ALTS_L p
112             bci_PUSH_ALTS_V -> do
113                 p <- getPtr
114                 return $ BCIPUSH_ALTS_V p
115             bci_PUSH_UBX -> do
116                 lits <- getLiterals
117                 return $ BCIPUSH_UBX lits
118             bci_PUSH_APPLY_N -> do
119                 return BCIPUSH_APPLY_N
120             bci_PUSH_APPLY_F -> do
121                 return BCIPUSH_APPLY_F
122             bci_PUSH_APPLY_D -> do
123                 return BCIPUSH_APPLY_D
124             bci_PUSH_APPLY_L -> do
125                 return BCIPUSH_APPLY_L
126             bci_PUSH_APPLY_V -> do
127                 return BCIPUSH_APPLY_V
128             bci_PUSH_APPLY_P -> do
129                 return BCIPUSH_APPLY_P
130             bci_PUSH_APPLY_PP -> do
131                 return BCIPUSH_APPLY_PP
132             bci_PUSH_APPLY_PPP -> do
133                 return BCIPUSH_APPLY_PPP
134             bci_PUSH_APPLY_PPPP -> do
135                 return BCIPUSH_APPLY_PPPP
136             bci_PUSH_APPLY_PPPPP -> do
137                 return BCIPUSH_APPLY_PPPPP
138             bci_PUSH_APPLY_PPPPPP -> do
139                 return BCIPUSH_APPLY_PPPPPP
140             bci_SLIDE -> do
141                 p <- getWord16host
142                 n <- getWord16host
143                 return $ BCISLIDE p n
144             bci_ALLOC_AP -> do
145                 n <- getWord16host
146                 return $ BCIALLOC_AP n
147             bci_ALLOC_AP_NOUPD -> do
148                 n <- getWord16host
149                 return $ BCIALLOC_AP_NOUPD n
150             bci_ALLOC_PAP -> do
151                 a <- getWord16host
152                 n <- getWord16host
153                 return $ BCIALLOC_PAP a n
154             bci_MKAP -> do
155                 n <- getWord16host
156                 s <- getWord16host
157                 return $ BCIMKAP n s
158             bci_MKPAP -> do
159                 n <- getWord16host
160                 s <- getWord16host
161                 return $ BCIMKPAP n s
162             bci_UNPACK -> do
163                 n <- getWord16host
164                 return $ BCIUNPACK n
165             bci_PACK -> do
166                 p <- getLiteral
167                 n <- getWord16host
168                 return $ BCIPACK p n
169             bci_TESTLT_I -> do
170                 d <- getLargeInt
171                 t <- getLargeInt
172                 return $ BCITESTLT_I d t
173             bci_TESTEQ_I -> do
174                 d <- getLargeInt
175                 t <- getLargeInt
176                 return $ BCITESTEQ_I d t
177             bci_TESTLT_W -> do
178                 d <- getLarge
179                 t <- getLargeInt
180                 return $ BCITESTLT_W d t
181             bci_TESTEQ_W -> do
182                 d <- getLarge
183                 t <- getLargeInt
184                 return $ BCITESTEQ_W d t
185             bci_TESTLT_F -> do
186                 d <- getLarge
187                 t <- getLargeInt
188                 return $ BCITESTLT_F d t
189             bci_TESTEQ_F -> do
190                 d <- getLarge
191                 t <- getLargeInt
192                 return $ BCITESTEQ_F d t
193             bci_TESTLT_D -> do
194                 d <- getLarge
195                 t <- getLargeInt
196                 return $ BCITESTLT_D d t
197             bci_TESTEQ_D -> do
198                 d <- getLarge
199                 t <- getLargeInt
200                 return $ BCITESTEQ_D d t
201             bci_TESTLT_P -> do
202                 d <- getWord16host
203                 t <- getLargeInt
204                 return $ BCITESTLT_P d t
205             bci_TESTEQ_P -> do
206                 d <- getWord16host
207                 t <- getLargeInt
208                 return $ BCITESTEQ_P d t
209             bci_CASEFAIL -> do
210                 return BCICASEFAIL
211             bci_JMP -> do
212                 return BCIJMP
213             bci_CCALL -> do
214                 p <- getLiteral
215                 return $ BCICCALL p
216             bci_SWIZZLE -> do
217                 p <- getWord16host
218                 n <- getInt16host
219                 return $ BCISWIZZLE p n
220             bci_ENTER -> do
221                 return BCIENTER
222             bci_RETURN -> do
223                 return BCIRETURN
224             bci_RETURN_P -> do
225                 return BCIRETURN_P
226             bci_RETURN_N -> do
227                 return BCIRETURN_N
228             bci_RETURN_F -> do
229                 return BCIRETURN_F
230             bci_RETURN_D -> do
231                 return BCIRETURN_D
232             bci_RETURN_L -> do
233                 return BCIRETURN_L
234             bci_RETURN_V -> do
235                 return BCIRETURN_V
236             bci_BRK_FUN -> do
237                 getWord16host
238                 getWord16host
239                 getWord16host
240                 return BCIBRK_FUN
241             x -> error $ "Unknown opcode " ++ show x
242         (i :) `fmap` nextInst
243             
244
245 -- | The various byte code instructions that GHCi supports.
246 data BCI box
247     = BCISTKCHECK Word
248     | BCIPUSH_L Word16
249     | BCIPUSH_LL Word16 Word16 
250     | BCIPUSH_LLL Word16 Word16 Word16
251     | BCIPUSH_G box
252     | BCIPUSH_ALTS box
253     | BCIPUSH_ALTS_P box
254     | BCIPUSH_ALTS_N box
255     | BCIPUSH_ALTS_F box
256     | BCIPUSH_ALTS_D box
257     | BCIPUSH_ALTS_L box
258     | BCIPUSH_ALTS_V box
259     | BCIPUSH_UBX [Word]
260     | BCIPUSH_APPLY_N
261     | BCIPUSH_APPLY_F
262     | BCIPUSH_APPLY_D
263     | BCIPUSH_APPLY_L
264     | BCIPUSH_APPLY_V
265     | BCIPUSH_APPLY_P
266     | BCIPUSH_APPLY_PP
267     | BCIPUSH_APPLY_PPP
268     | BCIPUSH_APPLY_PPPP
269     | BCIPUSH_APPLY_PPPPP
270     | BCIPUSH_APPLY_PPPPPP
271 /*     | BCIPUSH_APPLY_PPPPPPP */
272     | BCISLIDE Word16 Word16
273     | BCIALLOC_AP Word16
274     | BCIALLOC_AP_NOUPD Word16
275     | BCIALLOC_PAP Word16 Word16
276     | BCIMKAP Word16 Word16
277     | BCIMKPAP Word16 Word16
278     | BCIUNPACK Word16
279     | BCIPACK Word Word16
280     | BCITESTLT_I Int Int
281     | BCITESTEQ_I Int Int
282     | BCITESTLT_F Word Int
283     | BCITESTEQ_F Word Int
284     | BCITESTLT_D Word Int
285     | BCITESTEQ_D Word Int
286     | BCITESTLT_P Word16 Int
287     | BCITESTEQ_P Word16 Int
288     | BCICASEFAIL
289     | BCIJMP
290     | BCICCALL Word
291     | BCISWIZZLE Word16 Int16
292     | BCIENTER
293     | BCIRETURN
294     | BCIRETURN_P
295     | BCIRETURN_N
296     | BCIRETURN_F
297     | BCIRETURN_D
298     | BCIRETURN_L
299     | BCIRETURN_V
300     | BCIBRK_FUN -- ^ We do not parse this opcode's arguments
301     | BCITESTLT_W Word Int
302     | BCITESTEQ_W Word Int
303     deriving (Show)
304
305 getInthost :: Get Int
306 getInthost = fromIntegral <$> getWordhost
307
308 getInt16host :: Get Int16
309 getInt16host = fromIntegral <$> getWord16host