{-# LANGUAGE CPP, ScopedTypeVariables, DoAndIfThenElse, NondecreasingIndentation, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-- | A disassembler for ByteCode objects as used by GHCi.
module GHC.Disassembler (
    toBytes,
    disassemble,
    BCI(..) ) where

import qualified Data.ByteString.Lazy as BS
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Builder
import Data.ByteString.Builder.Extra
import Data.Binary.Get
import Data.Word
import Data.Int
import Data.Bits

#include "ghcautoconf.h"
#include "rts/Bytecodes.h"

-- | Converts the first @n@ bytes of this list of Words to a ByteString.
toBytes :: Word -> [Word] -> ByteString
toBytes :: Word -> [Word] -> ByteString
toBytes Word
n =
    Int64 -> ByteString -> ByteString
BS.take (Word -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) (ByteString -> ByteString)
-> ([Word] -> ByteString) -> [Word] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> ([Word] -> Builder) -> [Word] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Word] -> [Builder]) -> [Word] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Word -> Builder) -> [Word] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Word -> Builder
wordHost (Word -> Builder) -> (Word -> Word) -> Word -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

-- | Given a list of pointers, a list of literals and a ByteString containing
-- byte code instructions, disassembles them into a list of byte code instructions.
disassemble :: forall box. [box] -> [Word] -> ByteString -> [BCI box]
disassemble :: [box] -> [Word] -> ByteString -> [BCI box]
disassemble [box]
ptrs [Word]
lits = Get [BCI box] -> ByteString -> [BCI box]
forall a. Get a -> ByteString -> a
runGet (Get [BCI box] -> ByteString -> [BCI box])
-> Get [BCI box] -> ByteString -> [BCI box]
forall a b. (a -> b) -> a -> b
$ do
#ifndef GHC_7_7
    -- Ignore length tag. Needs to be skipped with GHC versions with
    -- http://hackage.haskell.org/trac/ghc/ticket/7518 included
    Word16
_ <- Get Word16
getWord16host
#if SIZEOF_VOID_P == 8
    Word16
_ <- Get Word16
getWord16host
    Word16
_ <- Get Word16
getWord16host
#endif
    Word16
_n <- Get Word16
getWord16host
#endif
    Get [BCI box]
nextInst
  where
    getLiteral :: Get Word
    getLiteral :: Get Word
getLiteral = ([Word] -> Int -> Word
forall a. [a] -> Int -> a
(!!) [Word]
lits) (Int -> Word) -> (Word16 -> Int) -> Word16 -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word) -> Get Word16 -> Get Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16host

    getLiterals :: Get [Word]
getLiterals = do
        Int
p <- Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Get Word16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16host
        Int
n <- Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int) -> Get Word16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16host
        [Word] -> Get [Word]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word] -> Get [Word]) -> [Word] -> Get [Word]
forall a b. (a -> b) -> a -> b
$ Int -> [Word] -> [Word]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Word] -> [Word]
forall a. Int -> [a] -> [a]
drop Int
p [Word]
lits)

    getAddr :: Int -> box
    getAddr :: Int -> box
getAddr Int
p = [box]
ptrs [box] -> Int -> box
forall a. [a] -> Int -> a
!! Int
p

    getPtr :: Get box
    getPtr :: Get box
getPtr = Int -> box
getAddr (Int -> box) -> (Word16 -> Int) -> Word16 -> box
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> box) -> Get Word16 -> Get box
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16host

    nextInst :: Get [BCI box]
    nextInst :: Get [BCI box]
nextInst = do
        Bool
e <- Get Bool
isEmpty
        if Bool
e then [BCI box] -> Get [BCI box]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
        Word16
w <- Get Word16
getWord16host
        let large :: Bool
large = Word16
0 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x8000

        let getLarge :: Get Word
getLarge = if Bool
large then Get Word
getWordhost else Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word) -> Get Word16 -> Get Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Get Word16
getWord16host
        let getLargeInt :: Get Int
getLargeInt = if Bool
large then Get Int
getInthost else Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16 -> Int) -> Get Int16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Get Int16
getInt16host

        BCI box
