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