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