module Hdis86.IO
(
UD
, newUD
, setInputBuffer
, InputHook, setInputHook
, unsetInput
, advance, skip, setIP
, run
, getInstruction
, getLength, getOffset
, getHex, getBytes, getAssembly
, getMetadata
, setConfig
, setVendor, setCPUMode, setSyntax
, setCallback
, unsafeSetInputPtr
, unsafeRunLazy
) where
import qualified Hdis86.C as C
import Hdis86.Types
import Hdis86.Internal.Map
import Data.Typeable ( Typeable )
import Control.Concurrent.MVar
( MVar, newMVar, withMVar, modifyMVar_, addMVarFinalizer )
import Foreign
import Foreign.C.String
import Control.Applicative hiding ( Const )
import Control.Monad
import Data.Maybe
import Data.Function
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import System.IO.Unsafe ( unsafeInterleaveIO )
data Input
= InNone
| InHook (FunPtr C.InputHook)
| InBuf (ForeignPtr Word8)
| InPtr
data XlatType
= XlBuiltin
| XlCustom
data State = State
{ udPtr :: Ptr C.UD_t
, udInput :: Input
, udXlatType :: XlatType
, udXlat :: FunPtr C.Translator }
newtype UD = UD (MVar State)
deriving (Typeable)
setInput :: Input -> State -> IO State
setInput inpt st@State{udInput} = do
case udInput of
InHook fp -> freeHaskellFunPtr fp
InBuf ptr -> touchForeignPtr ptr
_ -> return ()
return $ st { udInput = inpt }
setXlat :: XlatType -> FunPtr C.Translator -> State -> IO State
setXlat ty fp st@State{udPtr, udXlat, udXlatType} = do
case udXlatType of
XlCustom -> freeHaskellFunPtr udXlat
_ -> return ()
C.set_syntax udPtr fp
return $ st { udXlatType = ty, udXlat = fp }
finalizeState :: MVar State -> IO ()
finalizeState = flip withMVar $ \st@State{udPtr} -> do
_ <- setInput InNone st
_ <- setXlat XlBuiltin nullFunPtr st
free udPtr
newUD :: IO UD
newUD = do
p <- mallocBytes C.sizeof_ud_t
C.init p
s <- newMVar $ State p InNone XlBuiltin nullFunPtr
addMVarFinalizer s (finalizeState s)
return $ UD s
withUDPtr :: UD -> (Ptr C.UD_t -> IO a) -> IO a
withUDPtr (UD s) f = withMVar s $ \State{udPtr} -> f udPtr
type InputHook = IO (Maybe Word8)
setInputHook :: UD -> InputHook -> IO ()
setInputHook (UD s) f = modifyMVar_ s $ \st@State{udPtr} -> do
fp <- C.wrap_InputHook (maybe C.eoi fromIntegral <$> f)
C.set_input_hook udPtr fp
setInput (InHook fp) st
unsafeSetInputPtr :: UD -> Ptr Word8 -> Word -> IO ()
unsafeSetInputPtr (UD s) ptr len = modifyMVar_ s $ \st@State{udPtr} -> do
C.set_input_buffer udPtr (castPtr ptr) (fromIntegral len)
setInput InPtr st
unsetInput :: UD -> IO ()
unsetInput (UD s) = modifyMVar_ s $ \st@State{udPtr} -> do
C.set_input_buffer udPtr nullPtr 0
setInput InNone st
setInputBuffer :: UD -> BS.ByteString -> IO ()
setInputBuffer (UD s) bs = modifyMVar_ s $ \st@State{udPtr} -> do
let (ptr, off, len) = BS.toForeignPtr bs
C.set_input_buffer udPtr
(unsafeForeignPtrToPtr ptr `plusPtr` off)
(fromIntegral len)
setInput (InBuf ptr) st
setCPUMode :: UD -> CPUMode -> IO ()
setCPUMode s = withUDPtr s . flip C.set_mode . f where
f Mode16 = 16
f Mode32 = 32
f Mode64 = 64
setIP :: UD -> Word64 -> IO ()
setIP s w = withUDPtr s $ flip C.set_pc w
setSyntax :: UD -> Syntax -> IO ()
setSyntax (UD s) = modifyMVar_ s . setXlat XlBuiltin . f where
f SyntaxNone = nullFunPtr
f SyntaxIntel = C.translate_intel
f SyntaxATT = C.translate_att
setCallback :: UD -> IO () -> IO ()
setCallback (UD s) act = do
fp <- C.wrap_Translator (const act)
modifyMVar_ s $ setXlat XlCustom fp
setVendor :: UD -> Vendor -> IO ()
setVendor ud = withUDPtr ud . flip C.set_vendor . f where
f Intel = C.udVendorIntel
f AMD = C.udVendorAmd
setConfig :: UD -> Config -> IO ()
setConfig ud Config{..} = do
setVendor ud cfgVendor
setCPUMode ud cfgCPUMode
setSyntax ud cfgSyntax
setIP ud cfgOrigin
advance :: UD -> IO (Maybe Word)
advance = fmap f . flip withUDPtr C.disassemble where
f 0 = Nothing
f n = Just $ fromIntegral n
runImpl :: (IO [a] -> IO [a]) -> UD -> IO a -> IO [a]
runImpl wrap ud get = fix $ \loop -> do
n <- advance ud
case n of
Just _ -> liftA2 (:) get (wrap loop)
Nothing -> return []
run :: UD -> IO a -> IO [a]
run = runImpl id
unsafeRunLazy :: UD -> IO a -> IO [a]
unsafeRunLazy = runImpl unsafeInterleaveIO
getLength :: UD -> IO Word
getLength = fmap fromIntegral . flip withUDPtr C.insn_len
getOffset :: UD -> IO Word64
getOffset = flip withUDPtr C.insn_off
getHex :: UD -> IO String
getHex = flip withUDPtr $ \p ->
C.insn_hex p >>= peekCString
getBytes :: UD -> IO BS.ByteString
getBytes = flip withUDPtr $ \p -> do
len <- C.insn_len p
ptr <- C.insn_ptr p
BS.packCStringLen (castPtr ptr, fromIntegral len)
getAssembly :: UD -> IO String
getAssembly = flip withUDPtr $ \p ->
C.insn_asm p >>= peekCString
getMetadata :: UD -> IO Metadata
getMetadata ud = Metadata
<$> getOffset ud
<*> getLength ud
<*> getHex ud
<*> getBytes ud
<*> getAssembly ud
<*> getInstruction ud
skip :: UD -> Word -> IO ()
skip s n = withUDPtr s $ flip C.input_skip (fromIntegral n)
getPfx :: Ptr C.UD_t -> IO [Prefix]
getPfx udt = catMaybes <$> mapM get allPfx where
allPfx =
[ (C.get_pfx_seg, getSeg)
, (C.get_pfx_rex, k Rex)
, (C.get_pfx_opr, k OperSize)
, (C.get_pfx_adr, k AddrSize)
, (C.get_pfx_lock, k Lock)
, (C.get_pfx_rep, k Rep)
, (C.get_pfx_repe, k RepE)
, (C.get_pfx_repne, k RepNE)
]
get (retr, conv) = do
n <- fromIntegral <$> retr udt
return (guard (n /= C.udNone) >> conv n)
getSeg (register -> RegSeg seg) = Just $ Seg seg
getSeg _ = Nothing
k v _ = Just v
getLvalU :: WordSize -> Ptr C.Operand -> IO Word64
getLvalU Bits0 _ = return 0
getLvalU Bits8 uop = fromIntegral <$> C.get_lval_u8 uop
getLvalU Bits16 uop = fromIntegral <$> C.get_lval_u16 uop
getLvalU Bits32 uop = fromIntegral <$> C.get_lval_u32 uop
getLvalU _ uop = C.get_lval_u64 uop
getLvalS :: WordSize -> Ptr C.Operand -> IO Int64
getLvalS Bits0 _ = return 0
getLvalS Bits8 uop = fromIntegral <$> C.get_lval_s8 uop
getLvalS Bits16 uop = fromIntegral <$> C.get_lval_s16 uop
getLvalS Bits32 uop = fromIntegral <$> C.get_lval_s32 uop
getLvalS _ uop = C.get_lval_s64 uop
opDecode :: UDTM (Ptr C.Operand -> IO Operand)
opDecode = makeUDTM
[ (C.udOpMem, fmap Mem . getMem)
, (C.udOpReg, fmap Reg . getReg C.get_base)
, (C.udOpPtr, fmap Ptr . getPtr)
, (C.udOpImm, fmap Imm . getImm getLvalU)
, (C.udOpJimm, fmap Jump . getImm getLvalS)
, (C.udOpConst, fmap Const . getImm getLvalU) ] where
getReg f uop = register <$> f uop
getMem uop = do
Just sz <- wordSize <$> C.get_offset uop
off <- Immediate sz <$> getLvalS sz uop
Memory
<$> ((fromJust . wordSize) <$> C.get_size uop)
<*> getReg C.get_base uop
<*> getReg C.get_index uop
<*> C.get_scale uop
<*> pure off
getPtr uop = do
sz <- C.get_size uop
(seg, off) <- C.get_lval_ptr uop
let szw = case sz of
32 -> Bits16
48 -> Bits32
_ -> error ("invaild pointer size " ++ show sz)
return . Pointer seg $ Immediate szw off
getImm f uop = do
Just sz <- wordSize <$> C.get_size uop
val <- f sz uop
return $ Immediate sz val
getOperands :: Ptr C.UD_t -> IO [Operand]
getOperands udt = catMaybes <$> mapM decode getters where
getters = [C.get_operand1, C.get_operand2, C.get_operand3]
decode f = do
let uop = f udt
ty <- C.get_type uop
case lookupUDTM ty opDecode of
Just g -> Just <$> g uop
Nothing -> return Nothing
getInstruction :: UD -> IO Instruction
getInstruction = flip withUDPtr $ \udt ->
Inst <$> getPfx udt <*> (opcode <$> C.get_mnemonic udt) <*> getOperands udt