x86-64bit 0.1.2 → 0.1.3
raw patch · 9 files changed
+1047/−943 lines, 9 files
Files
- CHANGELOG.md +11/−1
- CodeGen/X86.hs +1/−0
- CodeGen/X86/Asm.hs +547/−534
- CodeGen/X86/CodeGen.hs +432/−392
- CodeGen/X86/Examples.hs +1/−3
- CodeGen/X86/Tests.hs +8/−8
- CodeGen/X86/Utils.hs +21/−4
- TODO.md +23/−0
- x86-64bit.cabal +3/−1
CHANGELOG.md view
@@ -1,6 +1,16 @@+# Version 0.1.3 + +- jmpq instruction support (George Stelle) +- support near conditional jumps +- support automatic decision between short and near conditional jumps for backward references +- support alternative condition names +- make possible to use labels as relative immediate values (not used yet) +- bugfix + - fail if a short jump is out of range + # Version 0.1.2 -- Windows operating system support +- Windows operating system support (Balázs Kőműves) - GHC 7.10 support - TODO.md file added
CodeGen/X86.hs view
@@ -42,6 +42,7 @@ , (<>) , (<.>), (<:>) , j, j_back, if_ + , lea8 , leaData -- * Compilation , Callable
CodeGen/X86/Asm.hs view
@@ -1,534 +1,547 @@-{-# language LambdaCase #-} -{-# language BangPatterns #-} -{-# language ViewPatterns #-} -{-# language PatternGuards #-} -{-# language PatternSynonyms #-} -{-# language NoMonomorphismRestriction #-} -{-# language ScopedTypeVariables #-} -{-# language RankNTypes #-} -{-# language TypeFamilies #-} -{-# language GADTs #-} -{-# language DataKinds #-} -{-# language KindSignatures #-} -{-# language PolyKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GeneralizedNewtypeDeriving #-} -module CodeGen.X86.Asm where - -import Numeric -import Data.List -import Data.Bits -import Data.Int -import Data.Word -import Control.Monad -import Control.Arrow -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State - -------------------------------------------------------- utils - -everyNth n [] = [] -everyNth n xs = take n xs: everyNth n (drop n xs) - -showNibble :: (Integral a, Bits a) => Int -> a -> Char -showNibble n x = toEnum (b + if b < 10 then 48 else 87) - where - b = fromIntegral $ x `shiftR` (4*n) .&. 0x0f - -showByte b = [showNibble 1 b, showNibble 0 b] - -showHex' x = "0x" ++ showHex x "" - -------------------------------------------------------- byte sequences - -newtype Bytes = Bytes {getBytes :: [Word8]} - deriving (Eq, Monoid) - -instance Show Bytes where - show (Bytes ws) = unwords $ map (concatMap showByte) $ everyNth 4 ws - -showBytes (Bytes ws) = unlines $ zipWith showLine [0 ::Int ..] $ everyNth 16 ws - where - showLine n bs = [showNibble 2 n, showNibble 1 n, showNibble 0 n, '0', ' ', ' '] ++ show (Bytes bs) - -bytesCount (Bytes x) = length x - -class HasBytes a where toBytes :: a -> Bytes - -instance HasBytes Word8 where toBytes w = Bytes [w] -instance HasBytes Word16 where toBytes w = Bytes [fromIntegral w, fromIntegral $ w `shiftR` 8] -instance HasBytes Word32 where toBytes w = Bytes [fromIntegral $ w `shiftR` n | n <- [0, 8.. 24]] -instance HasBytes Word64 where toBytes w = Bytes [fromIntegral $ w `shiftR` n | n <- [0, 8.. 56]] - -instance HasBytes Int8 where toBytes w = toBytes (fromIntegral w :: Word8) -instance HasBytes Int16 where toBytes w = toBytes (fromIntegral w :: Word16) -instance HasBytes Int32 where toBytes w = toBytes (fromIntegral w :: Word32) -instance HasBytes Int64 where toBytes w = toBytes (fromIntegral w :: Word64) - -------------------------------------------------------- sizes - -data Size = S8 | S16 | S32 | S64 - deriving (Eq, Ord) - -instance Show Size where - show = \case - S8 -> "byte" - S16 -> "word" - S32 -> "dword" - S64 -> "qword" - -mkSize 1 = S8 -mkSize 2 = S16 -mkSize 4 = S32 -mkSize 8 = S64 - -sizeLen = \case - S8 -> 1 - S16 -> 2 - S32 -> 4 - S64 -> 8 - -class HasSize a where size :: a -> Size - -instance HasSize Word8 where size _ = S8 -instance HasSize Word16 where size _ = S16 -instance HasSize Word32 where size _ = S32 -instance HasSize Word64 where size _ = S64 -instance HasSize Int8 where size _ = S8 -instance HasSize Int16 where size _ = S16 -instance HasSize Int32 where size _ = S32 -instance HasSize Int64 where size _ = S64 - --- | Singleton type for size -data SSize (s :: Size) where - SSize8 :: SSize S8 - SSize16 :: SSize S16 - SSize32 :: SSize S32 - SSize64 :: SSize S64 - -instance HasSize (SSize s) where - size = \case - SSize8 -> S8 - SSize16 -> S16 - SSize32 -> S32 - SSize64 -> S64 - -class IsSize (s :: Size) where - ssize :: SSize s - -instance IsSize S8 where ssize = SSize8 -instance IsSize S16 where ssize = SSize16 -instance IsSize S32 where ssize = SSize32 -instance IsSize S64 where ssize = SSize64 - -data EqT s s' where - Refl :: EqT s s - -sizeEqCheck :: forall s s' f g . (IsSize s, IsSize s') => f s -> g s' -> Maybe (EqT s s') -sizeEqCheck _ _ = case (ssize :: SSize s, ssize :: SSize s') of - (SSize8 , SSize8) -> Just Refl - (SSize16, SSize16) -> Just Refl - (SSize32, SSize32) -> Just Refl - (SSize64, SSize64) -> Just Refl - _ -> Nothing - -------------------------------------------------------- scale - --- replace with Size? -newtype Scale = Scale Word8 - deriving (Eq) - -s1 = Scale 0x0 -s2 = Scale 0x1 -s4 = Scale 0x2 -s8 = Scale 0x3 - -scaleFactor (Scale i) = case i of - 0x0 -> 1 - 0x1 -> 2 - 0x2 -> 4 - 0x3 -> 8 - -------------------------------------------------------- operand - -data Operand :: Size -> Access -> * where - ImmOp :: Int64 -> Operand s R - RegOp :: Reg s -> Operand s rw - MemOp :: IsSize s' => Addr s' -> Operand s rw - IPMemOp :: Immediate Int32 -> Operand s rw - -addr = MemOp - -data Immediate a - = Immediate a - | LabelRelAddr !LabelIndex - -type LabelIndex = Int - --- | Operand access modes -data Access - = R -- ^ readable operand - | RW -- ^ readable and writeable operand - -data Reg :: Size -> * where - NormalReg :: Word8 -> Reg s - HighReg :: Word8 -> Reg S8 - -data Addr s = Addr - { baseReg :: BaseReg s - , displacement :: Displacement - , indexReg :: IndexReg s - } - -type BaseReg s = Maybe (Reg s) -type IndexReg s = Maybe (Scale, Reg s) -type Displacement = Maybe Int32 - -pattern NoDisp = Nothing -pattern Disp a = Just a - -pattern NoIndex = Nothing -pattern IndexReg a b = Just (a, b) - -ipBase = IPMemOp $ LabelRelAddr 0 - -instance Eq (Reg s) where - NormalReg a == NormalReg b = a == b - HighReg a == HighReg b = a == b - _ == _ = False - -instance IsSize s => Show (Reg s) where - show = \case - HighReg i -> (["ah"," ch", "dh", "bh"] ++ repeat err) !! fromIntegral i - r@(NormalReg i) -> (!! fromIntegral i) . (++ repeat err) $ case size r of - S8 -> ["al", "cl", "dl", "bl", "spl", "bpl", "sil", "dil"] ++ map (++ "b") r8 - S16 -> r0 ++ map (++ "w") r8 - S32 -> map ('e':) r0 ++ map (++ "d") r8 - S64 -> map ('r':) r0 ++ r8 - where - r0 = ["ax", "cx", "dx", "bx", "sp", "bp", "si", "di"] - r8 = ["r8", "r9", "r10", "r11", "r12", "r13", "r14", "r15"] - where - err = error $ "show @ RegOp" -- ++ show (s, i) - -instance IsSize s => Show (Addr s) where - show (Addr b d i) = showSum $ shb b ++ shd d ++ shi i - where - shb Nothing = [] - shb (Just x) = [(True, show x)] - shd NoDisp = [] - shd (Disp x) = [(signum x /= (-1), show (abs x))] - shi NoIndex = [] - shi (IndexReg sc x) = [(True, show' (scaleFactor sc) ++ show x)] - show' 1 = "" - show' n = show n ++ " * " - showSum [] = "0" - showSum ((True, x): xs) = x ++ g xs - showSum ((False, x): xs) = "-" ++ x ++ g xs - g = concatMap (\(a, b) -> f a ++ b) - f True = " + " - f False = " - " - -instance IsSize s => Show (Operand s a) where - show = showOperand show - -showOperand mklab = \case - ImmOp w -> show w - RegOp r -> show r - r@(MemOp a) -> show (size r) ++ " [" ++ show a ++ "]" - r@(IPMemOp (Immediate x)) -> show (size r) ++ " [" ++ "rel " ++ show x ++ "]" - r@(IPMemOp (LabelRelAddr x)) -> show (size r) ++ " [" ++ "rel " ++ mklab x ++ "]" - where - showp x | x < 0 = " - " ++ show (-x) - showp x = " + " ++ show x - -instance IsSize s => HasSize (Operand s a) where - size _ = size (ssize :: SSize s) - -instance IsSize s => HasSize (Addr s) where - size _ = size (ssize :: SSize s) - -instance IsSize s => HasSize (BaseReg s) where - size _ = size (ssize :: SSize s) - -instance IsSize s => HasSize (Reg s) where - size _ = size (ssize :: SSize s) - -instance IsSize s => HasSize (IndexReg s) where - size _ = size (ssize :: SSize s) - -imm :: Integral a => a -> Operand s R -imm = ImmOp . fromIntegral - -instance Monoid (Addr s) where - mempty = Addr (getFirst mempty) (getFirst mempty) (getFirst mempty) - Addr a b c `mappend` Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (getFirst $ First c <> First c') - -instance Monoid (IndexReg s) where - mempty = NoIndex - i `mappend` NoIndex = i - NoIndex `mappend` i = i - -base :: Operand s RW -> Addr s -base (RegOp x) = Addr (Just x) NoDisp NoIndex - -index :: Scale -> Operand s RW -> Addr s -index sc (RegOp x) = Addr Nothing NoDisp (IndexReg sc x) - -index1 = index s1 -index2 = index s2 -index4 = index s4 -index8 = index s8 - -disp :: Int32 -> Addr s -disp x = Addr Nothing (Disp x) NoIndex - -reg = RegOp . NormalReg - -rax, rcx, rdx, rbx, rsp, rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 :: Operand S64 rw -rax = reg 0x0 -rcx = reg 0x1 -rdx = reg 0x2 -rbx = reg 0x3 -rsp = reg 0x4 -rbp = reg 0x5 -rsi = reg 0x6 -rdi = reg 0x7 -r8 = reg 0x8 -r9 = reg 0x9 -r10 = reg 0xa -r11 = reg 0xb -r12 = reg 0xc -r13 = reg 0xd -r14 = reg 0xe -r15 = reg 0xf - -eax, ecx, edx, ebx, esp, ebp, esi, edi, r8d, r9d, r10d, r11d, r12d, r13d, r14d, r15d :: Operand S32 rw -eax = reg 0x0 -ecx = reg 0x1 -edx = reg 0x2 -ebx = reg 0x3 -esp = reg 0x4 -ebp = reg 0x5 -esi = reg 0x6 -edi = reg 0x7 -r8d = reg 0x8 -r9d = reg 0x9 -r10d = reg 0xa -r11d = reg 0xb -r12d = reg 0xc -r13d = reg 0xd -r14d = reg 0xe -r15d = reg 0xf - -ax, cx, dx, bx, sp, bp, si, di, r8w, r9w, r10w, r11w, r12w, r13w, r14w, r15w :: Operand S16 rw -ax = reg 0x0 -cx = reg 0x1 -dx = reg 0x2 -bx = reg 0x3 -sp = reg 0x4 -bp = reg 0x5 -si = reg 0x6 -di = reg 0x7 -r8w = reg 0x8 -r9w = reg 0x9 -r10w = reg 0xa -r11w = reg 0xb -r12w = reg 0xc -r13w = reg 0xd -r14w = reg 0xe -r15w = reg 0xf - -al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b :: Operand S8 rw -al = reg 0x0 -cl = reg 0x1 -dl = reg 0x2 -bl = reg 0x3 -spl = reg 0x4 -bpl = reg 0x5 -sil = reg 0x6 -dil = reg 0x7 -r8b = reg 0x8 -r9b = reg 0x9 -r10b = reg 0xa -r11b = reg 0xb -r12b = reg 0xc -r13b = reg 0xd -r14b = reg 0xe -r15b = reg 0xf - -ah = RegOp $ HighReg 0x0 -ch = RegOp $ HighReg 0x1 -dh = RegOp $ HighReg 0x2 -bh = RegOp $ HighReg 0x3 - -pattern RegA = RegOp (NormalReg 0x0) - -pattern RegCl :: Operand S8 r -pattern RegCl = RegOp (NormalReg 0x1) - --------------------------------------------------------------- - -resizeOperand :: IsSize s' => Operand s RW -> Operand s' RW -resizeOperand (RegOp x) = RegOp $ resizeRegCode x -resizeOperand (MemOp a) = MemOp a -resizeOperand (IPMemOp a) = IPMemOp a - -resizeRegCode :: Reg s -> Reg s' -resizeRegCode (NormalReg i) = NormalReg i - -pattern MemLike <- (isMemOp -> True) - -isMemOp MemOp{} = True -isMemOp IPMemOp{} = True -isMemOp _ = False - --------------------------------------------------------------- condition - -newtype Condition = Condition Word8 - -pattern O = Condition 0x0 -pattern NO = Condition 0x1 -pattern C = Condition 0x2 -- b -pattern NC = Condition 0x3 -- nb -pattern Z = Condition 0x4 -- e -pattern NZ = Condition 0x5 -- ne -pattern BE = Condition 0x6 -- na -pattern NBE = Condition 0x7 -- a -pattern S = Condition 0x8 -pattern NS = Condition 0x9 -pattern P = Condition 0xa -pattern NP = Condition 0xb -pattern L = Condition 0xc -pattern NL = Condition 0xd -pattern LE = Condition 0xe -- ng -pattern NLE = Condition 0xf -- g - -instance Show Condition where - show (Condition x) = case x of - 0x0 -> "o" - 0x1 -> "no" - 0x2 -> "c" - 0x3 -> "nc" - 0x4 -> "z" - 0x5 -> "nz" - 0x6 -> "be" - 0x7 -> "nbe" - 0x8 -> "s" - 0x9 -> "ns" - 0xa -> "p" - 0xb -> "np" - 0xc -> "l" - 0xd -> "nl" - 0xe -> "le" - 0xf -> "nle" - --------------------------------------------------------------- asm code - -data Code where - Ret, Nop, PushF, PopF, Cmc, Clc, Stc, Cli, Sti, Cld, Std :: Code - - Inc, Dec, Not, Neg :: IsSize s => Operand s RW -> Code - Add, Or, Adc, Sbb, And, Sub, Xor, Cmp, Test, Mov :: IsSize s => Operand s RW -> Operand s r -> Code - Rol, Ror, Rcl, Rcr, Shl, Shr, Sar :: IsSize s => Operand s RW -> Operand S8 r -> Code - - Xchg :: IsSize s => Operand s RW -> Operand s RW -> Code - Lea :: (IsSize s, IsSize s') => Operand s RW -> Operand s' RW -> Code - - Pop :: Operand S64 RW -> Code - Push :: Operand S64 r -> Code - - Call :: Operand S64 RW -> Code - - J :: Condition -> Code - Jmp :: Code - - Label :: Code - Scope :: Code -> Code - Up :: Code -> Code - - Data :: Bytes -> Code - Align :: Size -> Code - - EmptyCode :: Code - AppendCode :: Code -> Code -> Code - -instance Monoid Code where - mempty = EmptyCode - mappend = AppendCode - -------------- - -showCode = \case - EmptyCode -> return () - AppendCode a b -> showCode a >> showCode b - - Scope c -> get >>= \i -> put (i+1) >> local (i:) (showCode c) - - Up c -> local tail $ showCode c - - J cc -> getLabel 0 >>= \l -> showOp ("j" ++ show cc) l - Jmp -> getLabel 0 >>= \l -> showOp "jmp" l - Label -> getLabel 0 >>= codeLine - - x -> showCodeFrag x - -getLabel i = ($ i) <$> getLabels - -getLabels = f <$> ask - where - f xs i = case drop i xs of - [] -> ".l?" - (i: _) -> ".l" ++ show i - -codeLine x = tell [x] - -showCodeFrag = \case - Add op1 op2 -> showOp2 "add" op1 op2 - Or op1 op2 -> showOp2 "or" op1 op2 - Adc op1 op2 -> showOp2 "adc" op1 op2 - Sbb op1 op2 -> showOp2 "sbb" op1 op2 - And op1 op2 -> showOp2 "and" op1 op2 - Sub op1 op2 -> showOp2 "sub" op1 op2 - Xor op1 op2 -> showOp2 "xor" op1 op2 - Cmp op1 op2 -> showOp2 "cmp" op1 op2 - Test op1 op2 -> showOp2 "test" op1 op2 - Rol op1 op2 -> showOp2 "rol" op1 op2 - Ror op1 op2 -> showOp2 "rol" op1 op2 - Rcl op1 op2 -> showOp2 "rol" op1 op2 - Rcr op1 op2 -> showOp2 "rol" op1 op2 - Shl op1 op2 -> showOp2 "rol" op1 op2 - Shr op1 op2 -> showOp2 "rol" op1 op2 - Sar op1 op2 -> showOp2 "rol" op1 op2 - Mov op1 op2 -> showOp2 "mov" op1 op2 - Lea op1 op2 -> showOp2 "lea" op1 op2 - Xchg op1 op2 -> showOp2 "xchg" op1 op2 - Inc op -> showOp1 "inc" op - Dec op -> showOp1 "dec" op - Not op -> showOp1 "not" op - Neg op -> showOp1 "neg" op - Pop op -> showOp1 "pop" op - Push op -> showOp1 "push" op - Call op -> showOp1 "call" op - Ret -> showOp0 "ret" - Nop -> showOp0 "nop" - PushF -> showOp0 "pushf" - PopF -> showOp0 "popf" - Cmc -> showOp0 "cmc" - Clc -> showOp0 "clc" - Stc -> showOp0 "stc" - Cli -> showOp0 "cli" - Sti -> showOp0 "sti" - Cld -> showOp0 "cld" - Std -> showOp0 "std" - - Align s -> codeLine $ ".align " ++ show s - Data (Bytes x) -> showOp "db" $ intercalate ", " (showByte <$> x) ++ " ; " ++ show (toEnum . fromIntegral <$> x :: String) - -showOp0 s = codeLine s -showOp s a = showOp0 $ s ++ " " ++ a -showOp1 s a = getLabels >>= \f -> showOp s $ showOperand f a -showOp2 s a b = getLabels >>= \f -> showOp s $ showOperand f a ++ ", " ++ showOperand f b - +{-# language LambdaCase #-}+{-# language BangPatterns #-}+{-# language ViewPatterns #-}+{-# language PatternGuards #-}+{-# language PatternSynonyms #-}+{-# language NoMonomorphismRestriction #-}+{-# language ScopedTypeVariables #-}+{-# language RankNTypes #-}+{-# language TypeFamilies #-}+{-# language GADTs #-}+{-# language DataKinds #-}+{-# language KindSignatures #-}+{-# language PolyKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GeneralizedNewtypeDeriving #-}+module CodeGen.X86.Asm where++import Numeric+import Data.List+import Data.Bits+import Data.Int+import Data.Word+import Control.Monad+import Control.Arrow+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State++------------------------------------------------------- utils++everyNth n [] = []+everyNth n xs = take n xs: everyNth n (drop n xs)++showNibble :: (Integral a, Bits a) => Int -> a -> Char+showNibble n x = toEnum (b + if b < 10 then 48 else 87)+ where+ b = fromIntegral $ x `shiftR` (4*n) .&. 0x0f++showByte b = [showNibble 1 b, showNibble 0 b]++showHex' x = "0x" ++ showHex x ""++------------------------------------------------------- byte sequences++newtype Bytes = Bytes {getBytes :: [Word8]}+ deriving (Eq, Monoid)++instance Show Bytes where+ show (Bytes ws) = unwords $ map (concatMap showByte) $ everyNth 4 ws++showBytes (Bytes ws) = unlines $ zipWith showLine [0 ::Int ..] $ everyNth 16 ws+ where+ showLine n bs = [showNibble 2 n, showNibble 1 n, showNibble 0 n, '0', ' ', ' '] ++ show (Bytes bs)++bytesCount (Bytes x) = length x++class HasBytes a where toBytes :: a -> Bytes++instance HasBytes Word8 where toBytes w = Bytes [w]+instance HasBytes Word16 where toBytes w = Bytes [fromIntegral w, fromIntegral $ w `shiftR` 8]+instance HasBytes Word32 where toBytes w = Bytes [fromIntegral $ w `shiftR` n | n <- [0, 8.. 24]]+instance HasBytes Word64 where toBytes w = Bytes [fromIntegral $ w `shiftR` n | n <- [0, 8.. 56]]++instance HasBytes Int8 where toBytes w = toBytes (fromIntegral w :: Word8)+instance HasBytes Int16 where toBytes w = toBytes (fromIntegral w :: Word16)+instance HasBytes Int32 where toBytes w = toBytes (fromIntegral w :: Word32)+instance HasBytes Int64 where toBytes w = toBytes (fromIntegral w :: Word64)++------------------------------------------------------- sizes++data Size = S8 | S16 | S32 | S64+ deriving (Eq, Ord)++instance Show Size where+ show = \case+ S8 -> "byte"+ S16 -> "word"+ S32 -> "dword"+ S64 -> "qword"++mkSize 1 = S8+mkSize 2 = S16+mkSize 4 = S32+mkSize 8 = S64++sizeLen = \case+ S8 -> 1+ S16 -> 2+ S32 -> 4+ S64 -> 8++class HasSize a where size :: a -> Size++instance HasSize Word8 where size _ = S8+instance HasSize Word16 where size _ = S16+instance HasSize Word32 where size _ = S32+instance HasSize Word64 where size _ = S64+instance HasSize Int8 where size _ = S8+instance HasSize Int16 where size _ = S16+instance HasSize Int32 where size _ = S32+instance HasSize Int64 where size _ = S64++-- | Singleton type for size+data SSize (s :: Size) where+ SSize8 :: SSize S8+ SSize16 :: SSize S16+ SSize32 :: SSize S32+ SSize64 :: SSize S64++instance HasSize (SSize s) where+ size = \case+ SSize8 -> S8+ SSize16 -> S16+ SSize32 -> S32+ SSize64 -> S64++class IsSize (s :: Size) where+ ssize :: SSize s++instance IsSize S8 where ssize = SSize8+instance IsSize S16 where ssize = SSize16+instance IsSize S32 where ssize = SSize32+instance IsSize S64 where ssize = SSize64++data EqT s s' where+ Refl :: EqT s s++sizeEqCheck :: forall s s' f g . (IsSize s, IsSize s') => f s -> g s' -> Maybe (EqT s s')+sizeEqCheck _ _ = case (ssize :: SSize s, ssize :: SSize s') of+ (SSize8 , SSize8) -> Just Refl+ (SSize16, SSize16) -> Just Refl+ (SSize32, SSize32) -> Just Refl+ (SSize64, SSize64) -> Just Refl+ _ -> Nothing++------------------------------------------------------- scale++-- replace with Size?+newtype Scale = Scale Word8+ deriving (Eq)++s1 = Scale 0x0+s2 = Scale 0x1+s4 = Scale 0x2+s8 = Scale 0x3++scaleFactor (Scale i) = case i of+ 0x0 -> 1+ 0x1 -> 2+ 0x2 -> 4+ 0x3 -> 8++------------------------------------------------------- operand++data Operand :: Size -> Access -> * where+ ImmOp :: Immediate Int64 -> Operand s R+ RegOp :: Reg s -> Operand s rw+ MemOp :: IsSize s' => Addr s' -> Operand s rw+ IPMemOp :: Immediate Int32 -> Operand s rw++addr = MemOp++data Immediate a+ = Immediate a+ | LabelRelValue Size{-size hint-} !LabelIndex++type LabelIndex = Int++-- | Operand access modes+data Access+ = R -- ^ readable operand+ | RW -- ^ readable and writeable operand++data Reg :: Size -> * where+ NormalReg :: Word8 -> Reg s+ HighReg :: Word8 -> Reg S8++data Addr s = Addr+ { baseReg :: BaseReg s+ , displacement :: Displacement+ , indexReg :: IndexReg s+ }++type BaseReg s = Maybe (Reg s)+type IndexReg s = Maybe (Scale, Reg s)+type Displacement = Maybe Int32++pattern NoDisp = Nothing+pattern Disp a = Just a++pattern NoIndex = Nothing+pattern IndexReg a b = Just (a, b)++ipBase = IPMemOp $ LabelRelValue S32 0++instance Eq (Reg s) where+ NormalReg a == NormalReg b = a == b+ HighReg a == HighReg b = a == b+ _ == _ = False++instance IsSize s => Show (Reg s) where+ show = \case+ HighReg i -> (["ah"," ch", "dh", "bh"] ++ repeat err) !! fromIntegral i+ r@(NormalReg i) -> (!! fromIntegral i) . (++ repeat err) $ case size r of+ S8 -> ["al", "cl", "dl", "bl", "spl", "bpl", "sil", "dil"] ++ map (++ "b") r8+ S16 -> r0 ++ map (++ "w") r8+ S32 -> map ('e':) r0 ++ map (++ "d") r8+ S64 -> map ('r':) r0 ++ r8+ where+ r0 = ["ax", "cx", "dx", "bx", "sp", "bp", "si", "di"]+ r8 = ["r8", "r9", "r10", "r11", "r12", "r13", "r14", "r15"]+ where+ err = error $ "show @ RegOp" -- ++ show (s, i)++instance IsSize s => Show (Addr s) where+ show (Addr b d i) = showSum $ shb b ++ shd d ++ shi i+ where+ shb Nothing = []+ shb (Just x) = [(True, show x)]+ shd NoDisp = []+ shd (Disp x) = [(signum x /= (-1), show (abs x))]+ shi NoIndex = []+ shi (IndexReg sc x) = [(True, show' (scaleFactor sc) ++ show x)]+ show' 1 = ""+ show' n = show n ++ " * "+ showSum [] = "0"+ showSum ((True, x): xs) = x ++ g xs+ showSum ((False, x): xs) = "-" ++ x ++ g xs+ g = concatMap (\(a, b) -> f a ++ b)+ f True = " + "+ f False = " - "++instance IsSize s => Show (Operand s a) where+ show = showOperand show++showOperand mklab = \case+ ImmOp w -> showImm w+ RegOp r -> show r+ r@(MemOp a) -> show (size r) ++ " [" ++ show a ++ "]"+ r@(IPMemOp x) -> show (size r) ++ " [" ++ "rel " ++ showImm x ++ "]"+ where+ showp x | x < 0 = " - " ++ show (-x)+ showp x = " + " ++ show x++ showImm :: Show a => Immediate a -> String+ showImm (Immediate x) = show x+ showImm (LabelRelValue _ x) = mklab x++instance IsSize s => HasSize (Operand s a) where+ size _ = size (ssize :: SSize s)++instance IsSize s => HasSize (Addr s) where+ size _ = size (ssize :: SSize s)++instance IsSize s => HasSize (BaseReg s) where+ size _ = size (ssize :: SSize s)++instance IsSize s => HasSize (Reg s) where+ size _ = size (ssize :: SSize s)++instance IsSize s => HasSize (IndexReg s) where+ size _ = size (ssize :: SSize s)++imm :: Integral a => a -> Operand s R+imm = ImmOp . Immediate . fromIntegral++instance Monoid (Addr s) where+ mempty = Addr (getFirst mempty) (getFirst mempty) (getFirst mempty)+ Addr a b c `mappend` Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (getFirst $ First c <> First c')++instance Monoid (IndexReg s) where+ mempty = NoIndex+ i `mappend` NoIndex = i+ NoIndex `mappend` i = i++base :: Operand s RW -> Addr s+base (RegOp x) = Addr (Just x) NoDisp NoIndex++index :: Scale -> Operand s RW -> Addr s+index sc (RegOp x) = Addr Nothing NoDisp (IndexReg sc x)++index1 = index s1+index2 = index s2+index4 = index s4+index8 = index s8++disp :: Int32 -> Addr s+disp x = Addr Nothing (Disp x) NoIndex++reg = RegOp . NormalReg++rax, rcx, rdx, rbx, rsp, rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 :: Operand S64 rw+rax = reg 0x0+rcx = reg 0x1+rdx = reg 0x2+rbx = reg 0x3+rsp = reg 0x4+rbp = reg 0x5+rsi = reg 0x6+rdi = reg 0x7+r8 = reg 0x8+r9 = reg 0x9+r10 = reg 0xa+r11 = reg 0xb+r12 = reg 0xc+r13 = reg 0xd+r14 = reg 0xe+r15 = reg 0xf++eax, ecx, edx, ebx, esp, ebp, esi, edi, r8d, r9d, r10d, r11d, r12d, r13d, r14d, r15d :: Operand S32 rw+eax = reg 0x0+ecx = reg 0x1+edx = reg 0x2+ebx = reg 0x3+esp = reg 0x4+ebp = reg 0x5+esi = reg 0x6+edi = reg 0x7+r8d = reg 0x8+r9d = reg 0x9+r10d = reg 0xa+r11d = reg 0xb+r12d = reg 0xc+r13d = reg 0xd+r14d = reg 0xe+r15d = reg 0xf++ax, cx, dx, bx, sp, bp, si, di, r8w, r9w, r10w, r11w, r12w, r13w, r14w, r15w :: Operand S16 rw+ax = reg 0x0+cx = reg 0x1+dx = reg 0x2+bx = reg 0x3+sp = reg 0x4+bp = reg 0x5+si = reg 0x6+di = reg 0x7+r8w = reg 0x8+r9w = reg 0x9+r10w = reg 0xa+r11w = reg 0xb+r12w = reg 0xc+r13w = reg 0xd+r14w = reg 0xe+r15w = reg 0xf++al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b :: Operand S8 rw+al = reg 0x0+cl = reg 0x1+dl = reg 0x2+bl = reg 0x3+spl = reg 0x4+bpl = reg 0x5+sil = reg 0x6+dil = reg 0x7+r8b = reg 0x8+r9b = reg 0x9+r10b = reg 0xa+r11b = reg 0xb+r12b = reg 0xc+r13b = reg 0xd+r14b = reg 0xe+r15b = reg 0xf++ah = RegOp $ HighReg 0x0+ch = RegOp $ HighReg 0x1+dh = RegOp $ HighReg 0x2+bh = RegOp $ HighReg 0x3++pattern RegA = RegOp (NormalReg 0x0)++pattern RegCl :: Operand S8 r+pattern RegCl = RegOp (NormalReg 0x1)++--------------------------------------------------------------++resizeOperand :: IsSize s' => Operand s RW -> Operand s' RW+resizeOperand (RegOp x) = RegOp $ resizeRegCode x+resizeOperand (MemOp a) = MemOp a+resizeOperand (IPMemOp a) = IPMemOp a++resizeRegCode :: Reg s -> Reg s'+resizeRegCode (NormalReg i) = NormalReg i++pattern MemLike <- (isMemOp -> True)++isMemOp MemOp{} = True+isMemOp IPMemOp{} = True+isMemOp _ = False++-------------------------------------------------------------- condition++newtype Condition = Condition Word8++pattern O = Condition 0x0+pattern NO = Condition 0x1+pattern B = Condition 0x2+pattern C = Condition 0x2+pattern NB = Condition 0x3+pattern NC = Condition 0x3+pattern E = Condition 0x4+pattern Z = Condition 0x4+pattern NE = Condition 0x5+pattern NZ = Condition 0x5+pattern NA = Condition 0x6+pattern BE = Condition 0x6+pattern A = Condition 0x7+pattern NBE = Condition 0x7+pattern S = Condition 0x8+pattern NS = Condition 0x9+pattern P = Condition 0xa+pattern NP = Condition 0xb+pattern L = Condition 0xc+pattern NL = Condition 0xd+pattern NG = Condition 0xe+pattern LE = Condition 0xe+pattern G = Condition 0xf+pattern NLE = Condition 0xf++instance Show Condition where+ show (Condition x) = case x of+ 0x0 -> "o"+ 0x1 -> "no"+ 0x2 -> "c"+ 0x3 -> "nc"+ 0x4 -> "z"+ 0x5 -> "nz"+ 0x6 -> "be"+ 0x7 -> "nbe"+ 0x8 -> "s"+ 0x9 -> "ns"+ 0xa -> "p"+ 0xb -> "np"+ 0xc -> "l"+ 0xd -> "nl"+ 0xe -> "le"+ 0xf -> "nle"++-------------------------------------------------------------- asm code++data Code where+ Ret, Nop, PushF, PopF, Cmc, Clc, Stc, Cli, Sti, Cld, Std :: Code++ Inc, Dec, Not, Neg :: IsSize s => Operand s RW -> Code+ Add, Or, Adc, Sbb, And, Sub, Xor, Cmp, Test, Mov :: IsSize s => Operand s RW -> Operand s r -> Code+ Rol, Ror, Rcl, Rcr, Shl, Shr, Sar :: IsSize s => Operand s RW -> Operand S8 r -> Code++ Xchg :: IsSize s => Operand s RW -> Operand s RW -> Code+ Lea :: (IsSize s, IsSize s') => Operand s RW -> Operand s' RW -> Code++ Pop :: Operand S64 RW -> Code+ Push :: Operand S64 r -> Code++ Call :: Operand S64 RW -> Code+ Jmpq :: Operand S64 RW -> Code++ J :: Maybe Size -> Condition -> Code+ Jmp :: Code++ Label :: Code+ Scope :: Code -> Code+ Up :: Code -> Code++ Data :: Bytes -> Code+ Align :: Size -> Code++ EmptyCode :: Code+ AppendCode :: Code -> Code -> Code++instance Monoid Code where+ mempty = EmptyCode+ mappend = AppendCode++-------------++showCode = \case+ EmptyCode -> return ()+ AppendCode a b -> showCode a >> showCode b++ Scope c -> get >>= \i -> put (i+1) >> local (i:) (showCode c)++ Up c -> local tail $ showCode c++ J s cc -> getLabel 0 >>= \l -> showOp ("j" ++ show cc) $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ l+ Jmp -> getLabel 0 >>= \l -> showOp "jmp" l+ Label -> getLabel 0 >>= codeLine++ x -> showCodeFrag x++getLabel i = ($ i) <$> getLabels++getLabels = f <$> ask+ where+ f xs i = case drop i xs of+ [] -> ".l?"+ (i: _) -> ".l" ++ show i++codeLine x = tell [x]++showCodeFrag = \case+ Add op1 op2 -> showOp2 "add" op1 op2+ Or op1 op2 -> showOp2 "or" op1 op2+ Adc op1 op2 -> showOp2 "adc" op1 op2+ Sbb op1 op2 -> showOp2 "sbb" op1 op2+ And op1 op2 -> showOp2 "and" op1 op2+ Sub op1 op2 -> showOp2 "sub" op1 op2+ Xor op1 op2 -> showOp2 "xor" op1 op2+ Cmp op1 op2 -> showOp2 "cmp" op1 op2+ Test op1 op2 -> showOp2 "test" op1 op2+ Rol op1 op2 -> showOp2 "rol" op1 op2+ Ror op1 op2 -> showOp2 "rol" op1 op2+ Rcl op1 op2 -> showOp2 "rol" op1 op2+ Rcr op1 op2 -> showOp2 "rol" op1 op2+ Shl op1 op2 -> showOp2 "rol" op1 op2+ Shr op1 op2 -> showOp2 "rol" op1 op2+ Sar op1 op2 -> showOp2 "rol" op1 op2+ Mov op1 op2 -> showOp2 "mov" op1 op2+ Lea op1 op2 -> showOp2 "lea" op1 op2+ Xchg op1 op2 -> showOp2 "xchg" op1 op2+ Inc op -> showOp1 "inc" op+ Dec op -> showOp1 "dec" op+ Not op -> showOp1 "not" op+ Neg op -> showOp1 "neg" op+ Pop op -> showOp1 "pop" op+ Push op -> showOp1 "push" op+ Call op -> showOp1 "call" op+ Jmpq op -> showOp1 "jmp" op+ Ret -> showOp0 "ret"+ Nop -> showOp0 "nop"+ PushF -> showOp0 "pushf"+ PopF -> showOp0 "popf"+ Cmc -> showOp0 "cmc"+ Clc -> showOp0 "clc"+ Stc -> showOp0 "stc"+ Cli -> showOp0 "cli"+ Sti -> showOp0 "sti"+ Cld -> showOp0 "cld"+ Std -> showOp0 "std"++ Align s -> codeLine $ ".align " ++ show s+ Data (Bytes x) -> showOp "db" $ intercalate ", " (showByte <$> x) ++ " ; " ++ show (toEnum . fromIntegral <$> x :: String)++showOp0 s = codeLine s+showOp s a = showOp0 $ s ++ " " ++ a+showOp1 s a = getLabels >>= \f -> showOp s $ showOperand f a+showOp2 s a b = getLabels >>= \f -> showOp s $ showOperand f a ++ ", " ++ showOperand f b+
CodeGen/X86/CodeGen.hs view
@@ -1,392 +1,432 @@-{-# language LambdaCase #-} -{-# language BangPatterns #-} -{-# language ViewPatterns #-} -{-# language PatternGuards #-} -{-# language PatternSynonyms #-} -{-# language NoMonomorphismRestriction #-} -{-# language ScopedTypeVariables #-} -{-# language RankNTypes #-} -{-# language TypeFamilies #-} -{-# language GADTs #-} -{-# language DataKinds #-} -{-# language KindSignatures #-} -{-# language PolyKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GeneralizedNewtypeDeriving #-} -module CodeGen.X86.CodeGen where - -import Numeric -import Data.Maybe -import Data.Monoid -import qualified Data.Vector as V -import Data.Bits -import Data.Int -import Data.Word -import Control.Arrow -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State -import Debug.Trace - -import CodeGen.X86.Asm - -------------------------------------------------------- utils - -takes [] _ = [] -takes (i: is) xs = take i xs: takes is (drop i xs) - -iff b a = if b then a else mempty - -indicator :: Integral a => Bool -> a -indicator False = 0x0 -indicator True = 0x1 - -pattern FJust a = First (Just a) -pattern FNothing = First Nothing - -pattern Integral xs <- (toIntegralSized -> Just xs) - -------------------------------------------------------- register packed with its size - -data SReg where - SReg :: IsSize s => Reg s -> SReg - -phisicalReg :: SReg -> Reg S64 -phisicalReg (SReg (HighReg x)) = NormalReg x -phisicalReg (SReg (NormalReg x)) = NormalReg x - -isHigh (SReg HighReg{}) = True -isHigh _ = False - -regs :: forall s k . IsSize s => Operand s k -> [SReg] -regs = \case - MemOp (Addr r _ i) -> foldMap (pure . SReg) r ++ foldMap (pure . SReg . snd) i - RegOp r -> [SReg r] - _ -> mempty - -isRex (SReg x@(NormalReg r)) = r .&. 0x8 /= 0 || size x == S8 && r `shiftR` 2 == 1 -isRex _ = False - -noHighRex r = not $ any isHigh r && any isRex r - -------------------------------------------------------- immediate value size conversion - -convertImm :: Bool{-sign extend-} -> Size -> Operand s k -> First ((Bool, Size), Bytes) -convertImm a b c = (,) (a, b) <$> g a b c - where - g :: Bool -> Size -> Operand s k -> First Bytes - g False S64 (ImmOp w) = toBytes <$> (f w :: First Word64) - g False S32 (ImmOp w) = toBytes <$> (f w :: First Word32) - g False S16 (ImmOp w) = toBytes <$> (f w :: First Word16) - g False S8 (ImmOp w) = toBytes <$> (f w :: First Word8) - g True S64 (ImmOp w) = toBytes <$> (f w :: First Int64) - g True S32 (ImmOp w) = toBytes <$> (f w :: First Int32) - g True S16 (ImmOp w) = toBytes <$> (f w :: First Int16) - g True S8 (ImmOp w) = toBytes <$> (f w :: First Int8) - g _ _ _ = FNothing - - f = First . toIntegralSized - - -mkImmS = convertImm True -mkImm = convertImm False - -mkImmNo64 s = mkImmS (no64 s) - -no64 S64 = S32 -no64 s = s - -------------------------------------------------------- code builder - -newtype CodeBuilder = CodeBuilder {buildCode :: CodeBuilderState -> (CodeBuilderRes, CodeBuilderState)} - -type CodeBuilderRes = [Either Int (Int, Word8)] - -type CodeBuilderState = (Int, [Either [(Size, Int, Int)] Int]) - -instance Monoid CodeBuilder where - mempty = CodeBuilder $ (,) mempty - f `mappend` g = CodeBuilder $ \(buildCode f -> (a, buildCode g -> (b, st))) -> (a ++ b, st) - -codeByte :: Word8 -> CodeBuilder -codeByte c = CodeBuilder $ \(n, labs) -> ([Right (n, c)], (n + 1, labs)) - -mkRef :: Size -> Int -> Int -> CodeBuilder -mkRef s sc bs = CodeBuilder f - where - f (n, labs) | bs >= length labs = trace "warning: missing scope" (mempty, (n + sizeLen s, labs)) - f (n, labs) = case labs !! bs of - Right i -> (Right <$> zip [n..] z, (n + sizeLen s, labs)) - where - vx = i - n - sc - z = getBytes $ case s of - S8 -> toBytes (fromIntegral vx :: Int8) - S32 -> toBytes (fromIntegral vx :: Int32) - Left cs -> (mempty, (n + sizeLen s, labs')) - where - labs' = take bs labs ++ Left ((s, n, - n - sc): cs): drop (bs + 1) labs - -------------------------------------------------------- code to code builder - -instance Show Code where - show c = unlines $ zipWith3 showLine is (takes (zipWith (-) (tail is ++ [s]) is) bs) ss - where - ss = snd . runWriter . flip evalStateT 0 . flip runReaderT [] . showCode $ c - (x, s) = second fst $ buildCode (mkCodeBuilder c) (0, replicate 10{-TODO-} $ Left []) - bs = V.toList $ V.replicate s 0 V.// [p | Right p <- x] - is = [i | Left i <- x] - - showLine addr [] s = s - showLine addr bs s = [showNibble i addr | i <- [5,4..0]] ++ " " ++ pad (2 * maxbytes) (concatMap showByte bs) ++ " " ++ s - - pad i xs = xs ++ replicate (i - length xs) ' ' - - maxbytes = 12 - -codeBytes c = Bytes $ V.toList $ V.replicate s 0 V.// [p | Right p <- x] - where - (x, s) = buildTheCode c - -buildTheCode x = second fst $ buildCode (mkCodeBuilder x) (0, []) - -mkCodeBuilder :: Code -> CodeBuilder -mkCodeBuilder = \case - EmptyCode -> mempty - AppendCode a b -> mkCodeBuilder a <> mkCodeBuilder b - - Up a -> CodeBuilder $ \(n, x: xs) -> second (second (x:)) $ buildCode (mkCodeBuilder a) (n, xs) - - Scope x -> CodeBuilder begin <> mkCodeBuilder x <> CodeBuilder end - where - begin (n, labs) = (mempty, (n, Left []: labs)) - end (n, Right _: labs) = (mempty, (n, labs)) - end (n, _: labs) = trace "warning: missing label" (mempty, (n, labs)) - - x -> CodeBuilder $ \st@(addr, _) -> first (Left addr:) $ buildCode (mkCodeBuilder' x) st - -mkCodeBuilder' :: Code -> CodeBuilder -mkCodeBuilder' = \case - Add a b -> op2 0x0 a b - Or a b -> op2 0x1 a b - Adc a b -> op2 0x2 a b - Sbb a b -> op2 0x3 a b - And a b -> op2 0x4 a b - Sub a b -> op2 0x5 a b - Xor a b -> op2 0x6 a b - Cmp a b -> op2 0x7 a b - - Rol a b -> shiftOp 0x0 a b - Ror a b -> shiftOp 0x1 a b - Rcl a b -> shiftOp 0x2 a b - Rcr a b -> shiftOp 0x3 a b - Shl a b -> shiftOp 0x4 a b -- sal - Shr a b -> shiftOp 0x5 a b - Sar a b -> shiftOp 0x7 a b - - Xchg x@RegA r -> xchg_a r - Xchg r x@RegA -> xchg_a r - Xchg dest src -> op2' 0x43 dest' src - where - (dest', src') = if isMemOp src then (src, dest) else (dest, src) - - Test dest (mkImmNo64 (size dest) -> FJust (_, im)) -> case dest of - RegA -> regprefix'' dest 0x54 mempty im - _ -> regprefix'' dest 0x7b (reg8 0x0 dest) im - Test dest (noImm "" -> src) -> op2' 0x42 dest' src' - where - (dest', src') = if isMemOp src then (src, dest) else (dest, src) - - Mov dest@(RegOp r) ((if size dest == S64 then mkImm S32 <> mkImmS S32 <> mkImmS S64 else mkImmS (size dest)) -> FJust ((se, si), im)) - | (se, si, size dest) /= (True, S32, S64) -> regprefix si dest (oneReg (0x16 .|. indicator (size dest /= S8)) r) im - | otherwise -> regprefix'' dest 0x63 (reg8 0x0 dest) im - Mov dest@(size -> s) (mkImmNo64 s -> FJust (_, im)) -> regprefix'' dest 0x63 (reg8 0x0 dest) im - Mov dest src -> op2' 0x44 dest $ noImm (show (dest, src)) src - - Lea dest@(RegOp r) src | size dest /= S8 -> regprefix2 (resizeOperand' dest src) dest 0x46 $ reg8 (reg8_ r) src - where - resizeOperand' :: IsSize s1 => Operand s1 x -> Operand s2 RW -> Operand s1 RW - resizeOperand' _ = resizeOperand - - Not a -> op1 0x7b 0x2 a - Neg a -> op1 0x7b 0x3 a - Inc a -> op1 0x7f 0x0 a - Dec a -> op1 0x7f 0x1 a - Call a -> op1' 0xff 0x2 a - - Pop dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty - Pop dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty - - Push (mkImmS S8 -> FJust (_, im)) -> codeByte 0x6a <> bytesToCode im - Push (mkImmS S32 -> FJust (_, im)) -> codeByte 0x68 <> bytesToCode im - Push dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty - Push dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty - - Ret -> codeByte 0xc3 - Nop -> codeByte 0x90 - PushF -> codeByte 0x9c - PopF -> codeByte 0x9d - Cmc -> codeByte 0xf5 - Clc -> codeByte 0xf8 - Stc -> codeByte 0xf9 - Cli -> codeByte 0xfa - Sti -> codeByte 0xfb - Cld -> codeByte 0xfc - Std -> codeByte 0xfd - - J (Condition c) -> codeByte (0x70 .|. c) <> mkRef S8 1 0 - - -- short jump - Jmp -> codeByte 0xeb <> mkRef S8 1 0 - - Label -> CodeBuilder lab - where - lab :: CodeBuilderState -> (CodeBuilderRes, CodeBuilderState) - lab (n, labs) = (Right <$> concatMap g corr, (n, labs')) - where - (corr, labs') = replL (Right n) labs - - g (size, p, v) = zip [p..] $ getBytes $ case (size, v + n) of - (S8, Integral v) -> toBytes (v :: Int8) - (S32, Integral v) -> toBytes (v :: Int32) - - replL x (Left z: zs) = (z, x: zs) - replL x (z: zs) = second (z:) $ replL x zs - - Data cs -> CodeBuilder $ \(n, labs) -> (Right <$> zip [n..] (getBytes cs), (n + bytesCount cs, labs)) - Align s -> CodeBuilder $ \(n, labs) -> let - n' = fromIntegral $ (fromIntegral n - 1 :: Int64) .|. f s + 1 - in (Right <$> zip [n..] (replicate (n' - n) 0x90), (n', labs)) - where - f :: Size -> Int64 - f s = sizeLen s - 1 - where - xchg_a :: IsSize s => Operand s a -> CodeBuilder - xchg_a dest@(RegOp r) | size dest /= S8 = regprefix (size dest) dest (oneReg 0x12 r) mempty - xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty - - bytesToCode :: Bytes -> CodeBuilder - bytesToCode = mkCodeBuilder' . Data - - toCode :: HasBytes a => a -> CodeBuilder - toCode = bytesToCode . toBytes - - sizePrefix_ :: [SReg] -> Size -> Operand s a -> Word8 -> CodeBuilder -> Bytes -> CodeBuilder - sizePrefix_ rs s r x c im - | noHighRex rs = pre <> c <> displacement r <> bytesToCode im - | otherwise = error "cannot use high register in rex instruction" - where - pre = case s of - S8 -> mem32pre r <> iff (any isRex rs || x /= 0) (prefix40_ x) - S16 -> codeByte 0x66 <> mem32pre r <> prefix40 x - S32 -> mem32pre r <> prefix40 x - S64 -> mem32pre r <> prefix40 (0x8 .|. x) - - mem32pre :: Operand s k -> CodeBuilder - mem32pre (MemOp r@Addr{}) | size r == S32 = codeByte 0x67 - mem32pre _ = mempty - - prefix40 x = iff (x /= 0) $ prefix40_ x - prefix40_ x = codeByte $ 0x40 .|. x - - displacement :: Operand s a -> CodeBuilder - displacement RegOp{} = mempty - displacement (IPMemOp (Immediate d)) = toCode d - displacement (IPMemOp (LabelRelAddr d)) = mkRef S32 (4 + fromIntegral (bytesCount im)) d - displacement (MemOp (Addr b d i)) = mkSIB b i <> dispVal b d - where - mkSIB _ (IndexReg s (NormalReg 0x4)) = error "sp cannot be used as index" - mkSIB _ (IndexReg s i) = f s $ reg8_ i - mkSIB Nothing _ = f s1 0x4 - mkSIB (Just (reg8_ -> 0x4)) _ = f s1 0x4 - mkSIB _ _ = mempty - - f (Scale s) i = codeByte $ s `shiftL` 6 .|. i `shiftL` 3 .|. maybe 0x5 reg8_ b - - dispVal Just{} (Disp (Integral (d :: Int8))) = toCode d - dispVal _ (Disp d) = toCode d - dispVal Nothing _ = toCode (0 :: Int32) -- [rbp] --> [rbp + 0] - dispVal (Just (reg8_ -> 0x5)) _ = codeByte 0 -- [rbp] --> [rbp + 0] - dispVal _ _ = mempty - - reg8_ :: Reg t -> Word8 - reg8_ (NormalReg r) = r .&. 0x7 - reg8_ (HighReg r) = r .|. 0x4 - - regprefix :: IsSize s => Size -> Operand s a -> CodeBuilder -> Bytes -> CodeBuilder - regprefix s r c im = sizePrefix_ (regs r) s r (extbits r) c im - - regprefix2 :: (IsSize s1, IsSize s) => Operand s1 a1 -> Operand s a -> Word8 -> CodeBuilder -> CodeBuilder - regprefix2 r r' p c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) (extension r p <> c) mempty - - regprefix'' :: IsSize s => Operand s a -> Word8 -> CodeBuilder -> Bytes -> CodeBuilder - regprefix'' r p c = regprefix (size r) r $ extension r p <> c - - extension :: HasSize a => a -> Word8 -> CodeBuilder - extension x p = codeByte $ p `shiftL` 1 .|. indicator (size x /= S8) - - extbits :: Operand s a -> Word8 - extbits = \case - MemOp (Addr b _ i) -> maybe 0 indexReg b .|. maybe 0 ((`shiftL` 1) . indexReg . snd) i - RegOp r -> indexReg r - IPMemOp{} -> 0 - where - indexReg (NormalReg r) = r `shiftR` 3 .&. 1 - indexReg _ = 0 - - reg8 :: Word8 -> Operand s a -> CodeBuilder - reg8 w x = codeByte $ operMode x `shiftL` 6 .|. w `shiftL` 3 .|. rc x - where - operMode :: Operand s a -> Word8 - operMode (MemOp (Addr (Just (reg8_ -> 0x5)) NoDisp _)) = 0x1 -- [rbp] --> [rbp + 0] - operMode (MemOp (Addr Nothing _ _)) = 0x0 - operMode (MemOp (Addr _ NoDisp _)) = 0x0 - operMode (MemOp (Addr _ (Disp (Integral (_ :: Int8))) _)) = 0x1 - operMode (MemOp (Addr _ Disp{} _)) = 0x2 - operMode IPMemOp{} = 0x0 - operMode RegOp{} = 0x3 - - rc :: Operand s a -> Word8 - rc (MemOp (Addr (Just r) _ NoIndex)) = reg8_ r - rc MemOp{} = 0x04 -- SIB byte - rc IPMemOp{} = 0x05 - rc (RegOp r) = reg8_ r - - op2 :: IsSize s => Word8 -> Operand s RW -> Operand s k -> CodeBuilder - op2 op dest@RegA src@(mkImmNo64 (size dest) -> FJust (_, im)) | size dest == S8 || isNothing (getFirst $ mkImmS S8 src) - = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im - op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im)) - = regprefix'' dest (0x40 .|. indicator (size dest /= S8 && k == S8)) (reg8 op dest) im - op2 op dest src = op2' (op `shiftL` 2) dest $ noImm "1" src - - noImm :: String -> Operand s k -> Operand s RW - noImm _ (RegOp r) = RegOp r - noImm _ (MemOp a) = MemOp a - noImm _ (IPMemOp a) = IPMemOp a - noImm er _ = error $ "immediate value of this size is not supported: " ++ er - - op2' :: IsSize s => Word8 -> Operand s RW -> Operand s RW -> CodeBuilder - op2' op dest src@RegOp{} = op2g op dest src - op2' op dest@RegOp{} src = op2g (op .|. 0x1) src dest - - op2g :: (IsSize t, IsSize s) => Word8 -> Operand s a1 -> Operand t a -> CodeBuilder - op2g op dest src@(RegOp r) = regprefix2 dest src op $ reg8 (reg8_ r) dest - - op1_ :: IsSize s => Word8 -> Word8 -> Operand s a -> Bytes -> CodeBuilder - op1_ r1 r2 dest im = regprefix'' dest r1 (reg8 r2 dest) im - - op1 :: IsSize s => Word8 -> Word8 -> Operand s a -> CodeBuilder - op1 a b c = op1_ a b c mempty - - op1' :: Word8 -> Word8 -> Operand S64 RW -> CodeBuilder - op1' r1 r2 dest = regprefix S32 dest (codeByte r1 <> reg8 r2 dest) mempty - - shiftOp :: IsSize s => Word8 -> Operand s RW -> Operand S8 k -> CodeBuilder - shiftOp c dest (ImmOp 1) = op1 0x68 c dest - shiftOp c dest (mkImm S8 -> FJust (_, i)) = op1_ 0x60 c dest i - shiftOp c dest RegCl = op1 0x69 c dest - shiftOp _ _ _ = error "invalid shift operands" - - oneReg :: Word8 -> Reg t -> CodeBuilder - oneReg x r = codeByte $ x `shiftL` 3 .|. reg8_ r - +{-# language LambdaCase #-}+{-# language BangPatterns #-}+{-# language ViewPatterns #-}+{-# language PatternGuards #-}+{-# language PatternSynonyms #-}+{-# language NoMonomorphismRestriction #-}+{-# language ScopedTypeVariables #-}+{-# language RankNTypes #-}+{-# language TypeFamilies #-}+{-# language GADTs #-}+{-# language DataKinds #-}+{-# language KindSignatures #-}+{-# language PolyKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GeneralizedNewtypeDeriving #-}+module CodeGen.X86.CodeGen where++import Numeric+import Data.Maybe+import Data.Monoid+import qualified Data.Vector as V+import Data.Bits+import Data.Int+import Data.Word+import Control.Arrow+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Debug.Trace++import CodeGen.X86.Asm++------------------------------------------------------- utils++takes [] _ = []+takes (i: is) xs = take i xs: takes is (drop i xs)++iff b a = if b then a else mempty++indicator :: Integral a => Bool -> a+indicator False = 0x0+indicator True = 0x1++pattern FJust a = First (Just a)+pattern FNothing = First Nothing++pattern Integral xs <- (toIntegralSized -> Just xs)++integralToBytes :: (Bits a, Integral a) => Bool{-signed-} -> Size -> a -> Maybe Bytes+integralToBytes False S64 w = toBytes <$> (toIntegralSized w :: Maybe Word64)+integralToBytes False S32 w = toBytes <$> (toIntegralSized w :: Maybe Word32)+integralToBytes False S16 w = toBytes <$> (toIntegralSized w :: Maybe Word16)+integralToBytes False S8 w = toBytes <$> (toIntegralSized w :: Maybe Word8)+integralToBytes True S64 w = toBytes <$> (toIntegralSized w :: Maybe Int64)+integralToBytes True S32 w = toBytes <$> (toIntegralSized w :: Maybe Int32)+integralToBytes True S16 w = toBytes <$> (toIntegralSized w :: Maybe Int16)+integralToBytes True S8 w = toBytes <$> (toIntegralSized w :: Maybe Int8)++------------------------------------------------------- register packed with its size++data SReg where+ SReg :: IsSize s => Reg s -> SReg++phisicalReg :: SReg -> Reg S64+phisicalReg (SReg (HighReg x)) = NormalReg x+phisicalReg (SReg (NormalReg x)) = NormalReg x++isHigh (SReg HighReg{}) = True+isHigh _ = False++regs :: forall s k . IsSize s => Operand s k -> [SReg]+regs = \case+ MemOp (Addr r _ i) -> foldMap (pure . SReg) r ++ foldMap (pure . SReg . snd) i+ RegOp r -> [SReg r]+ _ -> mempty++isRex (SReg x@(NormalReg r)) = r .&. 0x8 /= 0 || size x == S8 && r `shiftR` 2 == 1+isRex _ = False++noHighRex r = not $ any isHigh r && any isRex r++no64 S64 = S32+no64 s = s++------------------------------------------------------- code builder++data CodeBuilder+ = CodeBuilder (CodeBuilderState -> (CodeBuilderRes, CodeBuilderState))+ | ExactCodeBuilder Int (CodeBuilderState -> (CodeBuilderRes, LabelState)) -- ^ CodeBuilder with known length++codeBuilderLength (ExactCodeBuilder len _) = len++buildCode :: CodeBuilder -> CodeBuilderState -> (CodeBuilderRes, CodeBuilderState)+buildCode (CodeBuilder f) st = f st+buildCode (ExactCodeBuilder len f) (n, st) = second ((,) (n + len)) $ f (n, st)++mapLabelState g (CodeBuilder f) = CodeBuilder $ \(n, g -> (fx, xs)) -> second (second fx) $ f (n, xs)+mapLabelState g (ExactCodeBuilder len f) = ExactCodeBuilder len $ \(n, g -> (fx, xs)) -> second fx $ f (n, xs)++censorCodeBuilder g (CodeBuilder f) = CodeBuilder $ \st -> first (g st) $ f st+censorCodeBuilder g (ExactCodeBuilder len f) = ExactCodeBuilder len $ \st -> first (g st) $ f st++type CodeBuilderRes = [Either Int (Int, Word8)]++type CodeBuilderState = (Int, LabelState)++type LabelState = [Either [(Size, Int, Int)] Int]++instance Monoid CodeBuilder where+ mempty = ExactCodeBuilder 0 $ \(_, st) -> (mempty, st)+ ExactCodeBuilder len f `mappend` ExactCodeBuilder len' g = ExactCodeBuilder (len + len') $ \st -> let+ (a, st') = f st+ (b, st'') = g (len + fst st, st')+ in (a ++ b, st'')+ f `mappend` g = CodeBuilder $ \(buildCode f -> (a, buildCode g -> (b, st))) -> (a ++ b, st)++codeByte :: Word8 -> CodeBuilder+codeByte c = ExactCodeBuilder 1 $ \(n, labs) -> ([Right (n, c)], labs)++mkRef :: Size -> Int -> Int -> CodeBuilder+mkRef s@(sizeLen -> sn) offset bs = ExactCodeBuilder sn f+ where+ f (n, labs) | bs >= length labs = error "missing scope"+ f (n, labs) = case labs !! bs of+ Right i -> (Right <$> zip [n..] z, labs)+ where+ vx = i - n - offset+ z = getBytes $ case s of+ S8 -> case vx of+ Integral j -> toBytes (j :: Int8)+ _ -> error $ show vx ++ " does not fit into an Int8"+ S32 -> case vx of+ Integral j -> toBytes (j :: Int32)+ _ -> error $ show vx ++ " does not fit into an Int32"+ Left cs -> (mempty, labs')+ where+ labs' = take bs labs ++ Left ((s, n, - n - offset): cs): drop (bs + 1) labs++mkAutoRef :: [(Size, Bytes)] -> Int -> Int -> CodeBuilder+mkAutoRef ss offset bs = CodeBuilder f+ where+ f (n, labs) | bs >= length labs = error "missing scope"+ f (n, labs) = case labs !! bs of+ Left cs -> error "auto length computation for forward references is not supported"+ Right i -> (Right <$> zip [n..] z, (n + length z, labs))+ where+ vx = i - n - offset+ z = g ss++ g [] = error $ show vx ++ " does not fit into auto size"+ g ((s, c): ss) = case (s, vx - bytesCount c - sizeLen s) of+ (S8, Integral j) -> getBytes $ c <> toBytes (j :: Int8)+ (S32, Integral j) -> getBytes $ c <> toBytes (j :: Int32)+ _ -> g ss++------------------------------------------------------- code to code builder++instance Show Code where+ show c = unlines $ zipWith3 showLine is (takes (zipWith (-) (tail is ++ [s]) is) bs) ss+ where+ ss = snd . runWriter . flip evalStateT 0 . flip runReaderT [] . showCode $ c+ (x, s) = second fst $ buildCode (mkCodeBuilder c) (0, replicate 10{-TODO-} $ Left [])+ bs = V.toList $ V.replicate s 0 V.// [p | Right p <- x]+ is = [i | Left i <- x]++ showLine addr [] s = s+ showLine addr bs s = [showNibble i addr | i <- [5,4..0]] ++ " " ++ pad (2 * maxbytes) (concatMap showByte bs) ++ " " ++ s++ pad i xs = xs ++ replicate (i - length xs) ' '++ maxbytes = 12++codeBytes c = Bytes $ V.toList $ V.replicate s 0 V.// [p | Right p <- x]+ where+ (x, s) = buildTheCode c++buildTheCode x = second fst $ buildCode (mkCodeBuilder x) (0, [])++bytesToCodeBuilder :: Bytes -> CodeBuilder+bytesToCodeBuilder x = ExactCodeBuilder (bytesCount x) $ \(n, labs) -> (Right <$> zip [n..] (getBytes x), labs)++mkCodeBuilder :: Code -> CodeBuilder+mkCodeBuilder = \case+ EmptyCode -> mempty+ AppendCode a b -> mkCodeBuilder a <> mkCodeBuilder b++ Up a -> mapLabelState (\(x: xs) -> ((x:), xs)) $ mkCodeBuilder a++ Scope x -> ExactCodeBuilder 0 begin <> mkCodeBuilder x <> ExactCodeBuilder 0 end+ where+ begin (n, labs) = (mempty, Left []: labs)+ end (n, Right _: labs) = (mempty, labs)+ end (n, _: labs) = trace "warning: missing label" (mempty, labs)++ x -> censorCodeBuilder (\(addr, _) -> (Left addr:)) $ mkCodeBuilder' x++mkCodeBuilder' :: Code -> CodeBuilder+mkCodeBuilder' = \case+ Add a b -> op2 0x0 a b+ Or a b -> op2 0x1 a b+ Adc a b -> op2 0x2 a b+ Sbb a b -> op2 0x3 a b+ And a b -> op2 0x4 a b+ Sub a b -> op2 0x5 a b+ Xor a b -> op2 0x6 a b+ Cmp a b -> op2 0x7 a b++ Rol a b -> shiftOp 0x0 a b+ Ror a b -> shiftOp 0x1 a b+ Rcl a b -> shiftOp 0x2 a b+ Rcr a b -> shiftOp 0x3 a b+ Shl a b -> shiftOp 0x4 a b -- sal+ Shr a b -> shiftOp 0x5 a b+ Sar a b -> shiftOp 0x7 a b++ Xchg x@RegA r -> xchg_a r+ Xchg r x@RegA -> xchg_a r+ Xchg dest src -> op2' 0x43 dest' src+ where+ (dest', src') = if isMemOp src then (src, dest) else (dest, src)++ Test dest (mkImmNo64 (size dest) -> FJust (_, im)) -> case dest of+ RegA -> regprefix'' dest 0x54 mempty im+ _ -> regprefix'' dest 0x7b (reg8 0x0 dest) im+ Test dest (noImm "" -> src) -> op2' 0x42 dest' src'+ where+ (dest', src') = if isMemOp src then (src, dest) else (dest, src)++ Mov dest@(RegOp r) ((if size dest == S64 then mkImm S32 <> mkImmS S32 <> mkImmS S64 else mkImmS (size dest)) -> FJust ((se, si), im))+ | (se, si, size dest) /= (True, S32, S64) -> regprefix si dest (oneReg (0x16 .|. indicator (size dest /= S8)) r) im+ | otherwise -> regprefix'' dest 0x63 (reg8 0x0 dest) im+ Mov dest@(size -> s) (mkImmNo64 s -> FJust (_, im)) -> regprefix'' dest 0x63 (reg8 0x0 dest) im+ Mov dest src -> op2' 0x44 dest $ noImm (show (dest, src)) src++ Lea dest@(RegOp r) src | size dest /= S8 -> regprefix2 (resizeOperand' dest src) dest 0x46 $ reg8 (reg8_ r) src+ where+ resizeOperand' :: IsSize s1 => Operand s1 x -> Operand s2 RW -> Operand s1 RW+ resizeOperand' _ = resizeOperand++ Not a -> op1 0x7b 0x2 a+ Neg a -> op1 0x7b 0x3 a+ Inc a -> op1 0x7f 0x0 a+ Dec a -> op1 0x7f 0x1 a+ Call a -> op1' 0xff 0x2 a+ Jmpq a -> op1' 0xff 0x4 a++ Pop dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty+ Pop dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty++ Push (mkImmS S8 -> FJust (_, im)) -> codeByte 0x6a <> im+ Push (mkImmS S32 -> FJust (_, im)) -> codeByte 0x68 <> im+ Push dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty+ Push dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty++ Ret -> codeByte 0xc3+ Nop -> codeByte 0x90+ PushF -> codeByte 0x9c+ PopF -> codeByte 0x9d+ Cmc -> codeByte 0xf5+ Clc -> codeByte 0xf8+ Stc -> codeByte 0xf9+ Cli -> codeByte 0xfa+ Sti -> codeByte 0xfb+ Cld -> codeByte 0xfc+ Std -> codeByte 0xfd++ J (Just S8) (Condition c) -> codeByte (0x70 .|. c) <> mkRef S8 1 0+ J (Just S32) (Condition c) -> codeByte 0x0f <> codeByte (0x80 .|. c) <> mkRef S32 4 0+ J Nothing (Condition c) -> mkAutoRef [(S8, Bytes [0x70 .|. c]), (S32, Bytes [0x0f, 0x80 .|. c])] 0 0++ -- short jump+ Jmp -> codeByte 0xeb <> mkRef S8 1 0++ Label -> ExactCodeBuilder 0 lab+ where+ lab :: CodeBuilderState -> (CodeBuilderRes, LabelState)+ lab (n, labs) = (Right <$> concatMap g corr, labs')+ where+ (corr, labs') = replL (Right n) labs++ g (size, p, v) = zip [p..] $ getBytes $ case (size, v + n) of+ (S8, Integral v) -> toBytes (v :: Int8)+ (S32, Integral v) -> toBytes (v :: Int32)++ replL x (Left z: zs) = (z, x: zs)+ replL x (z: zs) = second (z:) $ replL x zs++ Data x -> bytesToCodeBuilder x+ Align s -> CodeBuilder $ \(n, labs) -> let+ n' = fromIntegral $ (fromIntegral n - 1 :: Int64) .|. f s + 1+ in (Right <$> zip [n..] (replicate (n' - n) 0x90), (n', labs))+ where+ f :: Size -> Int64+ f s = sizeLen s - 1+ where+ convertImm :: Bool{-signed-} -> Size -> Operand s k -> First ((Bool, Size), CodeBuilder)+ convertImm a b (ImmOp (Immediate c)) = First $ (,) (a, b) . bytesToCodeBuilder <$> integralToBytes a b c+ convertImm True b (ImmOp (LabelRelValue s d)) | b == s = FJust $ (,) (True, b) $ mkRef s (sizeLen s) d+ convertImm _ _ _ = FNothing++ mkImmS, mkImm, mkImmNo64 :: Size -> Operand s k -> First ((Bool, Size), CodeBuilder)+ mkImmS = convertImm True+ mkImm = convertImm False+ mkImmNo64 s = mkImmS (no64 s)++ xchg_a :: IsSize s => Operand s a -> CodeBuilder+ xchg_a dest@(RegOp r) | size dest /= S8 = regprefix (size dest) dest (oneReg 0x12 r) mempty+ xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty++ toCode :: HasBytes a => a -> CodeBuilder+ toCode = bytesToCodeBuilder . toBytes++ sizePrefix_ :: [SReg] -> Size -> Operand s a -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder+ sizePrefix_ rs s r x c im+ | noHighRex rs = pre <> c <> displacement r <> im+ | otherwise = error "cannot use high register in rex instruction"+ where+ pre = case s of+ S8 -> mem32pre r <> iff (any isRex rs || x /= 0) (prefix40_ x)+ S16 -> codeByte 0x66 <> mem32pre r <> prefix40 x+ S32 -> mem32pre r <> prefix40 x+ S64 -> mem32pre r <> prefix40 (0x8 .|. x)++ mem32pre :: Operand s k -> CodeBuilder+ mem32pre (MemOp r@Addr{}) | size r == S32 = codeByte 0x67+ mem32pre _ = mempty++ prefix40 x = iff (x /= 0) $ prefix40_ x+ prefix40_ x = codeByte $ 0x40 .|. x++ displacement :: Operand s a -> CodeBuilder+ displacement RegOp{} = mempty+ displacement (IPMemOp (Immediate d)) = toCode d+ displacement (IPMemOp (LabelRelValue s@S32 d)) = mkRef s (sizeLen s + fromIntegral (codeBuilderLength im)) d+ displacement (MemOp (Addr b d i)) = mkSIB b i <> dispVal b d+ where+ mkSIB _ (IndexReg s (NormalReg 0x4)) = error "sp cannot be used as index"+ mkSIB _ (IndexReg s i) = f s $ reg8_ i+ mkSIB Nothing _ = f s1 0x4+ mkSIB (Just (reg8_ -> 0x4)) _ = f s1 0x4+ mkSIB _ _ = mempty++ f (Scale s) i = codeByte $ s `shiftL` 6 .|. i `shiftL` 3 .|. maybe 0x5 reg8_ b++ dispVal Just{} (Disp (Integral (d :: Int8))) = toCode d+ dispVal _ (Disp d) = toCode d+ dispVal Nothing _ = toCode (0 :: Int32) -- [rbp] --> [rbp + 0]+ dispVal (Just (reg8_ -> 0x5)) _ = codeByte 0 -- [rbp] --> [rbp + 0]+ dispVal _ _ = mempty++ reg8_ :: Reg t -> Word8+ reg8_ (NormalReg r) = r .&. 0x7+ reg8_ (HighReg r) = r .|. 0x4++ regprefix :: IsSize s => Size -> Operand s a -> CodeBuilder -> CodeBuilder -> CodeBuilder+ regprefix s r c im = sizePrefix_ (regs r) s r (extbits r) c im++ regprefix2 :: (IsSize s1, IsSize s) => Operand s1 a1 -> Operand s a -> Word8 -> CodeBuilder -> CodeBuilder+ regprefix2 r r' p c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) (extension r p <> c) mempty++ regprefix'' :: IsSize s => Operand s a -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder+ regprefix'' r p c = regprefix (size r) r $ extension r p <> c++ extension :: HasSize a => a -> Word8 -> CodeBuilder+ extension x p = codeByte $ p `shiftL` 1 .|. indicator (size x /= S8)++ extbits :: Operand s a -> Word8+ extbits = \case+ MemOp (Addr b _ i) -> maybe 0 indexReg b .|. maybe 0 ((`shiftL` 1) . indexReg . snd) i+ RegOp r -> indexReg r+ IPMemOp{} -> 0+ where+ indexReg (NormalReg r) = r `shiftR` 3 .&. 1+ indexReg _ = 0++ reg8 :: Word8 -> Operand s a -> CodeBuilder+ reg8 w x = codeByte $ operMode x `shiftL` 6 .|. w `shiftL` 3 .|. rc x+ where+ operMode :: Operand s a -> Word8+ operMode (MemOp (Addr (Just (reg8_ -> 0x5)) NoDisp _)) = 0x1 -- [rbp] --> [rbp + 0]+ operMode (MemOp (Addr Nothing _ _)) = 0x0+ operMode (MemOp (Addr _ NoDisp _)) = 0x0+ operMode (MemOp (Addr _ (Disp (Integral (_ :: Int8))) _)) = 0x1+ operMode (MemOp (Addr _ Disp{} _)) = 0x2+ operMode IPMemOp{} = 0x0+ operMode RegOp{} = 0x3++ rc :: Operand s a -> Word8+ rc (MemOp (Addr (Just r) _ NoIndex)) = reg8_ r+ rc MemOp{} = 0x04 -- SIB byte+ rc IPMemOp{} = 0x05+ rc (RegOp r) = reg8_ r++ op2 :: IsSize s => Word8 -> Operand s RW -> Operand s k -> CodeBuilder+ op2 op dest@RegA src@(mkImmNo64 (size dest) -> FJust (_, im)) | size dest == S8 || isNothing (getFirst $ mkImmS S8 src)+ = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im+ op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im))+ = regprefix'' dest (0x40 .|. indicator (size dest /= S8 && k == S8)) (reg8 op dest) im+ op2 op dest src = op2' (op `shiftL` 2) dest $ noImm "1" src++ noImm :: String -> Operand s k -> Operand s RW+ noImm _ (RegOp r) = RegOp r+ noImm _ (MemOp a) = MemOp a+ noImm _ (IPMemOp a) = IPMemOp a+ noImm er _ = error $ "immediate value of this size is not supported: " ++ er++ op2' :: IsSize s => Word8 -> Operand s RW -> Operand s RW -> CodeBuilder+ op2' op dest src@RegOp{} = op2g op dest src+ op2' op dest@RegOp{} src = op2g (op .|. 0x1) src dest++ op2g :: (IsSize t, IsSize s) => Word8 -> Operand s a1 -> Operand t a -> CodeBuilder+ op2g op dest src@(RegOp r) = regprefix2 dest src op $ reg8 (reg8_ r) dest++ op1_ :: IsSize s => Word8 -> Word8 -> Operand s a -> CodeBuilder -> CodeBuilder+ op1_ r1 r2 dest im = regprefix'' dest r1 (reg8 r2 dest) im++ op1 :: IsSize s => Word8 -> Word8 -> Operand s a -> CodeBuilder+ op1 a b c = op1_ a b c mempty++ op1' :: Word8 -> Word8 -> Operand S64 RW -> CodeBuilder+ op1' r1 r2 dest = regprefix S32 dest (codeByte r1 <> reg8 r2 dest) mempty++ shiftOp :: IsSize s => Word8 -> Operand s RW -> Operand S8 k -> CodeBuilder+ shiftOp c dest (ImmOp (Immediate 1)) = op1 0x68 c dest+ shiftOp c dest (mkImm S8 -> FJust (_, i)) = op1_ 0x60 c dest i+ shiftOp c dest RegCl = op1 0x69 c dest+ shiftOp _ _ _ = error "invalid shift operands"++ oneReg :: Word8 -> Reg t -> CodeBuilder+ oneReg x r = codeByte $ x `shiftL` 3 .|. reg8_ r+
CodeGen/X86/Examples.hs view
@@ -1,5 +1,3 @@-{-# language CPP #-} -{-# language BangPatterns #-} module CodeGen.X86.Examples where import Foreign @@ -51,7 +49,7 @@ fib :: Word64 -> Word64 fib n = go n 0 1 where - go 0 !a !b = a + go 0 a b = b `seq` a go n a b = go (n-1) b (a+b) callHsFun :: Word64 -> Word64
CodeGen/X86/Tests.hs view
@@ -132,7 +132,7 @@ instance IsSize s => Arbitrary (Operand s R) where arbitrary = oneof - [ ImmOp <$> oneof (arbVal <$> [S8, S16, S32, S64]) + [ imm <$> oneof (arbVal <$> [S8, S16, S32, S64]) , genRegs , genMems , genIPBase @@ -190,7 +190,7 @@ ] where arb = oneof - [ ImmOp . fromIntegral <$> (arbitrary :: Gen Word8) + [ imm . fromIntegral <$> (arbitrary :: Gen Word8) , return cl ] @@ -199,7 +199,7 @@ noteqreg a b = x == nub x where x = map phisicalReg $ regs a ++ regs b - okk (size -> s) i@ImmOp{} = isJust (getFirst $ mkImmS (no64 s) i) + okk (size -> s) (ImmOp (Immediate i)) = isJust (integralToBytes True (no64 s) i) okk _ _ = True -- TODO: remove @@ -207,7 +207,7 @@ ok' a b | isMemOp a && isMemOp b = False ok' a b = noteqreg a b - oki x@RegOp{} i@ImmOp{} = isJust (getFirst $ mkImmS (size x) i) + oki x@RegOp{} (ImmOp (Immediate i)) = isJust (integralToBytes True (size x) i) oki a b = okk a b --------------------------------------------------- @@ -350,11 +350,11 @@ where mkVal :: IsSize s => Operand S64 RW -> Operand s k -> Gen (Int64, Code -> Code) - mkVal _ o@(ImmOp w) = return (w, id) + mkVal _ o@(ImmOp (Immediate w)) = return (w, id) mkVal _ o@(RegOp x) = do v <- arbVal $ size o - return (v, (Mov (RegOp x) (ImmOp v) <>)) - mkVal helper x@(IPMemOp (LabelRelAddr _)) = do + return (v, (Mov (RegOp x) (imm v) <>)) + mkVal helper x@(IPMemOp LabelRelValue{}) = do v <- arbVal $ size x return (v, \c -> Scope $ Up Jmp {- <> align (size x) -} <:> Data (toBytes v) <.> c) mkVal helper o@(MemOp (Addr (Just x) d i)) = do @@ -363,7 +363,7 @@ NoIndex -> return (0, mempty) IndexReg sc i -> do x <- arbVal $ size i - return (scaleFactor sc * x, Mov (RegOp i) (ImmOp x)) + return (scaleFactor sc * x, Mov (RegOp i) (imm x)) let d' = (vi :: Int64) + case d of NoDisp -> 0
CodeGen/X86/Utils.hs view
@@ -25,13 +25,30 @@ infixr 5 <:>, <.> -j c x = J c <> Up x <:> mempty +-- | short conditional forward jump (no auto size available for forward jumps) +j = j8 -x `j_back` c = mempty <:> Up x <> J c +-- | short conditional forward jump +j8 c x = J (Just S8) c <> Up x <:> mempty -if_ c a b = (J c <> Up (Up a <> Jmp) <:> mempty) <> Up b <:> mempty +-- | near conditional forward jump +j32 c x = J (Just S32) c <> Up x <:> mempty -leaData r d = (Lea r (ipBase :: Operand S8 RW) <> Up Jmp <:> mempty) <> Data (toBytes d) <:> mempty +-- | auto size conditional backward jump +x `j_back` c = mempty <:> Up x <> J Nothing c + +-- | short conditional backward jump +x `j_back8` c = mempty <:> Up x <> J (Just S8) c + +-- | near conditional backward jump +x `j_back32` c = mempty <:> Up x <> J (Just S32) c + +if_ c a b = (J (Just S8) c <> Up (Up a <> Jmp) <:> mempty) <> Up b <:> mempty + +lea8 :: IsSize s => Operand s RW -> Operand S8 RW -> Code +lea8 = Lea + +leaData r d = (lea8 r ipBase <> Up Jmp <:> mempty) <> Data (toBytes d) <:> mempty ------------------------------------------------------------------------------
+ TODO.md view
@@ -0,0 +1,23 @@++# Support more instructions++- pusha / popa ?++# Possible renaming++- x86 -> x64+- Code -> Asm / AsmCode+- compile -> compileAndRun+- codeBytes -> compile+- Bytes -> MachineCode ?+- Data -> DB++# Documentation++- add top level type signatures+- more Haddock comments++# Other++- merge Jmp and Jmpq constructors?+
x86-64bit.cabal view
@@ -1,5 +1,5 @@ name: x86-64bit -version: 0.1.2 +version: 0.1.3 homepage: https://github.com/divipp/x86-64 synopsis: Runtime code generation for x86 64 bit machine code description: The primary goal of x86-64bit is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. See README.md for further details. @@ -14,6 +14,7 @@ tested-with: GHC == 8.0.1 extra-source-files: README.md CHANGELOG.md + TODO.md source-repository head type: git @@ -45,6 +46,7 @@ DeriveFunctor DeriveFoldable DeriveTraversable + DataKinds GeneralizedNewtypeDeriving OverloadedStrings TupleSections