x86-64bit 0.1.1.1 → 0.1.2
raw patch · 13 files changed
+1903/−1703 lines, 13 filesdep +Win32dep ~base
Dependencies added: Win32
Dependency ranges changed: base
Files
- CHANGELOG.md +20/−14
- CodeGen/X86.hs +74/−67
- CodeGen/X86/Asm.hs +534/−534
- CodeGen/X86/CallConv.hs +95/−0
- CodeGen/X86/CodeGen.hs +392/−373
- CodeGen/X86/Examples.hs +81/−73
- CodeGen/X86/FFI.hs +119/−73
- CodeGen/X86/Tests.hs +395/−395
- CodeGen/X86/Utils.hs +69/−61
- LICENSE +30/−30
- README.md +13/−11
- Test.hs +4/−4
- x86-64bit.cabal +77/−68
CHANGELOG.md view
@@ -1,14 +1,20 @@-# Version 0.1.1.1--- change dependencies to reflect that the package compiles only with ghc 8-- add 'tested-with: GHC == 8.0.1' to the cabal file--# Version 0.1.1--- examples moved into the library-- more Haddock comments-- add cabal test suit-- bugfixes- - fix code generation for alignments- - smaller code is generated now for 'add rax, 100' and similar instrcutions-+# Version 0.1.2 + +- Windows operating system support +- GHC 7.10 support +- TODO.md file added + +# Version 0.1.1.1 + +- change dependencies to reflect that the package compiles only with ghc 8 +- add 'tested-with: GHC == 8.0.1' to the cabal file + +# Version 0.1.1 + +- examples moved into the library +- more Haddock comments +- add cabal test suit +- bugfixes + - fix code generation for alignments + - smaller code is generated now for 'add rax, 100' and similar instrcutions +
CodeGen/X86.hs view
@@ -1,67 +1,74 @@-{-# language PatternSynonyms #-}-module CodeGen.X86- (- -- * Byte sequences- Bytes (..)- , HasBytes (..)- -- * Sizes (in bits)- , Size (..)- , HasSize (..)- , IsSize- -- * Addresses- , base- , disp- , index1, index2, index4, index8- -- * Operands- , Access (..)- , Operand- , resizeOperand- -- ** Immediate values- , imm- -- ** Memory references- , addr- , ipBase- -- ** Registers- -- *** 64 bit registers- , rax, rcx, rdx, rbx, rsp, rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15- -- *** 32 bit registers- , eax, ecx, edx, ebx, esp, ebp, esi, edi, r8d, r9d, r10d, r11d, r12d, r13d, r14d, r15d- -- *** 16 bit registers- , ax, cx, dx, bx, sp, bp, si, di, r8w, r9w, r10w, r11w, r12w, r13w, r14w, r15w- -- *** 8 bit low registers- , al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b- -- *** 8 bit high registers- , ah, ch, dh, bh- -- * Conditions- , Condition- , pattern O, pattern NO, pattern C, pattern NC, pattern Z, pattern NZ, pattern BE, pattern NBE, pattern S, pattern NS, pattern P, pattern NP, pattern L, pattern NL, pattern LE, pattern NLE- -- * Assembly codes- , Code (..)- -- * Compound assembly codes- , (<>)- , (<.>), (<:>)- , j, j_back, if_- , leaData- -- * Compilation- , Callable- , compile- -- * Calling C and Haskell from Assembly- , callFun- , CallableHs- , hsPtr- -- * Misc- , runTests- , CString (..)- , traceReg- , memalign- , printf- ) where--import Data.Monoid--import CodeGen.X86.Asm-import CodeGen.X86.CodeGen-import CodeGen.X86.FFI-import CodeGen.X86.Utils-import CodeGen.X86.Tests-+{-# language CPP #-} +{-# language PatternSynonyms #-} +module CodeGen.X86 + ( + -- * Byte sequences + Bytes (..) + , HasBytes (..) + -- * Sizes (in bits) + , Size (..) + , HasSize (..) + , IsSize + -- * Addresses + , base + , disp + , index1, index2, index4, index8 + -- * Operands + , Access (..) + , Operand + , resizeOperand + -- ** Immediate values + , imm + -- ** Memory references + , addr + , ipBase + -- ** Registers + -- *** 64 bit registers + , rax, rcx, rdx, rbx, rsp, rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 + -- *** 32 bit registers + , eax, ecx, edx, ebx, esp, ebp, esi, edi, r8d, r9d, r10d, r11d, r12d, r13d, r14d, r15d + -- *** 16 bit registers + , ax, cx, dx, bx, sp, bp, si, di, r8w, r9w, r10w, r11w, r12w, r13w, r14w, r15w + -- *** 8 bit low registers + , al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b + -- *** 8 bit high registers + , ah, ch, dh, bh + -- * Conditions + , Condition + , pattern O, pattern NO, pattern C, pattern NC, pattern Z, pattern NZ, pattern BE, pattern NBE, pattern S, pattern NS, pattern P, pattern NP, pattern L, pattern NL, pattern LE, pattern NLE + -- * Assembly codes + , Code (..) + -- * Compound assembly codes + , (<>) + , (<.>), (<:>) + , j, j_back, if_ + , leaData + -- * Compilation + , Callable + , compile + -- * Calling C and Haskell from Assembly + , callFun + , saveNonVolatile + , arg1, arg2, arg3, arg4 + , result + , CallableHs + , hsPtr + -- * Misc + , runTests + , CString (..) + , traceReg +#ifdef linux_HOST_OS + , memalign +#endif + , printf + ) where + +import Data.Monoid + +import CodeGen.X86.Asm +import CodeGen.X86.CodeGen +import CodeGen.X86.FFI +import CodeGen.X86.CallConv +import CodeGen.X86.Utils +import CodeGen.X86.Tests +
CodeGen/X86/Asm.hs view
@@ -1,534 +1,534 @@-{-# 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 :: 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 +
+ CodeGen/X86/CallConv.hs view
@@ -0,0 +1,95 @@+ +-- | Calling conventions. There are basically only two: System V (Linux, OSX, BSD) and Win64\/fastcall + +{-# language CPP #-} +{-# language BangPatterns #-} +{-# language DataKinds #-} +module CodeGen.X86.CallConv where + +import Foreign +import Data.Monoid +import CodeGen.X86.Asm + +------------------------------------------------------------------------------ + +#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS) + +-- On Win64 the caller have to reserve 32 byte "shadow space" on the stack (and clean up after) +callFun :: Operand S64 RW -> FunPtr a -> Code +callFun r p + = Sub rsp (imm 32) + <> Mov r (imm $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) + <> Call r + <> Add rsp (imm 32) + +#else + +-- helper to call a function +callFun :: Operand S64 RW -> FunPtr a -> Code +callFun r p = Mov r (imm $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) <> Call r + +#endif + +------------------------------------------------------------------------------ + +-- | Save the non-volatile registers +-- +-- Note: R12..R15 should be preserved on both Windows and Linux. +-- This is the responsability of the user (this won't save them). +-- +saveNonVolatile :: Code -> Code +saveNonVolatile code = prologue <> code <> epilogue <> Ret + +------------------------------------------------------------------------------ +-- calling conventions + +#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS) + +---------- Win64 calling convention ---------- + +arg1 = rcx +arg2 = rdx +arg3 = r8 +arg4 = r9 +-- rest of the arguments on the stack + +result = rax + +prologue + = Push rbp + <> Push rbx + <> Push rdi + <> Push rsi + +epilogue + = Pop rsi + <> Pop rdi + <> Pop rbx + <> Pop rbp + +#elif defined (linux_HOST_OS) + +---------- System V calling convention ---------- + +arg1 = rdi +arg2 = rsi +arg3 = rdx +arg4 = rcx +arg5 = r8 +arg6 = r9 +-- rest of the arguments on the stack + +result = rax + +prologue + = Push rbp + <> Push rbx + +epilogue + = Pop rbx + <> Pop rbp + +#endif + +------------------------------------------------------------------------------ +
CodeGen/X86/CodeGen.hs view
@@ -1,373 +1,392 @@-{-# 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 -> ([Either Int (Int, Word8)], CodeBuilderState)}--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 (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 s = sizeLen s - 1- where- 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 = mkCodeBuilder' . Data- toCode = bytesToCode . toBytes-- 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_ (NormalReg r) = r .&. 0x7- reg8_ (HighReg r) = r .|. 0x4-- regprefix s r c im = sizePrefix_ (regs r) s r (extbits r) c im- 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'' r p c = regprefix (size r) r $ extension r p <> c-- 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 op dest src@(RegOp r) = regprefix2 dest src op $ reg8 (reg8_ r) dest-- op1_ r1 r2 dest im = regprefix'' dest r1 (reg8 r2 dest) im-- 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 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) + +------------------------------------------------------- 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 +
CodeGen/X86/Examples.hs view
@@ -1,73 +1,81 @@-{-# language BangPatterns #-}-module CodeGen.X86.Examples where--import Foreign--import CodeGen.X86-------------------------------------------------------------------------------- examples---- | Example: identity function in Assembly (look at the source code)------ Input: @rdi@------ Output: @rax@-idCode- = Mov rax rdi- <> Ret--idFun :: Word64 -> Word64-idFun = compile idCode ---- | Example: Fibonacci function in Assembly-fibCode- = Inc rdi- <> Xor rdx rdx- <> Mov rax (imm 1)- <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> Dec rdi) `j_back` NZ- <> Ret--fibFun :: Word64 -> Word64-fibFun = compile fibCode ---- | Example: trace a register in Assembly-tracedFibCode- = Inc rdi- <> Xor rdx rdx- <> Mov rax (imm 1)- <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> traceReg "d" rax <> Dec rdi) `j_back` NZ- <> Ret--tracedFibFun :: Word64 -> Word64-tracedFibFun = compile tracedFibCode ---- | Example: call Haskell @fib@ function from Assembly-callHsCode- = callFun rdx (hsPtr fib)- <> Ret--fib :: Word64 -> Word64-fib n = go n 0 1- where- go 0 !a !b = a- go n a b = go (n-1) b (a+b)--callHsFun :: Word64 -> Word64-callHsFun = compile callHsCode ---- | Example: call C @printf@ function from Assembly-callCCode name- = leaData rdi (CString "Hello %s!\n")- <> leaData rsi (CString name)- <> callFun rdx printf- <> Ret--callCFun :: String -> IO ()-callCFun name = compile $ callCCode name--memTestFun :: Word64 -> IO Bool-memTestFun v = do- r <- memalign 8 8- pokeByteOff r 0 (v :: Word64)- return $ compile (Mov rax (addr $ base rdi) <> Ret) r == v-+{-# language CPP #-} +{-# language BangPatterns #-} +module CodeGen.X86.Examples where + +import Foreign + +import CodeGen.X86 + +------------------------------------------------------------------------------ +-- * examples + +-- | Example: identity function in Assembly (look at the source code) +-- +-- Input: @rdi@ on Linux \/ System V, @rcx@ on Win64 +-- +-- Output: @rax@ +idCode + = Mov result arg1 + <> Ret + +idFun :: Word64 -> Word64 +idFun = compile idCode + +-- | Example: Fibonacci function in Assembly +fibCode = saveNonVolatile + $ Mov rdi arg1 + <> Inc rdi + <> Xor rdx rdx + <> Mov rax (imm 1) + <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> Dec rdi) `j_back` NZ + +fibFun :: Word64 -> Word64 +fibFun = compile fibCode + +-- | Example: trace a register in Assembly +tracedFibCode = saveNonVolatile + $ Mov rdi arg1 + <> Inc rdi + <> Xor rdx rdx + <> Mov rax (imm 1) + <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> traceReg "d" rax {- <> traceReg "d" rdi -} <> Dec rdi) `j_back` NZ + +tracedFibFun :: Word64 -> Word64 +tracedFibFun = compile tracedFibCode + +-- | Example: call Haskell @fib@ function from Assembly +callHsCode + = callFun r11 (hsPtr fib) + <> Ret + +fib :: Word64 -> Word64 +fib n = go n 0 1 + where + go 0 !a !b = a + go n a b = go (n-1) b (a+b) + +callHsFun :: Word64 -> Word64 +callHsFun = compile callHsCode + +-- | Example: call C @printf@ function from Assembly +-- +callCCode name = saveNonVolatile + $ leaData arg1 (CString "Hello %s!\n") + <> leaData arg2 (CString name) + <> Xor rax rax -- zero XMM arguments ????? + <> callFun r11 printf + +callCFun :: String -> IO () +callCFun name = compile $ callCCode name + +------------------------------------------------------- + +memTestFun :: Word64 -> IO Bool +memTestFun v = do + r <- mallocBytes 8 -- this is not required to be aligned (and in any case malloc aligns to machine words) + pokeByteOff r 0 (v :: Word64) + let code = saveNonVolatile + $ Mov rdi arg1 <> Mov rax (addr $ base rdi) + return $ compile code r == v + +
CodeGen/X86/FFI.hs view
@@ -1,73 +1,119 @@-{-# language ForeignFunctionInterface #-}-{-# language BangPatterns #-}-{-# language ViewPatterns #-}-{-# language FlexibleInstances #-}-module CodeGen.X86.FFI where--import Control.Monad-import Control.Exception (evaluate)-import Foreign-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.ForeignPtr.Unsafe-import System.IO.Unsafe--import CodeGen.X86.Asm-import CodeGen.X86.CodeGen-----------------------------------------------------------foreign import ccall "dynamic" callWord64 :: FunPtr Word64 -> Word64-foreign import ccall "dynamic" callWord32 :: FunPtr Word32 -> Word32-foreign import ccall "dynamic" callWord16 :: FunPtr Word16 -> Word16-foreign import ccall "dynamic" callWord8 :: FunPtr Word8 -> Word8-foreign import ccall "dynamic" callBool :: FunPtr Bool -> Bool-foreign import ccall "dynamic" callIOUnit :: FunPtr (IO ()) -> IO ()-foreign import ccall "dynamic" callWord64_Word64 :: FunPtr (Word64 -> Word64) -> Word64 -> Word64-foreign import ccall "dynamic" callPtr_Word64 :: FunPtr (Ptr a -> Word64) -> Ptr a -> Word64--unsafeCallForeignPtr0 call p = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p)) <* touchForeignPtr p--unsafeCallForeignPtr1 call p a = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) a) <* touchForeignPtr p--unsafeCallForeignPtrIO0 call p = call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) <* touchForeignPtr p---class Callable a where unsafeCallForeignPtr :: ForeignPtr a -> a--instance Callable Word64 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord64-instance Callable Word32 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord32-instance Callable Word16 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord16-instance Callable Word8 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord8-instance Callable Bool where unsafeCallForeignPtr = unsafeCallForeignPtr0 callBool-instance Callable (IO ()) where unsafeCallForeignPtr = unsafeCallForeignPtrIO0 callIOUnit-instance Callable (Word64 -> Word64) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callWord64_Word64-instance Callable (Ptr a -> Word64) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word64-----------------------------------------------------------foreign import ccall "static stdlib.h memalign" memalign :: CUInt -> CUInt -> IO (Ptr a)-foreign import ccall "static stdlib.h &free" stdfree :: FunPtr (Ptr a -> IO ())-foreign import ccall "static sys/mman.h mprotect" mprotect :: Ptr a -> CUInt -> Int -> IO Int--{-# NOINLINE compile #-}-compile :: Callable a => Code -> a-compile x = unsafeCallForeignPtr $ unsafePerformIO $ do- let (bytes, fromIntegral -> size) = buildTheCode x- arr <- memalign 0x1000 size- _ <- mprotect arr size 0x7 -- READ, WRITE, EXEC- forM_ [p | Right p <- bytes] $ uncurry $ pokeByteOff arr- newForeignPtr stdfree arr-----------------------------------------------------------foreign import ccall "wrapper" createPtrWord64_Word64 :: (Word64 -> Word64) -> IO (FunPtr (Word64 -> Word64))--class CallableHs a where createHsPtr :: a -> IO (FunPtr a)--instance CallableHs (Word64 -> Word64) where createHsPtr = createPtrWord64_Word64--hsPtr :: CallableHs a => a -> FunPtr a-hsPtr x = unsafePerformIO $ createHsPtr x--+{-# language CPP #-} +{-# language ForeignFunctionInterface #-} +{-# language BangPatterns #-} +{-# language ViewPatterns #-} +{-# language FlexibleInstances #-} +module CodeGen.X86.FFI where + +------------------------------------------------------- + +import Control.Monad +import Control.Exception (evaluate) +import Foreign +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.ForeignPtr.Unsafe +import System.IO.Unsafe + +import CodeGen.X86.Asm +import CodeGen.X86.CodeGen + +------------------------------------------------------- + +#define PAGE_SIZE 4096 + +#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS) + +import System.Win32.Types +import System.Win32.Mem +import Foreign.Marshal.Alloc + +#endif + +------------------------------------------------------- + +foreign import ccall "dynamic" callWord64 :: FunPtr Word64 -> Word64 +foreign import ccall "dynamic" callWord32 :: FunPtr Word32 -> Word32 +foreign import ccall "dynamic" callWord16 :: FunPtr Word16 -> Word16 +foreign import ccall "dynamic" callWord8 :: FunPtr Word8 -> Word8 +foreign import ccall "dynamic" callBool :: FunPtr Bool -> Bool +foreign import ccall "dynamic" callIOUnit :: FunPtr (IO ()) -> IO () +foreign import ccall "dynamic" callWord64_Word64 :: FunPtr (Word64 -> Word64) -> Word64 -> Word64 +foreign import ccall "dynamic" callPtr_Word64 :: FunPtr (Ptr a -> Word64) -> Ptr a -> Word64 + +unsafeCallForeignPtr0 call p = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p)) <* touchForeignPtr p + +unsafeCallForeignPtr1 call p a = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) a) <* touchForeignPtr p + +unsafeCallForeignPtrIO0 call p = call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) <* touchForeignPtr p + + +class Callable a where unsafeCallForeignPtr :: ForeignPtr a -> a + +instance Callable Word64 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord64 +instance Callable Word32 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord32 +instance Callable Word16 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord16 +instance Callable Word8 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord8 +instance Callable Bool where unsafeCallForeignPtr = unsafeCallForeignPtr0 callBool +instance Callable (IO ()) where unsafeCallForeignPtr = unsafeCallForeignPtrIO0 callIOUnit +instance Callable (Word64 -> Word64) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callWord64_Word64 +instance Callable (Ptr a -> Word64) where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word64 + +------------------------------------------------------- + +#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS) +-- note: GHC 64 bit also defines mingw32 ... + +foreign import ccall "static malloc.h _aligned_malloc" c_aligned_malloc :: CSize -> CSize -> IO (Ptr a) +foreign import ccall "static malloc.h _aligned_free" c_aligned_free :: Ptr a -> IO () +foreign import ccall "static malloc.h &_aligned_free" ptr_aligned_free :: FunPtr (Ptr a -> IO ()) + +#elif defined linux_HOST_OS + +foreign import ccall "static stdlib.h memalign" memalign :: CUInt -> CUInt -> IO (Ptr a) +foreign import ccall "static stdlib.h &free" stdfree :: FunPtr (Ptr a -> IO ()) +foreign import ccall "static sys/mman.h mprotect" mprotect :: Ptr a -> CUInt -> Int -> IO Int + +#endif + +------------------------------------------------------- + +#if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS) + +flag_PAGE_EXECUTE_READWRITE :: Word32 +flag_PAGE_EXECUTE_READWRITE = 0x40 + +{-# NOINLINE compile #-} +compile :: Callable a => Code -> a +compile x = unsafeCallForeignPtr $ unsafePerformIO $ do + let (bytes, fromIntegral -> size) = buildTheCode x + arr <- c_aligned_malloc (fromIntegral size) PAGE_SIZE + _ <- virtualProtect (castPtr arr) (fromIntegral size) flag_PAGE_EXECUTE_READWRITE + forM_ [p | Right p <- bytes] $ uncurry $ pokeByteOff arr + newForeignPtr ptr_aligned_free arr + +#elif defined linux_HOST_OS + +{-# NOINLINE compile #-} +compile :: Callable a => Code -> a +compile x = unsafeCallForeignPtr $ unsafePerformIO $ do + let (bytes, fromIntegral -> size) = buildTheCode x + arr <- memalign PAGE_SIZE size + _ <- mprotect arr size 0x7 -- READ, WRITE, EXEC + forM_ [p | Right p <- bytes] $ uncurry $ pokeByteOff arr + newForeignPtr stdfree arr + +#endif + +------------------------------------------------------- + +foreign import ccall "wrapper" createPtrWord64_Word64 :: (Word64 -> Word64) -> IO (FunPtr (Word64 -> Word64)) + +class CallableHs a where createHsPtr :: a -> IO (FunPtr a) + +instance CallableHs (Word64 -> Word64) where createHsPtr = createPtrWord64_Word64 + +hsPtr :: CallableHs a => a -> FunPtr a +hsPtr x = unsafePerformIO $ createHsPtr x + +
CodeGen/X86/Tests.hs view
@@ -1,395 +1,395 @@-{-# 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 #-}-{-# LANGUAGE TemplateHaskell #-}-module CodeGen.X86.Tests (runTests) where--import Data.Monoid-import Data.Maybe-import Data.List-import Data.Bits-import Data.Int-import Data.Word--import Test.QuickCheck hiding ((.&.))-import Debug.Trace--import CodeGen.X86.Asm-import CodeGen.X86.CodeGen-import CodeGen.X86.FFI-import CodeGen.X86.Utils----------------------------------------------------------------------------------class HasSigned a where- type Signed a- toSigned :: a -> Signed a- fromSigned :: Signed a -> a- shiftMask :: a--instance HasSigned Word8 where- type Signed Word8 = Int8- toSigned = fromIntegral- fromSigned = fromIntegral- shiftMask = 0x1f--instance HasSigned Word16 where- type Signed Word16 = Int16- toSigned = fromIntegral- fromSigned = fromIntegral- shiftMask = 0x1f--instance HasSigned Word32 where- type Signed Word32 = Int32- toSigned = fromIntegral- fromSigned = fromIntegral- shiftMask = 0x1f--instance HasSigned Word64 where- type Signed Word64 = Int64- toSigned = fromIntegral- fromSigned = fromIntegral- shiftMask = 0x3f----------------------------------------------------------------------------------prop_integral x@(Integral y) = x == y----------------------------------------------------------------------------------instance Arbitrary Size where arbitrary = elements [S8, S16, S32, S64]--instance Arbitrary Scale where arbitrary = elements [s1, s2, s4, s8]--arbVal :: Size -> Gen Int64-arbVal S8 = fromIntegral <$> (arbitrary :: Gen Int8)-arbVal S16 = fromIntegral <$> (arbitrary :: Gen Int16)-arbVal S32 = fromIntegral <$> (arbitrary :: Gen Int32)-arbVal S64 = fromIntegral <$> (arbitrary :: Gen Int64)--genReg8 :: Gen (Reg S8)-genReg8 = elements ((NormalReg <$> [0..15]) ++ (HighReg <$> [0..3]))-genReg16 :: Gen (Reg S16)-genReg16 = NormalReg <$> elements [0..15]-genReg32 :: Gen (Reg S32)-genReg32 = NormalReg <$> elements [0..15]-genReg64 :: Gen (Reg S64)-genReg64 = NormalReg <$> elements [0..15]--instance IsSize s => Arbitrary (Reg s) where- arbitrary = f (ssize :: SSize s) where- f :: SSize s -> Gen (Reg s)- f SSize8 = genReg8- f SSize16 = genReg16- f SSize32 = genReg32- f SSize64 = genReg64--genRegs = RegOp <$> arbitrary--genIPBase = pure ipBase--instance Arbitrary (Addr S64) where- arbitrary = suchThat (Addr <$> base <*> disp <*> index) ok- where- ok (Addr Nothing _ Nothing) = False- ok (Addr Nothing _ (Just (sc, _))) = sc == s1- ok _ = True- base = oneof- [ return Nothing- , Just <$> arbitrary- ]- disp = oneof- [ return NoDisp- , Disp <$> arbitrary- ]- index = oneof- [ return NoIndex- , IndexReg <$> arbitrary <*> iregs- ]- iregs = NormalReg <$> elements ([0..15] \\ [4]) -- sp cannot be index--genMems = MemOp <$> (arbitrary :: Gen (Addr S64))--instance IsSize s => Arbitrary (Operand s RW) where- arbitrary = oneof- [ genRegs- , genMems- , genIPBase- ]--instance IsSize s => Arbitrary (Operand s R) where- arbitrary = oneof- [ ImmOp <$> oneof (arbVal <$> [S8, S16, S32, S64])- , genRegs- , genMems- , genIPBase- ]--instance Arbitrary Code where- arbitrary = oneof- [ op2 Add- , op2 Or- , op2 Adc- , op2 Sbb- , op2 And- , op2 Sub- , op2 Xor- , op2 Cmp- , op2 Test- , op2' Rol- , op2' Ror- , op2' Rcl- , op2' Rcr- , op2' Shl- , op2' Shr- , op2' Sar- , op2'' Mov- ]- where- op2 :: (forall s . IsSize s => Operand s RW -> Operand s R -> Code) -> Gen Code- op2 op = oneof- [ f op (arbitrary :: Gen (Operand S8 RW)) arbitrary- , f op (arbitrary :: Gen (Operand S16 RW)) arbitrary- , f op (arbitrary :: Gen (Operand S32 RW)) arbitrary- , f op (arbitrary :: Gen (Operand S64 RW)) arbitrary- ]- where- f :: forall s . IsSize s => (Operand s RW -> Operand s R -> Code) -> Gen (Operand s RW) -> Gen (Operand s R) -> Gen Code- f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b)-- op2'' :: (forall s . IsSize s => Operand s RW -> Operand s R -> Code) -> Gen Code- op2'' op = oneof- [ f op (arbitrary :: Gen (Operand S8 RW)) arbitrary- , f op (arbitrary :: Gen (Operand S16 RW)) arbitrary- , f op (arbitrary :: Gen (Operand S32 RW)) arbitrary- , f op (arbitrary :: Gen (Operand S64 RW)) arbitrary- ]- where- f :: forall s . IsSize s => (Operand s RW -> Operand s R -> Code) -> Gen (Operand s RW) -> Gen (Operand s R) -> Gen Code- f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && oki a b)-- op2' :: (forall s . IsSize s => Operand s RW -> Operand S8 R -> Code) -> Gen Code- op2' op = oneof- [ f op (arbitrary :: Gen (Operand S8 RW)) arb- , f op (arbitrary :: Gen (Operand S16 RW)) arb- , f op (arbitrary :: Gen (Operand S32 RW)) arb- , f op (arbitrary :: Gen (Operand S64 RW)) arb- ]- where- arb = oneof- [ ImmOp . fromIntegral <$> (arbitrary :: Gen Word8)- , return cl- ]-- f :: forall s . IsSize s => (Operand s RW -> Operand S8 R -> Code) -> Gen (Operand s RW) -> Gen (Operand S8 R) -> Gen Code- f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b && noteqreg a b)-- 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 _ _ = True-- -- TODO: remove- ok' RegOp{} RegOp{} = True- 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 a b = okk a b-------------------------------------------------------evalOp :: forall a . (HasSigned a, Integral a, Integral (Signed a), FiniteBits (Signed a), Num a, FiniteBits a) => Code -> Bool -> a -> a -> ((Bool, Bool), a)-evalOp op c = case op of- Add{} -> mk (+)- Or{} -> mk (.|.)- Adc{} -> mk $ if c then \a b -> a + b + 1 else (+)- Sbb{} -> mk $ if c then \a b -> a - b - 1 else (-)- And{} -> mk (.&.)- Sub{} -> mk (-)- Xor{} -> mk xor- Cmp{} -> mk_ (-) (\a b -> a)- Test{} -> mk_ (.&.) (\a b -> a)- Mov{} -> \a b -> ((c, False), b)- Shl{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), a `shiftL` i)- Shr{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` (i-1), False), a `shiftR` i)- Sar{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else toSigned a `testBit'` (i-1), False), fromSigned (toSigned a `shiftR` i))- Rol{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` ((finiteBitSize a - i) `mod` finiteBitSize a), False), a `roL` i)- Ror{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` ((i-1) `mod` finiteBitSize a), False), a `roR` i)- Rcl{} -> \a b -> let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1) in ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), rcL c a i)- Rcr{} -> \a b -> let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1) in ((if i == 0 then c else a `testBit` (i-1), False), rcR c a i)-- where- mk :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> a -> a -> ((Bool, Bool), a)- mk f = mk_ f f-- mk_ :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> (a -> a -> a) -> a -> a -> ((Bool, Bool), a)- mk_ f g a b = ((extend (f a b) /= f (extend a) (extend b), sextend (f a b) /= f (sextend a) (sextend b)), g a b)-- extend :: a -> Integer- extend = fromIntegral- sextend :: a -> Integer- sextend = fromIntegral . toSigned-- rcL c a 0 = a- rcL c a i = (if c then setBit else clearBit) (a `shiftL` i .|. a `shiftR` (finiteBitSize a - i + 1)) (i - 1)-- rcR c a 0 = a- rcR c a i = (if c then setBit else clearBit) (a `shiftR` i .|. a `shiftL` (finiteBitSize a - i + 1)) (finiteBitSize a - i)-- roL a i = a `shiftL` j .|. a `shiftR` (finiteBitSize a - j)- where- j = i `mod` finiteBitSize a-- roR a i = a `shiftR` j .|. a `shiftL` (finiteBitSize a - j)- where- j = i `mod` finiteBitSize a-- testBit' a i- | isSigned a && i >= finiteBitSize a = testBit a (finiteBitSize a - 1)- | otherwise = testBit a i---data InstrTest = IT String Code--instance Show InstrTest where show (IT s _) = s--instance Arbitrary InstrTest where- arbitrary = do- i <- arbitrary- cF <- arbitrary- let fff :: forall s s' r . (IsSize s, IsSize s') => Code -> (Operand s RW -> Operand s' r -> Code) -> Operand s RW -> Operand s' r -> Gen InstrTest- fff op op' a b = do- let- (f1: f2: _) = map RegOp $ filter (`notElem` (regi a ++ regi b)) $ NormalReg <$> [8..15]- regi = map phisicalReg . regs-- ff :: Operand s RW -> Operand s' k -> Gen (Int64, Int64, Code -> Code)- ff a@(RegOp x) (RegOp x') | Just Refl <- sizeEqCheck x x', x == x' = do- (av, inita) <- mkVal f2 a- return (av, av, inita)- ff (MemOp (Addr (Just x) _ _)) (RegOp x') | phisicalReg (SReg x) == phisicalReg (SReg x') = error "TODO" {-do- (av, inita) <- mkVal a- return (av, av, inita) -}- ff a_ b_ = do- (av, inita) <- mkVal f2 a_- (bv, initb) <- mkVal f2 b_- return (av, bv, inita . initb)-- (av, bv, initab) <- ff a b- let- code = foldMap Push sr <> Mov f1 rsp <> PushF <> Pop rax <> Push rax <> PopF- <> initab (initcf <> cc <> mova) <> mkRes- <> Mov rsp f1 {- <> traceReg "X" rdx' -} <> foldMap Pop (reverse sr) <> Ret-- sr = [rbx, rbp, r12, r13, r14, r15]-- cc = i- initcf = if cF then Stc else Clc- mova = case a of- RegOp (NormalReg 0x2) -> mempty- _ -> Mov rdx' a- mkRes = otest cc (if_ (if cF' then C else NC) (Xor rax rax) (Xor rax rax <> Mov rcx res <> Cmp rcx' rdx' <> j NZ (Inc rax)))- isShift = \case- Rol{} -> True- Ror{} -> True- Rcl{} -> True- Rcr{} -> True- Shl{} -> True- Shr{} -> True- Sar{} -> True- _ -> False- otest i x | isShift i = x- otest _ x = if_ (if oF' then O else NO) (Xor rax rax) x-- rcx' = resizeOperand rcx :: Operand s RW- rdx' = resizeOperand rdx :: Operand s RW- sa = size a-- ((cF', oF'), res) = case sa of- S8 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word8)- S16 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word16)- S32 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word32)- S64 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word64)-- msg = unlines [show i, "code: " ++ show cc, "input a: " ++ show av, "input b: " ++ show bv, "input flags: " ++ show cF, "output: " ++ show res, "output flags: " ++ show cF' ++ " " ++ show oF']-- return $ traceShow i $ IT msg code-- case i of- Add a_ b_ -> fff i Add a_ b_- Or a_ b_ -> fff i Or a_ b_- Adc a_ b_ -> fff i Adc a_ b_- Sbb a_ b_ -> fff i Sbb a_ b_- And a_ b_ -> fff i And a_ b_- Sub a_ b_ -> fff i Sub a_ b_- Xor a_ b_ -> fff i Xor a_ b_- Cmp a_ b_ -> fff i Cmp a_ b_- Test a_ b_ -> fff i Test a_ b_- Rol a_ b_ -> fff i Rol a_ b_- Ror a_ b_ -> fff i Ror a_ b_- Rcl a_ b_ -> fff i Rcl a_ b_- Rcr a_ b_ -> fff i Rcr a_ b_- Shl a_ b_ -> fff i Shl a_ b_- Shr a_ b_ -> fff i Shr a_ b_- Sar a_ b_ -> fff i Sar a_ b_- Mov a_ b_ -> fff i Mov a_ b_-- where- mkVal :: IsSize s => Operand S64 RW -> Operand s k -> Gen (Int64, Code -> Code)- mkVal _ o@(ImmOp 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- 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- v <- arbVal $ size o- (vi, setvi) <- case i of- NoIndex -> return (0, mempty)- IndexReg sc i -> do- x <- arbVal $ size i- return (scaleFactor sc * x, Mov (RegOp i) (ImmOp x))- let- d' = (vi :: Int64) + case d of- NoDisp -> 0- Disp v -> fromIntegral v- rx = resizeOperand $ RegOp x :: Operand S64 RW- return (v, ((leaData rx v <> Mov helper (imm d') <> Sub rx helper <> setvi) <>))- mkVal helper o@(MemOp (Addr Nothing d (Just (sc, x)))) = do- v <- arbVal $ size o- let- d' = case d of- NoDisp -> 0 :: Int64- Disp v -> fromIntegral v- rx = resizeOperand $ RegOp x :: Operand S64 RW- return (v, ((leaData rx v <> Mov helper (imm d') <> Sub rx helper) <>))---propInstr (IT _ c) = compile c :: Bool--tests num = quickCheckWith stdArgs { maxSuccess = num } propInstr---------------------------------------------return []---- | Run all tests-runTests = do- $quickCheckAll- tests 2000-+{-# 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 #-} +{-# LANGUAGE TemplateHaskell #-} +module CodeGen.X86.Tests (runTests) where + +import Data.Monoid +import Data.Maybe +import Data.List +import Data.Bits +import Data.Int +import Data.Word + +import Test.QuickCheck hiding ((.&.)) +import Debug.Trace + +import CodeGen.X86.Asm +import CodeGen.X86.CodeGen +import CodeGen.X86.FFI +import CodeGen.X86.Utils + +------------------------------------------------------------------------------ + +class HasSigned a where + type Signed a + toSigned :: a -> Signed a + fromSigned :: Signed a -> a + shiftMask :: a + +instance HasSigned Word8 where + type Signed Word8 = Int8 + toSigned = fromIntegral + fromSigned = fromIntegral + shiftMask = 0x1f + +instance HasSigned Word16 where + type Signed Word16 = Int16 + toSigned = fromIntegral + fromSigned = fromIntegral + shiftMask = 0x1f + +instance HasSigned Word32 where + type Signed Word32 = Int32 + toSigned = fromIntegral + fromSigned = fromIntegral + shiftMask = 0x1f + +instance HasSigned Word64 where + type Signed Word64 = Int64 + toSigned = fromIntegral + fromSigned = fromIntegral + shiftMask = 0x3f + +------------------------------------------------------------------------------ + +prop_integral x@(Integral y) = x == y + +------------------------------------------------------------------------------ + +instance Arbitrary Size where arbitrary = elements [S8, S16, S32, S64] + +instance Arbitrary Scale where arbitrary = elements [s1, s2, s4, s8] + +arbVal :: Size -> Gen Int64 +arbVal S8 = fromIntegral <$> (arbitrary :: Gen Int8) +arbVal S16 = fromIntegral <$> (arbitrary :: Gen Int16) +arbVal S32 = fromIntegral <$> (arbitrary :: Gen Int32) +arbVal S64 = fromIntegral <$> (arbitrary :: Gen Int64) + +genReg8 :: Gen (Reg S8) +genReg8 = elements ((NormalReg <$> [0..15]) ++ (HighReg <$> [0..3])) +genReg16 :: Gen (Reg S16) +genReg16 = NormalReg <$> elements [0..15] +genReg32 :: Gen (Reg S32) +genReg32 = NormalReg <$> elements [0..15] +genReg64 :: Gen (Reg S64) +genReg64 = NormalReg <$> elements [0..15] + +instance IsSize s => Arbitrary (Reg s) where + arbitrary = f (ssize :: SSize s) where + f :: SSize s -> Gen (Reg s) + f SSize8 = genReg8 + f SSize16 = genReg16 + f SSize32 = genReg32 + f SSize64 = genReg64 + +genRegs = RegOp <$> arbitrary + +genIPBase = pure ipBase + +instance Arbitrary (Addr S64) where + arbitrary = suchThat (Addr <$> base <*> disp <*> index) ok + where + ok (Addr Nothing _ Nothing) = False + ok (Addr Nothing _ (Just (sc, _))) = sc == s1 + ok _ = True + base = oneof + [ return Nothing + , Just <$> arbitrary + ] + disp = oneof + [ return NoDisp + , Disp <$> arbitrary + ] + index = oneof + [ return NoIndex + , IndexReg <$> arbitrary <*> iregs + ] + iregs = NormalReg <$> elements ([0..15] \\ [4]) -- sp cannot be index + +genMems = MemOp <$> (arbitrary :: Gen (Addr S64)) + +instance IsSize s => Arbitrary (Operand s RW) where + arbitrary = oneof + [ genRegs + , genMems + , genIPBase + ] + +instance IsSize s => Arbitrary (Operand s R) where + arbitrary = oneof + [ ImmOp <$> oneof (arbVal <$> [S8, S16, S32, S64]) + , genRegs + , genMems + , genIPBase + ] + +instance Arbitrary Code where + arbitrary = oneof + [ op2 Add + , op2 Or + , op2 Adc + , op2 Sbb + , op2 And + , op2 Sub + , op2 Xor + , op2 Cmp + , op2 Test + , op2' Rol + , op2' Ror + , op2' Rcl + , op2' Rcr + , op2' Shl + , op2' Shr + , op2' Sar + , op2'' Mov + ] + where + op2 :: (forall s . IsSize s => Operand s RW -> Operand s R -> Code) -> Gen Code + op2 op = oneof + [ f op (arbitrary :: Gen (Operand S8 RW)) arbitrary + , f op (arbitrary :: Gen (Operand S16 RW)) arbitrary + , f op (arbitrary :: Gen (Operand S32 RW)) arbitrary + , f op (arbitrary :: Gen (Operand S64 RW)) arbitrary + ] + where + f :: forall s . IsSize s => (Operand s RW -> Operand s R -> Code) -> Gen (Operand s RW) -> Gen (Operand s R) -> Gen Code + f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b) + + op2'' :: (forall s . IsSize s => Operand s RW -> Operand s R -> Code) -> Gen Code + op2'' op = oneof + [ f op (arbitrary :: Gen (Operand S8 RW)) arbitrary + , f op (arbitrary :: Gen (Operand S16 RW)) arbitrary + , f op (arbitrary :: Gen (Operand S32 RW)) arbitrary + , f op (arbitrary :: Gen (Operand S64 RW)) arbitrary + ] + where + f :: forall s . IsSize s => (Operand s RW -> Operand s R -> Code) -> Gen (Operand s RW) -> Gen (Operand s R) -> Gen Code + f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && oki a b) + + op2' :: (forall s . IsSize s => Operand s RW -> Operand S8 R -> Code) -> Gen Code + op2' op = oneof + [ f op (arbitrary :: Gen (Operand S8 RW)) arb + , f op (arbitrary :: Gen (Operand S16 RW)) arb + , f op (arbitrary :: Gen (Operand S32 RW)) arb + , f op (arbitrary :: Gen (Operand S64 RW)) arb + ] + where + arb = oneof + [ ImmOp . fromIntegral <$> (arbitrary :: Gen Word8) + , return cl + ] + + f :: forall s . IsSize s => (Operand s RW -> Operand S8 R -> Code) -> Gen (Operand s RW) -> Gen (Operand S8 R) -> Gen Code + f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b && noteqreg a b) + + 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 _ _ = True + + -- TODO: remove + ok' RegOp{} RegOp{} = True + 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 a b = okk a b + +--------------------------------------------------- + +evalOp :: forall a . (HasSigned a, Integral a, Integral (Signed a), FiniteBits (Signed a), Num a, FiniteBits a) => Code -> Bool -> a -> a -> ((Bool, Bool), a) +evalOp op c = case op of + Add{} -> mk (+) + Or{} -> mk (.|.) + Adc{} -> mk $ if c then \a b -> a + b + 1 else (+) + Sbb{} -> mk $ if c then \a b -> a - b - 1 else (-) + And{} -> mk (.&.) + Sub{} -> mk (-) + Xor{} -> mk xor + Cmp{} -> mk_ (-) (\a b -> a) + Test{} -> mk_ (.&.) (\a b -> a) + Mov{} -> \a b -> ((c, False), b) + Shl{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), a `shiftL` i) + Shr{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` (i-1), False), a `shiftR` i) + Sar{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else toSigned a `testBit'` (i-1), False), fromSigned (toSigned a `shiftR` i)) + Rol{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` ((finiteBitSize a - i) `mod` finiteBitSize a), False), a `roL` i) + Ror{} -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` ((i-1) `mod` finiteBitSize a), False), a `roR` i) + Rcl{} -> \a b -> let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1) in ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), rcL c a i) + Rcr{} -> \a b -> let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1) in ((if i == 0 then c else a `testBit` (i-1), False), rcR c a i) + + where + mk :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> a -> a -> ((Bool, Bool), a) + mk f = mk_ f f + + mk_ :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> (a -> a -> a) -> a -> a -> ((Bool, Bool), a) + mk_ f g a b = ((extend (f a b) /= f (extend a) (extend b), sextend (f a b) /= f (sextend a) (sextend b)), g a b) + + extend :: a -> Integer + extend = fromIntegral + sextend :: a -> Integer + sextend = fromIntegral . toSigned + + rcL c a 0 = a + rcL c a i = (if c then setBit else clearBit) (a `shiftL` i .|. a `shiftR` (finiteBitSize a - i + 1)) (i - 1) + + rcR c a 0 = a + rcR c a i = (if c then setBit else clearBit) (a `shiftR` i .|. a `shiftL` (finiteBitSize a - i + 1)) (finiteBitSize a - i) + + roL a i = a `shiftL` j .|. a `shiftR` (finiteBitSize a - j) + where + j = i `mod` finiteBitSize a + + roR a i = a `shiftR` j .|. a `shiftL` (finiteBitSize a - j) + where + j = i `mod` finiteBitSize a + + testBit' a i + | isSigned a && i >= finiteBitSize a = testBit a (finiteBitSize a - 1) + | otherwise = testBit a i + + +data InstrTest = IT String Code + +instance Show InstrTest where show (IT s _) = s + +instance Arbitrary InstrTest where + arbitrary = do + i <- arbitrary + cF <- arbitrary + let fff :: forall s s' r . (IsSize s, IsSize s') => Code -> (Operand s RW -> Operand s' r -> Code) -> Operand s RW -> Operand s' r -> Gen InstrTest + fff op op' a b = do + let + (f1: f2: _) = map RegOp $ filter (`notElem` (regi a ++ regi b)) $ NormalReg <$> [8..15] + regi = map phisicalReg . regs + + ff :: Operand s RW -> Operand s' k -> Gen (Int64, Int64, Code -> Code) + ff a@(RegOp x) (RegOp x') | Just Refl <- sizeEqCheck x x', x == x' = do + (av, inita) <- mkVal f2 a + return (av, av, inita) + ff (MemOp (Addr (Just x) _ _)) (RegOp x') | phisicalReg (SReg x) == phisicalReg (SReg x') = error "TODO" {-do + (av, inita) <- mkVal a + return (av, av, inita) -} + ff a_ b_ = do + (av, inita) <- mkVal f2 a_ + (bv, initb) <- mkVal f2 b_ + return (av, bv, inita . initb) + + (av, bv, initab) <- ff a b + let + code = foldMap Push sr <> Mov f1 rsp <> PushF <> Pop rax <> Push rax <> PopF + <> initab (initcf <> cc <> mova) <> mkRes + <> Mov rsp f1 {- <> traceReg "X" rdx' -} <> foldMap Pop (reverse sr) <> Ret + + sr = [rsi, rdi, rbx, rbp, r12, r13, r14, r15] + + cc = i + initcf = if cF then Stc else Clc + mova = case a of + RegOp (NormalReg 0x2) -> mempty + _ -> Mov rdx' a + mkRes = otest cc (if_ (if cF' then C else NC) (Xor rax rax) (Xor rax rax <> Mov rcx res <> Cmp rcx' rdx' <> j NZ (Inc rax))) + isShift = \case + Rol{} -> True + Ror{} -> True + Rcl{} -> True + Rcr{} -> True + Shl{} -> True + Shr{} -> True + Sar{} -> True + _ -> False + otest i x | isShift i = x + otest _ x = if_ (if oF' then O else NO) (Xor rax rax) x + + rcx' = resizeOperand rcx :: Operand s RW + rdx' = resizeOperand rdx :: Operand s RW + sa = size a + + ((cF', oF'), res) = case sa of + S8 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word8) + S16 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word16) + S32 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word32) + S64 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word64) + + msg = unlines [show i, "code: " ++ show cc, "input a: " ++ show av, "input b: " ++ show bv, "input flags: " ++ show cF, "output: " ++ show res, "output flags: " ++ show cF' ++ " " ++ show oF'] + + return $ traceShow i $ IT msg code + + case i of + Add a_ b_ -> fff i Add a_ b_ + Or a_ b_ -> fff i Or a_ b_ + Adc a_ b_ -> fff i Adc a_ b_ + Sbb a_ b_ -> fff i Sbb a_ b_ + And a_ b_ -> fff i And a_ b_ + Sub a_ b_ -> fff i Sub a_ b_ + Xor a_ b_ -> fff i Xor a_ b_ + Cmp a_ b_ -> fff i Cmp a_ b_ + Test a_ b_ -> fff i Test a_ b_ + Rol a_ b_ -> fff i Rol a_ b_ + Ror a_ b_ -> fff i Ror a_ b_ + Rcl a_ b_ -> fff i Rcl a_ b_ + Rcr a_ b_ -> fff i Rcr a_ b_ + Shl a_ b_ -> fff i Shl a_ b_ + Shr a_ b_ -> fff i Shr a_ b_ + Sar a_ b_ -> fff i Sar a_ b_ + Mov a_ b_ -> fff i Mov a_ b_ + + where + mkVal :: IsSize s => Operand S64 RW -> Operand s k -> Gen (Int64, Code -> Code) + mkVal _ o@(ImmOp 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 + 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 + v <- arbVal $ size o + (vi, setvi) <- case i of + NoIndex -> return (0, mempty) + IndexReg sc i -> do + x <- arbVal $ size i + return (scaleFactor sc * x, Mov (RegOp i) (ImmOp x)) + let + d' = (vi :: Int64) + case d of + NoDisp -> 0 + Disp v -> fromIntegral v + rx = resizeOperand $ RegOp x :: Operand S64 RW + return (v, ((leaData rx v <> Mov helper (imm d') <> Sub rx helper <> setvi) <>)) + mkVal helper o@(MemOp (Addr Nothing d (Just (sc, x)))) = do + v <- arbVal $ size o + let + d' = case d of + NoDisp -> 0 :: Int64 + Disp v -> fromIntegral v + rx = resizeOperand $ RegOp x :: Operand S64 RW + return (v, ((leaData rx v <> Mov helper (imm d') <> Sub rx helper) <>)) + + +propInstr (IT _ c) = compile c :: Bool + +tests num = quickCheckWith stdArgs { maxSuccess = num } propInstr + +----------------------------------------- + +return [] + +-- | Run all tests +runTests = do + $quickCheckAll + tests 2000 +
CodeGen/X86/Utils.hs view
@@ -1,61 +1,69 @@-{-# language BangPatterns #-}-{-# language NoMonomorphismRestriction #-}-{-# language ScopedTypeVariables #-}-{-# language DataKinds #-}-{-# language ForeignFunctionInterface #-}-module CodeGen.X86.Utils where--import Data.Char-import Data.Monoid-import Control.Monad-import Foreign-import System.Environment-import Debug.Trace--import CodeGen.X86.Asm---------------------------------------------------------------- derived constructs--(<.>) :: Code -> Code -> Code-a <.> b = a <> Label <> b--a <:> b = Scope $ a <.> b--infixr 5 <:>, <.>--j c x = J c <> Up x <:> mempty--x `j_back` c = mempty <:> Up x <> J c--if_ c a b = (J c <> Up (Up a <> Jmp) <:> mempty) <> Up b <:> mempty--leaData r d = (Lea r (ipBase :: Operand S8 RW) <> Up Jmp <:> mempty) <> Data (toBytes d) <:> mempty-------------------------------------------------------------------------------- utils---- helper to call a function-callFun :: Operand S64 RW -> FunPtr a -> Code-callFun r p = Mov r (imm $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) <> Call r--foreign import ccall "static stdio.h &printf" printf :: FunPtr a--mov' :: forall s s' r . IsSize s' => Operand s RW -> Operand s' r -> Code-mov' a b = Mov (resizeOperand a :: Operand s' RW) b--newtype CString = CString String--instance HasBytes CString where- toBytes (CString cs) = mconcat $ toBytes . (fromIntegral :: Int -> Word8) . fromEnum <$> (cs ++ "\0")--traceReg :: IsSize s => String -> Operand s RW -> Code-traceReg d r = - Push rsi <> Push rdi <> Push rax <> Push rcx <> Push rdx- <> mov' rsi r <> leaData rdi (CString $ show r ++ " = %" ++ s ++ d ++ "\n") <> callFun rax printf- <> Pop rdx <> Pop rcx <> Pop rax <> Pop rdi <> Pop rsi- where- s = case size r of- S8 -> "hh"- S16 -> "h"- S32 -> ""- S64 -> "l"-+{-# language CPP #-} +{-# language BangPatterns #-} +{-# language NoMonomorphismRestriction #-} +{-# language ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language ForeignFunctionInterface #-} +module CodeGen.X86.Utils where + +import Data.Char +import Data.Monoid +import Control.Monad +import Foreign +import System.Environment +import Debug.Trace + +import CodeGen.X86.Asm +import CodeGen.X86.CallConv + +-------------------------------------------------------------- derived constructs + +(<.>) :: Code -> Code -> Code +a <.> b = a <> Label <> b + +a <:> b = Scope $ a <.> b + +infixr 5 <:>, <.> + +j c x = J c <> Up x <:> mempty + +x `j_back` c = mempty <:> Up x <> J c + +if_ c a b = (J c <> Up (Up a <> Jmp) <:> mempty) <> Up b <:> mempty + +leaData r d = (Lea r (ipBase :: Operand S8 RW) <> Up Jmp <:> mempty) <> Data (toBytes d) <:> mempty + +------------------------------------------------------------------------------ + +foreign import ccall "static stdio.h &printf" printf :: FunPtr a + +------------------------------------------------------------------------------ +-- * utils + +mov' :: forall s s' r . IsSize s' => Operand s RW -> Operand s' r -> Code +mov' a b = Mov (resizeOperand a :: Operand s' RW) b + +newtype CString = CString String + +instance HasBytes CString where + toBytes (CString cs) = mconcat $ toBytes . (fromIntegral :: Int -> Word8) . fromEnum <$> (cs ++ "\0") + +-- | we should implement PUSHA and POPA later +all_regs_except_rsp :: [Operand S64 rw] +all_regs_except_rsp = [ rax, rcx, rdx, rbx, {- rsp, -} rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 ] + +push_all = mconcat [ Push r | r <- all_regs_except_rsp ] +pop_all = mconcat [ Pop r | r <- reverse all_regs_except_rsp ] + +traceReg :: IsSize s => String -> Operand s RW -> Code +traceReg d r = + push_all + <> mov' arg2 r <> leaData arg1 (CString $ show r ++ " = %" ++ s ++ d ++ "\n") <> Xor rax rax <> callFun r11 printf + <> pop_all + where + s = case size r of + S8 -> "hh" + S16 -> "h" + S32 -> "" + S64 -> "l" +
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2016, Péter Diviánszky--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Péter Diviánszky nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2016, Péter Diviánszky + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Péter Diviánszky nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,11 +1,13 @@-# x86-64--The primary goal of x86-64 is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions.--Features:--- The size of operands are statically checked. For example, exchanging `rax` with `eax` raises a compile time error rather than a code-generation time error. As a consequence, code generation is faster because the sizes are statically known.-- Immediate values are automatically converted to smaller size if possible.-- De Bruijn indices are used instead of named labels-- Quickcheck tests: You can quickcheck your x86 processor! Please report failures, there is a higher chance that the error is in this library rather than in your processor.-+# x86-64 + +The primary goal of x86-64 is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. + +Features: + +- The size of operands are statically checked. For example, exchanging `rax` with `eax` raises a compile time error rather than a code-generation time error. As a consequence, code generation is faster because the sizes are statically known. +- Immediate values are automatically converted to smaller size if possible. +- De Bruijn indices are used instead of named labels +- Quickcheck tests: You can quickcheck your x86 processor! Please report failures, there is a higher chance that the error is in this library rather than in your processor. + +The package is available on HackageDB: http://hackage.haskell.org/package/x86-64bit +
Test.hs view
@@ -1,4 +1,4 @@-import CodeGen.X86--main = runTests-+import CodeGen.X86 + +main = runTests +
x86-64bit.cabal view
@@ -1,68 +1,77 @@-name: x86-64bit-version: 0.1.1.1-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.-license: BSD3-license-file: LICENSE-author: Péter Diviánszky-maintainer: divipp@gmail.com-category: Code Generation-build-type: Simple-cabal-version: >=1.10-stability: Experimental-tested-with: GHC == 8.0.1-extra-source-files: README.md- CHANGELOG.md--source-repository head- type: git- location: https://github.com/divipp/x86-64--library- exposed-modules:- CodeGen.X86- CodeGen.X86.Examples- other-modules:- CodeGen.X86.Asm- CodeGen.X86.CodeGen- CodeGen.X86.FFI- CodeGen.X86.Utils- CodeGen.X86.Tests- other-extensions:- NoMonomorphismRestriction- LambdaCase- PatternSynonyms- ViewPatterns- TypeSynonymInstances- FlexibleInstances- TypeFamilies- GADTs- RankNTypes- RecordWildCards- DeriveFunctor- DeriveFoldable- DeriveTraversable- GeneralizedNewtypeDeriving- OverloadedStrings- TupleSections- ExistentialQuantification- ScopedTypeVariables-- build-depends:- base >=4.9 && <4.10,- monads-tf >=0.1 && <0.2,- vector >=0.11 && <0.12,- QuickCheck >=2.8 && <2.10-- default-language: Haskell2010--test-suite test-x86-64bit- type: exitcode-stdio-1.0- main-is: Test.hs- build-depends:- base >=4.9 && <4.10,- monads-tf >=0.1 && <0.2,- vector >=0.11 && <0.12,- QuickCheck >=2.8 && <2.10-+name: x86-64bit +version: 0.1.2 +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. +license: BSD3 +license-file: LICENSE +author: Péter Diviánszky +maintainer: divipp@gmail.com +category: Code Generation +build-type: Simple +cabal-version: >=1.10 +stability: Experimental +tested-with: GHC == 8.0.1 +extra-source-files: README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/divipp/x86-64 + +library + exposed-modules: + CodeGen.X86 + CodeGen.X86.Examples + other-modules: + CodeGen.X86.Asm + CodeGen.X86.CodeGen + CodeGen.X86.CallConv + CodeGen.X86.FFI + CodeGen.X86.Utils + CodeGen.X86.Tests + + other-extensions: + NoMonomorphismRestriction + LambdaCase + PatternSynonyms + ViewPatterns + TypeSynonymInstances + FlexibleInstances + TypeFamilies + GADTs + RankNTypes + RecordWildCards + DeriveFunctor + DeriveFoldable + DeriveTraversable + GeneralizedNewtypeDeriving + OverloadedStrings + TupleSections + ExistentialQuantification + ScopedTypeVariables + + build-depends: + base >=4.8 && <4.10, + monads-tf >=0.1 && <0.2, + vector >=0.11 && <0.12, + QuickCheck >=2.8 && <2.10 + + if os(windows) + build-depends: Win32 + + default-language: Haskell2010 + +test-suite test-x86-64bit + type: exitcode-stdio-1.0 + main-is: Test.hs + + build-depends: + base >=4.8 && <4.10, + monads-tf >=0.1 && <0.2, + vector >=0.11 && <0.12, + QuickCheck >=2.8 && <2.10 + + if os(windows) + build-depends: Win32 +