diff --git a/flexdis86.cabal b/flexdis86.cabal index 031893b..45b1b92 100644 --- a/flexdis86.cabal +++ b/flexdis86.cabal @@ -13,21 +13,21 @@ library default-language: Haskell2010 build-depends: base >= 4.6, - ansi-wl-pprint, - binary, binary-symbols, + binary, bytestring, containers, deepseq, directory, + exceptions >= 0.4 && < 0.11, filepath, lens >= 3.8, mtl, + prettyprinter, template-haskell, + unordered-containers, vector, - exceptions >= 0.4 && < 0.11, - xml, - unordered-containers + xml hs-source-dirs: src exposed-modules: @@ -46,22 +46,15 @@ library Flexdis86.DefaultParser Flexdis86.Disassembler Flexdis86.OpTable - ghc-options: -Wall -fno-ignore-asserts -O2 + ghc-options: -Wall -fno-ignore-asserts -O2 executable DumpInstr default-language: Haskell2010 build-depends: base >= 4, - ansi-wl-pprint, - binary, bytestring, - containers, flexdis86, - lens, - mtl, - template-haskell, - vector, - xml + mtl ghc-options: -Wall hs-source-dirs: utils @@ -96,4 +89,4 @@ test-suite flexdis86-tests Util if !os(darwin) && !os(windows) - cpp-options: -DARCH_ELF + cpp-options: -DARCH_ELF diff --git a/src/Flexdis86/InstructionSet.hs b/src/Flexdis86/InstructionSet.hs index c1152ef..6637f42 100644 --- a/src/Flexdis86/InstructionSet.hs +++ b/src/Flexdis86/InstructionSet.hs @@ -5,7 +5,9 @@ Maintainer : jhendrix@galois.com This declares the main datatypes for the instruction set. -} -{-# LANGUAGE PatternSynonyms #-} + +{-# LANGUAGE OverloadedStrings #-} + module Flexdis86.InstructionSet ( -- * Instruction information InstructionInstance @@ -22,10 +24,10 @@ module Flexdis86.InstructionSet import Control.Applicative import qualified Data.ByteString.Char8 as BSC import Data.Int +import Data.String (fromString) import Data.Word import Numeric (showHex) -import qualified Text.PrettyPrint.ANSI.Leijen as PP -import Text.PrettyPrint.ANSI.Leijen hiding (empty, (<$>)) +import qualified Prettyprinter as PP import Prelude @@ -36,14 +38,12 @@ import Flexdis86.Relocation import Flexdis86.Segment import Flexdis86.Sizes -padToWidth :: Int -> String -> String -padToWidth n s = if l > 0 then s ++ (replicate (n - l) ' ') else s +padToWidth :: Int -> String -> PP.Doc a +padToWidth n s = fromString $ if l > 0 then s ++ replicate (n - l) ' ' else s where l = length s -ppPunctuate :: Doc -> [Doc] -> Doc -ppPunctuate p (d1:d2:ds) = d1 <> p <> ppPunctuate p (d2 : ds) -ppPunctuate _ (d:[]) = d -ppPunctuate _ [] = PP.empty +ppPunctuate :: PP.Doc a -> [PP.Doc a] -> PP.Doc a +ppPunctuate p = PP.hcat . PP.punctuate p ------------------------------------------------------------------------ -- AddrRef @@ -56,25 +56,24 @@ data Displacement = Disp32 Imm32 | NoDisplacement deriving (Show, Eq, Ord) -prettyDisplacement :: Displacement -> Doc -prettyDisplacement NoDisplacement = text "0" -prettyDisplacement (Disp32 x) = text (show x) -prettyDisplacement (Disp8 x) = - if x >= 0 then - text ("0x" ++ showHex x "") - else - text ("-0x" ++ showHex (negate (fromIntegral x :: Int16)) "") +prettyDisplacement :: Displacement -> PP.Doc a +prettyDisplacement NoDisplacement = "0" +prettyDisplacement (Disp32 x) = fromString (show x) +prettyDisplacement (Disp8 x) = fromString $ + if x >= 0 + then "0x" ++ showHex x "" + else "-0x" ++ showHex (negate (fromIntegral x :: Int16)) "" -- | Append a displacement to an expression -appendDisplacement :: Displacement -> Doc -appendDisplacement NoDisplacement = text "" +appendDisplacement :: Displacement -> PP.Doc a +appendDisplacement NoDisplacement = "" appendDisplacement (Disp32 x) - | Imm32Concrete 0 <- x = text "" - | otherwise = text (show x) + | Imm32Concrete 0 <- x = "" + | otherwise = fromString (show x) appendDisplacement (Disp8 x) - | x > 0 = text ("+0x" ++ showHex x "") - | x == 0 = text "" - | otherwise = text ("-0x" ++ showHex (negate (fromIntegral x :: Int16)) "") + | x > 0 = fromString ("+0x" ++ showHex x "") + | x == 0 = "" + | otherwise = fromString ("-0x" ++ showHex (negate (fromIntegral x :: Int16)) "") -- | A references to an address in memory. data AddrRef @@ -98,47 +97,47 @@ data AddrRef | IP_Offset_64 !Segment Displacement deriving (Show, Eq, Ord) -ppAddrRef :: AddrRef -> Doc +ppAddrRef :: AddrRef -> PP.Doc a ppAddrRef addr = case addr of Addr_32 seg base roff off -> case base of Just r | isDefaultSeg32 seg r -> a - | seg == FS -> text (show seg) <> colon <+> a - | seg == GS -> text (show seg) <> colon <+> a - | otherwise -> a -- ((text (show seg) <> colon) <+>) + | seg == FS -> PP.pretty seg <> ":" PP.<+> a + | seg == GS -> PP.pretty seg <> ":" PP.<+> a + | otherwise -> a -- (((show seg) <> colon) PP.<+>) _ -> a where a = ppAddr base roff off -- or rip? this is 32 bits ... - IP_Offset_32 _seg off -> brackets $ text "ip" <> appendDisplacement off + IP_Offset_32 _seg off -> PP.brackets $ "ip" <> appendDisplacement off Offset_32 seg off -> prefix seg off Offset_64 seg off -> prefix seg off Addr_64 seg base roff off - | seg == FS || seg == GS -> text (show seg) <> colon <> a + | seg == FS || seg == GS -> PP.pretty seg <> ":" <> a | isDef -> a | otherwise -> a where a = ppAddr base roff off isDef = maybe False (isDefaultSeg64 seg) base - IP_Offset_64 _seg off -> brackets $ text "rip" <> appendDisplacement off + IP_Offset_64 _seg off -> PP.brackets $ "rip" <> appendDisplacement off where - prefix seg off = ppShowReg seg <> colon <> text (show off) + prefix seg off = PP.pretty seg <> ":" <> fromString (show off) - ppAddr :: Show r + ppAddr :: PP.Pretty r => Maybe r -- Base value -> Maybe (Int, r) -- Relative offset -> Displacement -- Offset - -> Doc + -> PP.Doc a ppAddr base roff off = case (base, roff) of (Nothing, Nothing) -> prettyDisplacement off (Nothing, Just (n, r)) -> - brackets (text (show r) <> text "*" <> int n <> appendDisplacement off) - (Just r, Nothing) -> brackets $ - text (show r) <> appendDisplacement off + PP.brackets (PP.pretty r <> "*" <> PP.pretty n <> appendDisplacement off) + (Just r, Nothing) -> PP.brackets $ + PP.pretty r <> appendDisplacement off (Just r, Just (n, r')) -> - brackets $ - text (show r) <> text "+" <> text (show r') <> text "*" <> int n <> appendDisplacement off + PP.brackets $ + PP.pretty r <> "+" <> PP.pretty r' <> "*" <> PP.pretty n <> appendDisplacement off ------------------------------------------------------------------------ -- Value @@ -192,51 +191,47 @@ data Value | JumpOffset !JumpSize !JumpOffset deriving (Show, Eq, Ord) -ppShowReg :: Show r => r -> Doc -ppShowReg r = text (show r) - -ppValue :: Value - -> Doc +ppValue :: Value -> PP.Doc a ppValue v = case v of - ControlReg r -> text (show r) - DebugReg r -> text (show r) - MMXReg r -> text (show r) - XMMReg r -> text (show r) - YMMReg r -> text (show r) - X87Register n -> text "st" <> if n == 0 then PP.empty else parens (int n) - SegmentValue r -> ppShowReg r + ControlReg r -> PP.pretty r + DebugReg r -> PP.pretty r + MMXReg r -> PP.pretty r + XMMReg r -> PP.pretty r + YMMReg r -> PP.pretty r + X87Register n -> "st" <> if n == 0 then "" else PP.parens (PP.pretty n) + SegmentValue r -> PP.pretty r -- do the "*" belong here or in ppAddrRef? - FarPointer addr -> text "??FAR PTR??" <+> ppAddrRef addr + FarPointer addr -> "??FAR PTR??" PP.<+> ppAddrRef addr VoidMem addr -> ppAddrRef addr - Mem8 addr -> text "BYTE PTR" <+> ppAddrRef addr - Mem16 addr -> text "WORD PTR" <+> ppAddrRef addr - Mem32 addr -> text "DWORD PTR" <+> ppAddrRef addr - Mem64 addr -> text "QWORD PTR" <+> ppAddrRef addr - Mem128 addr -> text "XMMWORD PTR" <+> ppAddrRef addr - Mem256 addr -> text "YMMWORD PTR" <+> ppAddrRef addr - FPMem32 addr -> text "DWORD PTR" <+> ppAddrRef addr - FPMem64 addr -> text "QWORD PTR" <+> ppAddrRef addr - FPMem80 addr -> text "TBYTE PTR" <+> ppAddrRef addr - ByteImm i -> text "0x" <> text (showHex i "") - WordImm i -> text "0x" <> text (showHex i "") - DWordImm i -> text (show i) - QWordImm i -> text (show i) + Mem8 addr -> "BYTE PTR" PP.<+> ppAddrRef addr + Mem16 addr -> "WORD PTR" PP.<+> ppAddrRef addr + Mem32 addr -> "DWORD PTR" PP.<+> ppAddrRef addr + Mem64 addr -> "QWORD PTR" PP.<+> ppAddrRef addr + Mem128 addr -> "XMMWORD PTR" PP.<+> ppAddrRef addr + Mem256 addr -> "YMMWORD PTR" PP.<+> ppAddrRef addr + FPMem32 addr -> "DWORD PTR" PP.<+> ppAddrRef addr + FPMem64 addr -> "QWORD PTR" PP.<+> ppAddrRef addr + FPMem80 addr -> "TBYTE PTR" PP.<+> ppAddrRef addr + ByteImm i -> "0x" <> fromString (showHex i "") + WordImm i -> "0x" <> fromString (showHex i "") + DWordImm i -> PP.pretty i + QWordImm i -> PP.pretty i ByteSignedImm i -> ppImm i WordSignedImm i -> ppImm i DWordSignedImm i -> ppImm i - ByteReg r -> ppShowReg r - WordReg r -> ppShowReg r - DWordReg r -> ppShowReg r - QWordReg r -> ppShowReg r - JumpOffset _ off -> text ("pc+" ++ show off) + ByteReg r -> PP.pretty r + WordReg r -> PP.pretty r + DWordReg r -> PP.pretty r + QWordReg r -> PP.pretty r + JumpOffset _ off -> "pc+" <> PP.pretty off -ppImm :: (Integral w, Show w) => w -> Doc -ppImm i | i >= 0 = text"0x" <> text (showHex i "") - -- Print negation after converting to integer +ppImm :: (Integral w, Show w) => w -> PP.Doc a +ppImm i | i >= 0 = "0x" <> fromString (showHex i "") + -- PrPP.pretty negation after converting to integer -- Recall that "negate minBound = minBound" with types like Int16, Int32, Int64. - | otherwise = text"-0x" <> text (showHex (negate (toInteger i)) "") + | otherwise = "-0x" <> fromString (showHex (negate (toInteger i)) "") ------------------------------------------------------------------------ -- InstructionInstance @@ -273,8 +268,7 @@ nonHex1Instrs = ["sar","sal","shr","shl","rcl","rcr","rol","ror"] -- | This pretty prints an instruction using close to Intel syntax. -- Jump offsets refer to PC rather than the relative address. -ppInstruction :: InstructionInstance - -> Doc +ppInstruction :: InstructionInstance -> PP.Doc a ppInstruction i = let sLockPrefix = ppLockPrefix (iiLockPrefix i) args = fst <$> iiArgs i @@ -284,19 +278,19 @@ ppInstruction i = -- special casem for one-bit shift instructions (_, [dst, ByteImm 1]) | op `elem` nonHex1Instrs -> - text (padToWidth 6 op) <+> ppValue dst <> comma <> text "1" + padToWidth 6 op PP.<+> ppValue dst <> ",1" -- objdump prints `xchg (e)ax,(e)ax` as nop - ("xchg", [WordReg AX, WordReg AX]) -> text "nop" - ("xchg", [DWordReg EAX, DWordReg EAX]) -> text "nop" + ("xchg", [WordReg AX, WordReg AX]) -> "nop" + ("xchg", [DWordReg EAX, DWordReg EAX]) -> "nop" _ -> case (args, iiLockPrefix i) of - ([], NoLockPrefix) -> text op - (_, NoLockPrefix) -> text (padToWidth 6 op) <+> ppPunctuate comma (ppValue <$> args) - ([], _) -> sLockPrefix <+> text op - (_,_) -> sLockPrefix <+> text op <+> ppPunctuate comma (ppValue <$> args) + ([], NoLockPrefix) -> fromString op + (_, NoLockPrefix) -> padToWidth 6 op PP.<+> ppPunctuate "," (ppValue <$> args) + ([], _) -> sLockPrefix PP.<+> fromString op + (_,_) -> sLockPrefix PP.<+> fromString op PP.<+> ppPunctuate "," (ppValue <$> args) -ppInstructionWith :: (a -> Doc) - -> InstructionInstanceF a - -> Doc +ppInstructionWith :: (i -> PP.Doc a) + -> InstructionInstanceF i + -> PP.Doc a ppInstructionWith ppv i = -- FIXME Too much copy-and-paste, but not clear how to abstract -- given the special cases @@ -304,9 +298,8 @@ ppInstructionWith ppv i = args = iiArgs i op = BSC.unpack (iiOp i) in - case (op, args) of - _ -> case (args, iiLockPrefix i) of - ([], NoLockPrefix) -> text op - (_, NoLockPrefix) -> text (padToWidth 6 op) <+> ppPunctuate comma (ppv <$> args) - ([], _) -> sLockPrefix <+> text op - (_,_) -> sLockPrefix <+> text op <+> ppPunctuate comma (ppv <$> args) + case (args, iiLockPrefix i) of + ([], NoLockPrefix) -> fromString op + (_, NoLockPrefix) -> padToWidth 6 op PP.<+> ppPunctuate "," (ppv <$> args) + ([], _) -> sLockPrefix PP.<+> fromString op + (_,_) -> sLockPrefix PP.<+> fromString op PP.<+> ppPunctuate "," (ppv <$> args) diff --git a/src/Flexdis86/Prefixes.hs b/src/Flexdis86/Prefixes.hs index 2841e6e..5c963f8 100644 --- a/src/Flexdis86/Prefixes.hs +++ b/src/Flexdis86/Prefixes.hs @@ -5,8 +5,11 @@ Maintainer : jhendrix@galois.com Defines prefix operations. -} + {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} + module Flexdis86.Prefixes ( Prefixes(..) , REX(..) @@ -39,8 +42,7 @@ import qualified Data.Bits as B import Data.Word ( Word8 ) import GHC.Generics import Numeric ( showHex ) -import qualified Text.PrettyPrint.ANSI.Leijen as PP -import Text.PrettyPrint.ANSI.Leijen hiding (empty, (<$>)) +import qualified Prettyprinter as PP import Text.Printf import Flexdis86.Segment @@ -81,12 +83,12 @@ data LockPrefix instance DS.NFData LockPrefix -ppLockPrefix :: LockPrefix -> Doc -ppLockPrefix NoLockPrefix = PP.empty -ppLockPrefix LockPrefix = text "lock" -ppLockPrefix RepPrefix = text "rep" -ppLockPrefix RepZPrefix = text "repz" -ppLockPrefix RepNZPrefix = text "repnz" +ppLockPrefix :: LockPrefix -> PP.Doc a +ppLockPrefix NoLockPrefix = "" +ppLockPrefix LockPrefix = "lock" +ppLockPrefix RepPrefix = "rep" +ppLockPrefix RepZPrefix = "repz" +ppLockPrefix RepNZPrefix = "repnz" ----------------------------------------------------------------------- -- REX diff --git a/src/Flexdis86/Register.hs b/src/Flexdis86/Register.hs index e44d42b..10f0542 100644 --- a/src/Flexdis86/Register.hs +++ b/src/Flexdis86/Register.hs @@ -5,11 +5,13 @@ Maintainer : jhendrix@galois.com Defines types for x86 registers. -} + {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ViewPatterns #-} + module Flexdis86.Register ( -- * 8-bit General Purpose registers Reg8 @@ -85,6 +87,7 @@ import Data.Bits import qualified Data.Vector as V import Data.Word ( Word8 ) import GHC.Generics +import qualified Prettyprinter as PP ------------------------------------------------------------------------ -- Reg8 @@ -124,7 +127,9 @@ pattern HighReg8 w <- (asHighReg -> Just w) where HighReg8 x = high_reg8 x instance Show Reg8 where - show (Reg8 i) = assert (i < 20) (regNames8 V.! (fromIntegral i)) + show (Reg8 i) = assert (i < 20) (regNames8 V.! fromIntegral i) + +instance PP.Pretty Reg8 where pretty = PP.unsafeViaShow regNames8 :: V.Vector String regNames8 = V.fromList [ "al", "cl", "dl", "bl" @@ -188,6 +193,8 @@ reg16_reg (Reg16 r) = Reg64 r instance Show Reg16 where show (Reg16 i) = assert (i < 16) (regNames16 V.! fromIntegral i) +instance PP.Pretty Reg16 where pretty = PP.unsafeViaShow + regNames16 :: V.Vector String regNames16 = V.fromList [ "ax", "cx", "dx", "bx" , "sp", "bp", "si", "di" @@ -234,6 +241,8 @@ reg32_reg (Reg32 r) = Reg64 r instance Show Reg32 where show (Reg32 i) = assert (i < 16) (regNames32 V.! fromIntegral i) +instance PP.Pretty Reg32 where pretty = PP.unsafeViaShow + regNames32 :: V.Vector String regNames32 = V.fromList [ "eax", "ecx", "edx", "ebx" , "esp", "ebp", "esi", "edi" @@ -289,6 +298,8 @@ reg64Idx = fromIntegral . unReg64 instance Show Reg64 where show (Reg64 i) = assert (i < 16) (regNames64 V.! fromIntegral i) +instance PP.Pretty Reg64 where pretty = PP.unsafeViaShow + regNames64 :: V.Vector String regNames64 = V.fromList [ "rax", "rcx", "rdx", "rbx" , "rsp", "rbp", "rsi", "rdi" @@ -355,6 +366,8 @@ newtype ControlReg = CR Word8 instance Show ControlReg where show (CR w) = "cr" ++ show w +instance PP.Pretty ControlReg where pretty = PP.unsafeViaShow + controlReg :: Word8 -> ControlReg controlReg w = assert (w < 16) $ CR w @@ -372,6 +385,8 @@ newtype DebugReg = DR Word8 instance Show DebugReg where show (DR w) = "dr" ++ show w +instance PP.Pretty DebugReg where pretty = PP.unsafeViaShow + debugReg :: Word8 -> DebugReg debugReg w = assert (w < 16) $ DR w @@ -388,6 +403,8 @@ newtype MMXReg = MMXR Word8 instance Show MMXReg where show (MMXR w) = "mm" ++ show w +instance PP.Pretty MMXReg where pretty = PP.unsafeViaShow + mmxReg :: Word8 -> MMXReg mmxReg w = assert (w < 8) $ MMXR w @@ -407,6 +424,8 @@ newtype XMMReg = XMMR Word8 instance Show XMMReg where show (XMMR w) = "xmm" ++ show w +instance PP.Pretty XMMReg where pretty = PP.unsafeViaShow + xmmReg :: Word8 -> XMMReg xmmReg w = assert (w < 16) $ XMMR w @@ -426,6 +445,8 @@ newtype YMMReg = YMMR Word8 instance Show YMMReg where show (YMMR w) = "ymm" ++ show w +instance PP.Pretty YMMReg where pretty = PP.unsafeViaShow + ymmReg :: Word8 -> YMMReg ymmReg w = assert (w < 16) $ YMMR w diff --git a/src/Flexdis86/Relocation.hs b/src/Flexdis86/Relocation.hs index 8a5fbe2..6df41cd 100644 --- a/src/Flexdis86/Relocation.hs +++ b/src/Flexdis86/Relocation.hs @@ -14,11 +14,11 @@ module Flexdis86.Relocation , UImm64(..) ) where - import Data.BinarySymbols import Data.Int import Data.Word import Numeric +import qualified Prettyprinter as PP ------------------------------------------------------------------------ -- JumpOffset @@ -75,6 +75,8 @@ instance Show Imm32 where . (if isSigned then showString ",S" else id) . showChar ']' +instance PP.Pretty Imm32 where pretty = PP.unsafeViaShow + -- | A 32-bit value which could either be a specific number, or a -- relocation that should be computed at later load/link time. data UImm64 @@ -96,6 +98,8 @@ instance Show UImm64 where . shows o . showChar ']' +instance PP.Pretty UImm64 where pretty = PP.unsafeViaShow + showOff :: Int64 -> ShowS showOff i -- convert to Integer before negate (negate minBound == minBound :: Int64) @@ -112,3 +116,5 @@ instance Show JumpOffset where . showChar ',' . showOff off . showChar ']' + +instance PP.Pretty JumpOffset where pretty = PP.unsafeViaShow diff --git a/src/Flexdis86/Segment.hs b/src/Flexdis86/Segment.hs index 112767f..0a89f0f 100644 --- a/src/Flexdis86/Segment.hs +++ b/src/Flexdis86/Segment.hs @@ -5,9 +5,11 @@ Maintainer : jhendrix@galois.com Defines a datatype for segments and supporting operations. -} + {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Safe #-} + module Flexdis86.Segment ( Segment , pattern ES @@ -23,8 +25,9 @@ module Flexdis86.Segment ) where import qualified Control.DeepSeq as DS -import Data.Word ( Word8 ) +import Data.Word (Word8) import GHC.Generics +import qualified Prettyprinter as PP import Flexdis86.Register @@ -65,6 +68,9 @@ instance Show Segment where show FS = "fs" show GS = "gs" +instance PP.Pretty Segment where + pretty = PP.unsafeViaShow + -- | Return segment register by index or fail. segmentRegisterByIndex :: Monad m => Word8 -> m Segment segmentRegisterByIndex r