x86-64bit (empty) → 0.1
raw patch · 10 files changed
+1657/−0 lines, 10 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, monads-tf, vector, x86-64bit
Files
- CodeGen/X86.hs +8/−0
- CodeGen/X86/Asm.hs +546/−0
- CodeGen/X86/CodeGen.hs +377/−0
- CodeGen/X86/FFI.hs +73/−0
- CodeGen/X86/Tests.hs +390/−0
- LICENSE +30/−0
- README.md +11/−0
- Setup.hs +2/−0
- examples/Main.hs +142/−0
- x86-64bit.cabal +78/−0
+ CodeGen/X86.hs view
@@ -0,0 +1,8 @@+module CodeGen.X86+ ( module X+ ) where++import CodeGen.X86.Asm as X+import CodeGen.X86.CodeGen as X+import CodeGen.X86.FFI as X+
+ CodeGen/X86/Asm.hs view
@@ -0,0 +1,546 @@+{-# 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 ""++------------------------------------------------------- bytes++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)++------------------------------------------------------- size++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++data Immediate a+ = Immediate a+ | LabelRelAddr !LabelIndex++type LabelIndex = Int++data Access = R | RW++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++-------------------------------------------------------------- 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+
+ CodeGen/X86/CodeGen.hs view
@@ -0,0 +1,377 @@+{-# 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.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+ j = fromIntegral $ (fromIntegral n - 1 :: Int64) .|. f s + 1+ in (Right <$> zip [n..] (replicate j 0x90), (n + j, 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++ notA8 dest@RegA = False+ notA8 dest = size dest == S8++ op2 :: IsSize s => Word8 -> Operand s RW -> Operand s k -> CodeBuilder+ op2 op dest@(notA8 -> True) (mkImmS S8 -> FJust (_, im))+ = regprefix'' dest 0x40 (reg8 op dest) im+ op2 op dest@RegA (mkImmNo64 (size dest) -> FJust (_, im))+ = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im+ op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im))+ = regprefix'' dest (0x40 .|. indicator (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+
+ CodeGen/X86/FFI.hs view
@@ -0,0 +1,73 @@+{-# 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++
+ CodeGen/X86/Tests.hs view
@@ -0,0 +1,390 @@+{-# 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 (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++------------------------------------------------------------------------------++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 = quickCheckWith stdArgs { maxSuccess = 2000 } propInstr++-----------------------------------------++return []+runTests = $quickCheckAll+
+ LICENSE view
@@ -0,0 +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.
+ README.md view
@@ -0,0 +1,11 @@+# 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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Main.hs view
@@ -0,0 +1,142 @@+{-# 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 #-}++import Data.Char+import Data.Monoid+import qualified Data.ByteString.Lazy as BS+import Control.Monad+import Foreign+import System.Environment+import Debug.Trace++import CodeGen.X86+import CodeGen.X86.Tests++------------------------------------------------------------------------------ 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"++pattern Show :: (Show a, Read a) => a -> String+pattern Show x <- (maybeRead -> Just x)+ where Show x = show x++maybeRead x = case reads x of+ ((y, cs): _) | all isSpace cs -> Just y+ _ -> Nothing++------------------------------------------------------------------------------ examples++main = do+ args <- getArgs+ case args of++ ["id", Show n] -> do+ print idCode+ print $ (compile idCode :: Word64 -> Word64) n++ ["fib", Show n] -> do+ print fibCode+ print $ (compile fibCode :: Word64 -> Word64) n++ ["fib", "traced", Show n] -> do+ print tracedFibCode+ print $ (compile tracedFibCode :: Word64 -> Word64) n++ -- for time comparison+ ["hsfib", Show n] -> print $ fib n++ ["callhs", Show n] -> do+ print callHsCode+ print $ (compile $ callHsCode :: Word64 -> Word64) n++ ["callc", name] -> do+ print $ callCCode name+ compile $ callCCode name++ ["memtest", Show v] -> do+ r <- memalign 8 8+ pokeByteOff r 0 (v :: Word64)+ print $ compile (Mov rax (MemOp $ base rdi) <> Ret) r == v++ ["tests"] -> do+ tests+ runTests+ return ()++ ["fib", "writebytes"]+ -> BS.writeFile "fib.bytes" $ BS.pack $ getBytes $ codeBytes fibCode++ _ -> putStrLn "wrong command line arguments"++idCode+ = Mov rax rdi+ <> Ret++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++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++callHsCode+ = callFun rdx (hsPtr fib)+ <> Ret++callCCode name+ = leaData rdi (CString "Hello %s!\n")+ <> leaData rsi (CString name)+ <> callFun rdx printf+ <> 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)+
+ x86-64bit.cabal view
@@ -0,0 +1,78 @@+name: x86-64bit+version: 0.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.+ .+ 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.+ .+ * 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 this library rather than in your processor.+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+extra-source-files: README.md+++source-repository head+ type: git+ location: https://github.com/divipp/x86-64++library+ exposed-modules:+ CodeGen.X86+ CodeGen.X86.Tests+ other-modules:+ CodeGen.X86.Asm+ CodeGen.X86.CodeGen+ CodeGen.X86.FFI+ other-extensions:+ NoMonomorphismRestriction+ LambdaCase+ PatternSynonyms+ ViewPatterns+ TypeSynonymInstances+ FlexibleInstances+ TypeFamilies+ GADTs+ RankNTypes+ RecordWildCards+ DeriveFunctor+ DeriveFoldable+ DeriveTraversable+ GeneralizedNewtypeDeriving+ OverloadedStrings+ TupleSections+ ExistentialQuantification+ ScopedTypeVariables++ build-depends:+ base >=4.7 && <4.10,+-- transformers >=0.5 && <0.6,+ monads-tf >=0.1 && <0.2,+ vector >=0.11 && <0.12,+ QuickCheck >=2.8 && <2.10++ default-language: Haskell2010++executable x86-64-examples+ hs-source-dirs: examples+ main-is: Main.hs+ default-language: Haskell2010++ build-depends:+ x86-64bit,+ base < 4.10,+ bytestring >=0.10 && <0.11+