i <- case Word16
w Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0xff of
            bci_STKCHECK -> do
                n <- getLarge
                return $ BCISTKCHECK (n + 1)
            bci_PUSH_L -> do
                o1 <- getWord16host
                return $ BCIPUSH_L o1
            bci_PUSH_LL -> do
                o1 <- getWord16host
                o2 <- getWord16host
                return $ BCIPUSH_LL o1 o2
            bci_PUSH_LLL -> do
                o1 <- getWord16host
                o2 <- getWord16host
                o3 <- getWord16host
                return $ BCIPUSH_LLL o1 o2 o3
            bci_PUSH_G -> do
                p <- getPtr
                return $ BCIPUSH_G p
            bci_PUSH_ALTS -> do
                p <- getPtr
                return $ BCIPUSH_ALTS p
            bci_PUSH_ALTS_P -> do
                p <- getPtr
                return $ BCIPUSH_ALTS_P p
            bci_PUSH_ALTS_N -> do
                p <- getPtr
                return $ BCIPUSH_ALTS_N p
            bci_PUSH_ALTS_F -> do
                p <- getPtr
                return $ BCIPUSH_ALTS_F p
            bci_PUSH_ALTS_D -> do
                p <- getPtr
                return $ BCIPUSH_ALTS_D p
            bci_PUSH_ALTS_L -> do
                p <- getPtr
                return $ BCIPUSH_ALTS_L p
            bci_PUSH_ALTS_V -> do
                p <- getPtr
                return $ BCIPUSH_ALTS_V p
            bci_PUSH_UBX -> do
                ubx_lits <- getLiterals
                return $ BCIPUSH_UBX ubx_lits
            bci_PUSH_APPLY_N -> do
                return BCIPUSH_APPLY_N
            bci_PUSH_APPLY_F -> do
                return BCIPUSH_APPLY_F
            bci_PUSH_APPLY_D -> do
                return BCIPUSH_APPLY_D
            bci_PUSH_APPLY_L -> do
                return BCIPUSH_APPLY_L
            bci_PUSH_APPLY_V -> do
                return BCIPUSH_APPLY_V
            bci_PUSH_APPLY_P -> do
                return BCIPUSH_APPLY_P
            bci_PUSH_APPLY_PP -> do
                return BCIPUSH_APPLY_PP
            bci_PUSH_APPLY_PPP -> do
                return BCIPUSH_APPLY_PPP
            bci_PUSH_APPLY_PPPP -> do
                return BCIPUSH_APPLY_PPPP
            bci_PUSH_APPLY_PPPPP -> do
                return BCIPUSH_APPLY_PPPPP
            bci_PUSH_APPLY_PPPPPP -> do
                return BCIPUSH_APPLY_PPPPPP
            bci_SLIDE -> do
                p <- getWord16host
                n <- getWord16host
                return $ BCISLIDE p n
            bci_ALLOC_AP -> do
                n <- getWord16host
                return $ BCIALLOC_AP n
            bci_ALLOC_AP_NOUPD -> do
                n <- getWord16host
                return $ BCIALLOC_AP_NOUPD n
            bci_ALLOC_PAP -> do
                a <- getWord16host
                n <- getWord16host
                return $ BCIALLOC_PAP a n
            bci_MKAP -> do
                n <- getWord16host
                s <- getWord16host
                return $ BCIMKAP n s
            bci_MKPAP -> do
                n <- getWord16host
                s <- getWord16host
                return $ BCIMKPAP n s
            bci_UNPACK -> do
                n <- getWord16host
                return $ BCIUNPACK n
            bci_PACK -> do
                p <- getLiteral
                n <- getWord16host
                return $ BCIPACK p n
            bci_TESTLT_I -> do
                d <- getLargeInt
                t <- getLargeInt
                return $ BCITESTLT_I d t
            bci_TESTEQ_I -> do
                d <- getLargeInt
                t <- getLargeInt
                return $ BCITESTEQ_I d t
            bci_TESTLT_W -> do
                d <- getLarge
                t <- getLargeInt
                return $ BCITESTLT_W d t
            bci_TESTEQ_W -> do
                d <- getLarge
                t <- getLargeInt
                return $ BCITESTEQ_W d t
            bci_TESTLT_F -> do
                d <- getLarge
                t <- getLargeInt
                return $ BCITESTLT_F d t
            bci_TESTEQ_F -> do
                d <- getLarge
                t <- getLargeInt
                return $ BCITESTEQ_F d t
            bci_TESTLT_D -> do
                d <- getLarge
                t <- getLargeInt
                return $ BCITESTLT_D d t
            bci_TESTEQ_D -> do
                d <- getLarge
                t <- getLargeInt
                return $ BCITESTEQ_D d t
            bci_TESTLT_P -> do
                d <- getWord16host
                t <- getLargeInt
                return $ BCITESTLT_P d t
            bci_TESTEQ_P -> do
                d <- getWord16host
                t <- getLargeInt
                return $ BCITESTEQ_P d t
            bci_CASEFAIL -> do
                return BCICASEFAIL
            bci_JMP -> do
                return BCIJMP
            bci_CCALL -> do
                p <- getLiteral
                return $ BCICCALL p
            bci_SWIZZLE -> do
                p <- getWord16host
                n <- getInt16host
                return $ BCISWIZZLE p n
            bci_ENTER -> do
                return BCIENTER
            bci_RETURN -> do
                return BCIRETURN
            bci_RETURN_P -> do
                return BCIRETURN_P
            bci_RETURN_N -> do
                return BCIRETURN_N
            bci_RETURN_F -> do
                return BCIRETURN_F
            bci_RETURN_D -> do
                return BCIRETURN_D
            bci_RETURN_L -> do
                return BCIRETURN_L
            bci_RETURN_V -> do
                return BCIRETURN_V
            bci_BRK_FUN -> do
                _ <- getWord16host
                _ <- getWord16host
                _ <- getWord16host
                return BCIBRK_FUN
            Word16
