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