diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/CodeGen/X86.hs b/CodeGen/X86.hs --- a/CodeGen/X86.hs +++ b/CodeGen/X86.hs @@ -42,6 +42,7 @@ , (<>) , (<.>), (<:>) , j, j_back, if_ + , lea8 , leaData -- * Compilation , Callable diff --git a/CodeGen/X86/Asm.hs b/CodeGen/X86/Asm.hs --- a/CodeGen/X86/Asm.hs +++ b/CodeGen/X86/Asm.hs @@ -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 + diff --git a/CodeGen/X86/CodeGen.hs b/CodeGen/X86/CodeGen.hs --- a/CodeGen/X86/CodeGen.hs +++ b/CodeGen/X86/CodeGen.hs @@ -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 + diff --git a/CodeGen/X86/Examples.hs b/CodeGen/X86/Examples.hs --- a/CodeGen/X86/Examples.hs +++ b/CodeGen/X86/Examples.hs @@ -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 diff --git a/CodeGen/X86/Tests.hs b/CodeGen/X86/Tests.hs --- a/CodeGen/X86/Tests.hs +++ b/CodeGen/X86/Tests.hs @@ -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 diff --git a/CodeGen/X86/Utils.hs b/CodeGen/X86/Utils.hs --- a/CodeGen/X86/Utils.hs +++ b/CodeGen/X86/Utils.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -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? + diff --git a/x86-64bit.cabal b/x86-64bit.cabal --- a/x86-64bit.cabal +++ b/x86-64bit.cabal @@ -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