x -> BCI box -> Get (BCI box)
forall (m :: * -> *) a. Monad m => a -> m a
return (BCI box -> Get (BCI box)) -> BCI box -> Get (BCI box)
forall a b. (a -> b) -> a -> b
$ Word16 -> BCI box
forall box. Word16 -> BCI box
BCI_DECODE_ERROR Word16
x
        (BCI box
i BCI box -> [BCI box] -> [BCI box]
forall a. a -> [a] -> [a]
:) ([BCI box] -> [BCI box]) -> Get [BCI box] -> Get [BCI box]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Get [BCI box]
nextInst


-- | The various byte code instructions that GHCi supports.
data BCI box
    = BCISTKCHECK Word
    | BCIPUSH_L Word16
    | BCIPUSH_LL Word16 Word16
    | BCIPUSH_LLL Word16 Word16 Word16
    | BCIPUSH_G box
    | BCIPUSH_ALTS box
    | BCIPUSH_ALTS_P box
    | BCIPUSH_ALTS_N box
    | BCIPUSH_ALTS_F box
    | BCIPUSH_ALTS_D box
    | BCIPUSH_ALTS_L box
    | BCIPUSH_ALTS_V box
    | BCIPUSH_UBX [Word]
    | BCIPUSH_APPLY_N
    | BCIPUSH_APPLY_F
    | BCIPUSH_APPLY_D
    | BCIPUSH_APPLY_L
    | BCIPUSH_APPLY_V
    | BCIPUSH_APPLY_P
    | BCIPUSH_APPLY_PP
    | BCIPUSH_APPLY_PPP
    | BCIPUSH_APPLY_PPPP
    | BCIPUSH_APPLY_PPPPP
    | BCIPUSH_APPLY_PPPPPP
