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