diff --git a/CodeGen/X86.hs b/CodeGen/X86.hs new file mode 100644 --- /dev/null +++ b/CodeGen/X86.hs @@ -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 + diff --git a/CodeGen/X86/Asm.hs b/CodeGen/X86/Asm.hs new file mode 100644 --- /dev/null +++ b/CodeGen/X86/Asm.hs @@ -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 + diff --git a/CodeGen/X86/CodeGen.hs b/CodeGen/X86/CodeGen.hs new file mode 100644 --- /dev/null +++ b/CodeGen/X86/CodeGen.hs @@ -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 + diff --git a/CodeGen/X86/FFI.hs b/CodeGen/X86/FFI.hs new file mode 100644 --- /dev/null +++ b/CodeGen/X86/FFI.hs @@ -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 + + diff --git a/CodeGen/X86/Tests.hs b/CodeGen/X86/Tests.hs new file mode 100644 --- /dev/null +++ b/CodeGen/X86/Tests.hs @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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) + diff --git a/x86-64bit.cabal b/x86-64bit.cabal new file mode 100644 --- /dev/null +++ b/x86-64bit.cabal @@ -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 +