/*     | BCIPUSH_APPLY_PPPPPPP */
    | BCISLIDE Word16 Word16
    | BCIALLOC_AP Word16
    | BCIALLOC_AP_NOUPD Word16
    | BCIALLOC_PAP Word16 Word16
    | BCIMKAP Word16 Word16
    | BCIMKPAP Word16 Word16
    | BCIUNPACK Word16
    | BCIPACK Word Word16
    | BCITESTLT_I Int Int
    | BCITESTEQ_I Int Int
    | BCITESTLT_F Word Int
    | BCITESTEQ_F Word Int
    | BCITESTLT_D Word Int
    | BCITESTEQ_D Word Int
    | BCITESTLT_P Word16 Int
    | BCITESTEQ_P Word16 Int
    | BCICASEFAIL
    | BCIJMP
    | BCICCALL Word
    | BCISWIZZLE Word16 Int16
    | BCIENTER
    | BCIRETURN
    | BCIRETURN_P
    | BCIRETURN_N
    | BCIRETURN_F
    | BCIRETURN_D
    | BCIRETURN_L
    | BCIRETURN_V
    | BCIBRK_FUN -- ^ We do not parse this opcode's arguments
    | BCITESTLT_W Word Int
    | BCITESTEQ_W Word Int
    | BCI_DECODE_ERROR Word16
    deriving (Int -> BCI box -> ShowS
[BCI box] -> ShowS
BCI box -> String
(Int -> BCI box -> ShowS)
-> (BCI box -> String) -> ([BCI box] -> ShowS) -> Show (BCI box)
forall box. Show box => Int -> BCI box -> ShowS
forall box. Show box => [BCI box] -> ShowS
forall box. Show box => BCI box -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BCI box] -> ShowS
$cshowList :: forall box. Show box => [BCI box] -> ShowS
show :: BCI box -> String
$cshow :: forall box. Show box => BCI box -> String
showsPrec :: Int -> BCI box -> ShowS
$cshowsPrec :: forall box. Show box => Int -> BCI box -> ShowS
Show, a -> BCI b -> BCI a
(a -> b) -> BCI a -> BCI b
(forall a b. (a -> b) -> BCI a -> BCI b)
-> (forall a b. a -> BCI b -> BCI a) -> Functor BCI
forall a b. a -> BCI b -> BCI a
forall a b. (a -> b) -> BCI a -> BCI b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> BCI b -> BCI a
$c<$ :: forall a b. a -> BCI b -> BCI a
fmap :: (a -> b) -> BCI a -> BCI b
$cfmap :: forall a b. (a -> b) -> BCI a -> BCI b
Functor, Functor BCI
Foldable BCI
Functor BCI
-> Foldable BCI
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> BCI a -> f (BCI b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    BCI (f a) -> f (BCI a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> BCI a -> m (BCI b))
-> (forall (m :: * -> *) a. Monad m => BCI (m a) -> m (BCI a))
-> Traversable BCI
(a -> f b) -> BCI a -> f (BCI b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => BCI (m a) -> m (BCI a)
forall (f :: * -> *) a. Applicative f => BCI (f a) -> f (BCI a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BCI a -> m (BCI b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BCI a -> f (BCI b)
sequence :: BCI (m a) -> m (BCI a)
$csequence :: forall (m :: * -> *) a. Monad m => BCI (m a) -> m (BCI a)
mapM :: (a -> m b) -> BCI a -> m (BCI b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> BCI a -> m (BCI b)
sequenceA :: BCI (f a) -> f (BCI a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => BCI (f a) -> f (BCI a)
traverse :: (a -> f b) -> BCI a -> f (BCI b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BCI a -> f (BCI b)
$cp2Traversable :: Foldable BCI
$cp1Traversable :: Functor BCI
Traversable, BCI a -> Bool
(a -> m) -> BCI a -> m
(a -> b -> b) -> b -> BCI a -> b
(forall m. Monoid m => BCI m -> m)
-> (forall m a. Monoid m => (a -> m) -> BCI a -> m)
-> (forall m a. Monoid m => (a -> m) -> BCI a -> m)
-> (forall a b. (a -> b -> b) -> b -> BCI a -> b)
-> (forall a b. (a -> b -> b) -> b -> BCI a -> b)
-> (forall b a. (b -> a -> b) -> b -> BCI a -> b)
-> (forall b a. (b -> a -> b) -> b -> BCI a -> b)
-> (forall a. (a -> a -> a) -> BCI a -> a)
-> (forall a. (a -> a -> a) -> BCI a -> a)
-> (forall a. BCI a -> [a])
-> (forall a. BCI a -> Bool)
-> (forall a. BCI a -> Int)
-> (forall a. Eq a => a -> BCI a -> Bool)
-> (forall a. Ord a => BCI a -> a)
-> (forall a. Ord a => BCI a -> a)
-> (forall a. Num a => BCI a -> a)
-> (forall a. Num a => BCI a -> a)
-> Foldable BCI
forall a. Eq a => a -> BCI a -> Bool
forall a. Num a => BCI a -> a
forall a. Ord a => BCI a -> a
forall m. Monoid m => BCI m -> m
forall a. BCI a -> Bool
forall a. BCI a -> Int
forall a. BCI a -> [a]
forall a. (a -> a -> a) -> BCI a -> a
forall m a. Monoid m => (a -> m) -> BCI a -> m
forall b a. (b -> a -> b) -> b -> BCI a -> b
forall a b. (a -> b -> b) -> b -> BCI a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: BCI a -> a
$cproduct :: forall a. Num a => BCI a -> a
sum :: BCI a -> a
$csum :: forall a. Num a => BCI a -> a
minimum :: BCI a -> a
$cminimum :: forall a. Ord a => BCI a -> a
maximum :: BCI a -> a
$cmaximum :: forall a. Ord a => BCI a -> a
elem :: a -> BCI a -> Bool
$celem :: forall a. Eq a => a -> BCI a -> Bool
length :: BCI a -> Int
$clength :: forall a. BCI a -> Int
null :: BCI a -> Bool
$cnull :: forall a. BCI a -> Bool
toList :: BCI a -> [a]
$ctoList :: forall a. BCI a -> [a]
foldl1 :: (a -> a -> a) -> BCI a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> BCI a -> a
foldr1 :: (a -> a -> a) -> BCI a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> BCI a -> a
foldl' :: (b -> a -> b) -> b -> BCI a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> BCI a -> b
foldl :: (b -> a -> b) -> b -> BCI a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> BCI a -> b
foldr' :: (a -> b -> b) -> b -> BCI a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> BCI a -> b
foldr :: (a -> b -> b) -> b -> BCI a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> BCI a -> b
foldMap' :: (a -> m) -> BCI a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> BCI a -> m
foldMap :: (a -> m) -> BCI a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> BCI a -> m
fold :: BCI m -> m
$cfold :: forall m. Monoid m => BCI m -> m
Foldable)

#if MIN_VERSION_binary(0,8,1)
#else
getInthost :: Get Int
getInthost = fromIntegral <$> getWordhost

getInt16host :: Get Int16
getInt16host = fromIntegral <$> getWord16host
#endif