diff --git a/CodeGen/X86.hs b/CodeGen/X86.hs --- a/CodeGen/X86.hs +++ b/CodeGen/X86.hs @@ -25,7 +25,7 @@ -- ** SSE registers , xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7 -- * Addresses - , Addr (..), BaseReg, IndexReg, Scale, Displacement, Address + , Addr (..), BaseReg, IndexReg (..), Scale, s1, s2, s4, s8, Displacement, Address , addr , addr8 , addr16 @@ -158,8 +158,6 @@ , printf , hsPtr , CString (..) - -- * Misc - , runTests ) where import Data.Monoid @@ -169,5 +167,3 @@ import CodeGen.X86.FFI import CodeGen.X86.CallConv import CodeGen.X86.Utils -import CodeGen.X86.Tests - diff --git a/CodeGen/X86/Asm.hs b/CodeGen/X86/Asm.hs --- a/CodeGen/X86/Asm.hs +++ b/CodeGen/X86/Asm.hs @@ -1,20 +1,21 @@ -{-# language LambdaCase #-} -{-# language BangPatterns #-} -{-# language ViewPatterns #-} -{-# language PatternGuards #-} -{-# language PatternSynonyms #-} +{-# language GeneralizedNewtypeDeriving #-} {-# language NoMonomorphismRestriction #-} {-# language ScopedTypeVariables #-} -{-# language RankNTypes #-} +{-# language StandaloneDeriving #-} +{-# language FlexibleInstances #-} +{-# language FlexibleContexts #-} +{-# language PatternSynonyms #-} +{-# language KindSignatures #-} +{-# language PatternGuards #-} +{-# language BangPatterns #-} +{-# language ViewPatterns #-} {-# language TypeFamilies #-} -{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language RankNTypes #-} {-# language DataKinds #-} -{-# language KindSignatures #-} {-# language PolyKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language StandaloneDeriving #-} +{-# language GADTs #-} +{-# language CPP #-} module CodeGen.X86.Asm where import Numeric @@ -35,8 +36,7 @@ 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 + where b = fromIntegral $ x `shiftR` (4 * n) .&. 0x0f showByte b = [showNibble 1 b, showNibble 0 b] @@ -50,30 +50,38 @@ class HasBytes a where toBytes :: a -> Bytes -instance HasBytes Word8 where toBytes w = [w] -instance HasBytes Word16 where toBytes w = [fromIntegral w, fromIntegral $ w `shiftR` 8] -instance HasBytes Word32 where toBytes w = [fromIntegral $ w `shiftR` n | n <- [0, 8.. 24]] -instance HasBytes Word64 where toBytes w = [fromIntegral $ w `shiftR` n | n <- [0, 8.. 56]] +instance HasBytes Word8 where + toBytes w = [w] +instance HasBytes Word16 where + toBytes w = [fromIntegral w, fromIntegral $ w `shiftR` 8] +instance HasBytes Word32 where + toBytes w = [ fromIntegral $ w `shiftR` n | n <- [0, 8 .. 24] ] +instance HasBytes Word64 where + toBytes w = [ 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) +instance HasBytes Int8 where + toBytes w = toBytes (fromIntegral w :: Word8) +instance HasBytes Int16 where + toBytes w = toBytes (fromIntegral w :: Word16) +instance HasBytes Int32 where + toBytes w = toBytes (fromIntegral w :: Word32) +instance HasBytes Int64 where + toBytes w = toBytes (fromIntegral w :: Word64) ------------------------------------------------------- sizes -- | The size of a register (in bits) data Size = S1 | S8 | S16 | S32 | S64 | S128 - deriving (Eq, Ord) + deriving (Eq, Ord) instance Show Size where - show = \case - S1 -> "bit" - S8 -> "byte" - S16 -> "word" - S32 -> "dword" - S64 -> "qword" - S128 -> "oword" + show = \case + S1 -> "bit" + S8 -> "byte" + S16 -> "word" + S32 -> "dword" + S64 -> "qword" + S128 -> "oword" mkSize 1 = S8 mkSize 2 = S16 @@ -82,11 +90,11 @@ mkSize 16 = S128 sizeLen = \case - S8 -> 1 - S16 -> 2 - S32 -> 4 - S64 -> 8 - S128 -> 16 + S8 -> 1 + S16 -> 2 + S32 -> 4 + S64 -> 8 + S128 -> 16 class HasSize a where size :: a -> Size @@ -101,24 +109,24 @@ -- | Singleton type for size data SSize (s :: Size) where - SSize1 :: SSize S1 - SSize8 :: SSize S8 - SSize16 :: SSize S16 - SSize32 :: SSize S32 - SSize64 :: SSize S64 - SSize128 :: SSize S128 + SSize1 :: SSize S1 + SSize8 :: SSize S8 + SSize16 :: SSize S16 + SSize32 :: SSize S32 + SSize64 :: SSize S64 + SSize128 :: SSize S128 instance HasSize (SSize s) where - size = \case - SSize1 -> S1 - SSize8 -> S8 - SSize16 -> S16 - SSize32 -> S32 - SSize64 -> S64 - SSize128 -> S128 + size = \case + SSize1 -> S1 + SSize8 -> S8 + SSize16 -> S16 + SSize32 -> S32 + SSize64 -> S64 + SSize128 -> S128 class IsSize (s :: Size) where - ssize :: SSize s + ssize :: SSize s instance IsSize S1 where ssize = SSize1 instance IsSize S8 where ssize = SSize8 @@ -128,21 +136,21 @@ instance IsSize S128 where ssize = SSize128 data EqT s s' where - Refl :: EqT s s + 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 + (SSize8 , SSize8) -> Just Refl + (SSize16, SSize16) -> Just Refl + (SSize32, SSize32) -> Just Refl + (SSize64, SSize64) -> Just Refl + _ -> Nothing ------------------------------------------------------- scale -- | The scaling of an index. (replace with Size?) newtype Scale = Scale Word8 - deriving (Eq) + deriving (Eq) s1 = Scale 0x0 s2 = Scale 0x1 @@ -150,25 +158,25 @@ s8 = Scale 0x3 toScale = \case - 1 -> s1 - 2 -> s2 - 4 -> s4 - 8 -> s8 + 1 -> s1 + 2 -> s2 + 4 -> s4 + 8 -> s8 scaleFactor (Scale i) = case i of - 0x0 -> 1 - 0x1 -> 2 - 0x2 -> 4 - 0x3 -> 8 + 0x0 -> 1 + 0x1 -> 2 + 0x2 -> 4 + 0x3 -> 8 ------------------------------------------------------- operand -- | An operand can be an immediate, a register, a memory address or RIP-relative (memory address relative to the instruction pointer) data Operand :: Access -> Size -> * where - ImmOp :: Immediate Int64 -> Operand R s - RegOp :: Reg s -> Operand rw s - MemOp :: IsSize s' => Addr s' -> Operand rw s - IPMemOp :: Immediate Int32 -> Operand rw s + ImmOp :: Immediate Int64 -> Operand R s + RegOp :: Reg s -> Operand rw s + MemOp :: IsSize s' => Addr s' -> Operand rw s + IPMemOp :: Immediate Int32 -> Operand rw s addr :: IsSize s => Address s -> Operand rw s' addr = MemOp . makeAddr @@ -190,25 +198,25 @@ addr64 = addr data Immediate a - = Immediate a - | LabelRelValue Size{-size hint-} Label + = Immediate a + | LabelRelValue Size{-size hint-} Label -- Type of labels newtype Label = Label {unLabel :: Int} instance Show Label where - show (Label i) = ".l" ++ show i + show (Label i) = ".l" ++ show i -- | Operand access modes data Access - = R -- ^ readable operand - | RW -- ^ readable and writeable operand + = R -- ^ readable operand + | RW -- ^ readable and writeable operand -- | A register. data Reg :: Size -> * where - NormalReg :: Word8 -> Reg s -- \"normal\" registers are for example @AL@, @BX@, @ECX@ or @RSI@ - HighReg :: Word8 -> Reg S8 -- \"high\" registers are @AH@, @BH@, @CH@ etc - XMM :: Word8 -> Reg S128 -- XMM registers + NormalReg :: Word8 -> Reg s -- \"normal\" registers are for example @AL@, @BX@, @ECX@ or @RSI@ + HighReg :: Word8 -> Reg S8 -- \"high\" registers are @AH@, @BH@, @CH@ etc + XMM :: Word8 -> Reg S128 -- XMM registers deriving instance Eq (Reg s) deriving instance Ord (Reg s) @@ -217,15 +225,17 @@ -- For example in @[eax+4*ecx+20]@ the base register is @eax@, the displacement is @20@ and the -- index is @4*ecx@. data Addr s = Addr - { baseReg :: BaseReg s - , displacement :: Displacement - , indexReg :: IndexReg s - } - deriving (Eq) + { baseReg :: BaseReg s + , displacement :: Displacement + , indexReg :: IndexReg s + } + deriving (Eq) -type BaseReg s = Maybe (Reg s) -data IndexReg s = NoIndex | IndexReg Scale (Reg s) - deriving (Eq) +type BaseReg s = Maybe (Reg s) + +data IndexReg s = NoIndex | IndexReg Scale (Reg s) + deriving (Eq) + type Displacement = Maybe Int32 pattern NoDisp = Nothing @@ -242,89 +252,106 @@ ipRel8 = ipRel instance IsSize s => Show (Reg s) where - show = \case - XMM i -> "xmm" ++ show i - 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) + show (XMM i) = "xmm" ++ show i + show (HighReg i) = + (["ah", " ch", "dh", "bh"] ++ repeat (error ("show @Reg"))) + !! fromIntegral i + show r@(NormalReg i) = + (!! fromIntegral i) . (++ repeat (error ("show @Reg"))) $ 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"] + 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 = " - " + 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 a s) where - show = \case - ImmOp w -> show w - RegOp r -> show r - r@(MemOp a) -> show (size r) ++ " [" ++ show a ++ "]" - r@(IPMemOp x) -> show (size r) ++ " [" ++ "rel " ++ show x ++ "]" - where - showp x | x < 0 = " - " ++ show (-x) - showp x = " + " ++ show x + show = \case + ImmOp w -> show w + RegOp r -> show r + r@(MemOp a) -> show (size r) ++ " [" ++ show a ++ "]" + r@(IPMemOp x) -> show (size r) ++ " [" ++ "rel " ++ show x ++ "]" + where + showp x | x < 0 = " - " ++ show (-x) + showp x = " + " ++ show x instance Show a => Show (Immediate a) where - show (Immediate x) = show x - show (LabelRelValue s x) = show x + show (Immediate x) = show x + show (LabelRelValue s x) = show x instance IsSize s => HasSize (Operand a s) where - size _ = size (ssize :: SSize s) + size _ = size (ssize :: SSize s) instance IsSize s => HasSize (Addr s) where - size _ = size (ssize :: SSize s) + size _ = size (ssize :: SSize s) instance IsSize s => HasSize (Address s) where - size _ = size (ssize :: SSize s) + size _ = size (ssize :: SSize s) instance IsSize s => HasSize (BaseReg s) where - size _ = size (ssize :: SSize s) + size _ = size (ssize :: SSize s) instance IsSize s => HasSize (Reg s) where - size _ = size (ssize :: SSize s) + size _ = size (ssize :: SSize s) instance IsSize s => HasSize (IndexReg s) where - size _ = size (ssize :: SSize s) + size _ = size (ssize :: SSize s) instance (rw ~ R) => Num (Operand rw s) where - negate (ImmOp (Immediate x)) = ImmOp $ Immediate $ negate x - fromInteger (Integral x) = ImmOp $ Immediate x - fromInteger z = error $ show z ++ " does not fit into " -- ++ show s - (+) = error "(+) @Operand" - (-) = error "(-) @Operand" - (*) = error "(*) @Operand" - abs = error "abs @Operand" - signum = error "signum @Operand" + negate (ImmOp (Immediate x)) = ImmOp $ Immediate $ negate x + fromInteger (Integral x) = ImmOp $ Immediate x + fromInteger z = error $ show z ++ " does not fit into " -- ++ show s + (+) = error "(+) @Operand" + (-) = error "(-) @Operand" + (*) = error "(*) @Operand" + abs = error "abs @Operand" + signum = error "signum @Operand" +#if MIN_VERSION_base(4,11,0) +instance Semigroup (Addr s) where + Addr a b c <> Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (c <> c') + +instance Semigroup (IndexReg s) where + i <> NoIndex = i + NoIndex <> i = i +#endif + instance Monoid (Addr s) where - mempty = Addr (getFirst mempty) (getFirst mempty) mempty - Addr a b c `mappend` Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (c <> c') + mempty = Addr (getFirst mempty) (getFirst mempty) mempty +#if !MIN_VERSION_base(4,11,0) + Addr a b c `mappend` Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (c <> c') +#endif + instance Monoid (IndexReg s) where - mempty = NoIndex - i `mappend` NoIndex = i - NoIndex `mappend` i = i + mempty = NoIndex +#if !MIN_VERSION_base(4,11,0) + i `mappend` NoIndex = i + NoIndex `mappend` i = i +#endif + base :: Reg s -> Addr s base x = Addr (Just x) NoDisp NoIndex @@ -341,31 +368,34 @@ disp :: (Bits a, Integral a) => a -> Addr s disp (Integral x) - | x == 0 = mempty - | otherwise = Addr Nothing (Disp x) NoIndex + | x == 0 = mempty + | otherwise = Addr Nothing (Disp x) NoIndex data Address :: Size -> * where - Address :: [(Int, Reg s)] -> Int -> Address s + Address :: [(Int, Reg s)] -> Int -> Address s scaleAddress :: (Int -> Int) -> Address s -> Address s scaleAddress f (Address rs d) = Address (first f <$> rs) $ f d instance Num (Address s) where - fromInteger d = Address [] $ fromInteger d - negate = scaleAddress negate - Address [] t * a = scaleAddress (t*) a - a * Address [] t = scaleAddress (t*) a - Address rs d + Address rs' d' = Address (f rs rs') (d + d') where - f [] rs = rs - f rs [] = rs - f (p@(t, r): rs) (p'@(t', r'): rs') = case compare r r' of - LT -> p: f rs (p': rs') - GT -> p': f (p: rs) rs' - EQ | t + t' == 0 -> f rs rs' - | otherwise -> (t + t', r): f rs rs' - abs = error "abs @Address" - signum = error "signum @Address" + fromInteger d = Address [] $ fromInteger d + negate = scaleAddress negate + Address [] t * a = scaleAddress (t *) a + a * Address [] t = scaleAddress (t *) a + + Address rs d + Address rs' d' = Address (f rs rs') (d + d') where + f [] rs = rs + f rs [] = rs + f (p@(t, r) : rs) (p'@(t', r') : rs') = case compare r r' of + LT -> p : f rs (p' : rs') + GT -> p' : f (p : rs) rs' + EQ | t + t' == 0 -> f rs rs' + | otherwise -> (t + t', r) : f rs rs' + + abs = error "abs @Address" + signum = error "signum @Address" + makeAddr :: Address s -> Addr s makeAddr (Address [(1, r)] d) = base r <> disp d makeAddr (Address [(t, r)] d) = index' t r <> disp d @@ -374,16 +404,16 @@ makeAddr (Address [(t, r'), (1, r)] d) = base r <> index' t r' <> disp d class FromReg c where - fromReg :: Reg s -> c s + fromReg :: Reg s -> c s instance FromReg Reg where - fromReg = id + fromReg = id instance FromReg (Operand r) where - fromReg = RegOp + fromReg = RegOp instance FromReg Address where - fromReg r = Address [(1, r)] 0 + fromReg r = Address [(1, r)] 0 reg = fromReg . NormalReg @@ -526,23 +556,23 @@ pattern NLE = Condition 0xf instance Show Condition where - show (Condition x) = case x of - 0x0 -> "o" - 0x1 -> "no" - 0x2 -> "c" - 0x3 -> "nc" - 0x4 -> "z" - 0x5 -> "nz" - 0x6 -> "be" - 0x7 -> "nbe" - 0x8 -> "s" - 0x9 -> "ns" - 0xa -> "p" - 0xb -> "np" - 0xc -> "l" - 0xd -> "nl" - 0xe -> "le" - 0xf -> "nle" + 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" pattern N cc <- (notCond -> cc) where N = notCond @@ -552,42 +582,43 @@ -------------------------------------------------------------- asm code lines +{- HLINT ignore -} data CodeLine where - Ret_, Nop_, PushF_, PopF_, Cmc_, Clc_, Stc_, Cli_, Sti_, Cld_, Std_ :: CodeLine + Ret_, Nop_, PushF_, PopF_, Cmc_, Clc_, Stc_, Cli_, Sti_, Cld_, Std_ :: CodeLine - Inc_, Dec_, Not_, Neg_, Bswap :: IsSize s => Operand RW s -> CodeLine - Add_, Or_, Adc_, Sbb_, And_, Sub_, Xor_, Cmp_, Test_, Mov_, Bsf, Bsr :: IsSize s => Operand RW s -> Operand r s -> CodeLine - Rol_, Ror_, Rcl_, Rcr_, Shl_, Shr_, Sar_ :: IsSize s => Operand RW s -> Operand r S8 -> CodeLine - Bt :: IsSize s => Operand r s -> Operand RW s -> CodeLine + Inc_, Dec_, Not_, Neg_, Bswap :: IsSize s => Operand RW s -> CodeLine + Add_, Or_, Adc_, Sbb_, And_, Sub_, Xor_, Cmp_, Test_, Mov_, Bsf, Bsr :: IsSize s => Operand RW s -> Operand r s -> CodeLine + Rol_, Ror_, Rcl_, Rcr_, Shl_, Shr_, Sar_ :: IsSize s => Operand RW s -> Operand r S8 -> CodeLine + Bt :: IsSize s => Operand r s -> Operand RW s -> CodeLine - Movdqa_, Paddb_, Paddw_, Paddd_, Paddq_, Psubb_, Psubw_, Psubd_, Psubq_, Pxor_ :: Operand RW S128 -> Operand r S128 -> CodeLine - Psllw_, Pslld_, Psllq_, Pslldq_, Psrlw_, Psrld_, Psrlq_, Psrldq_, Psraw_, Psrad_ :: Operand RW S128 -> Operand r S8 -> CodeLine - Movd_, Movq_ :: (IsSize s, IsSize s') => Operand RW s -> Operand r s' -> CodeLine + Movdqa_, Paddb_, Paddw_, Paddd_, Paddq_, Psubb_, Psubw_, Psubd_, Psubq_, Pxor_ :: Operand RW S128 -> Operand r S128 -> CodeLine + Psllw_, Pslld_, Psllq_, Pslldq_, Psrlw_, Psrld_, Psrlq_, Psrldq_, Psraw_, Psrad_ :: Operand RW S128 -> Operand r S8 -> CodeLine + Movd_, Movq_ :: (IsSize s, IsSize s') => Operand RW s -> Operand r s' -> CodeLine - Cmov_ :: IsSize s => Condition -> Operand RW s -> Operand RW s -> CodeLine - Xchg_ :: IsSize s => Operand RW s -> Operand RW s -> CodeLine - Lea_ :: (IsSize s, IsSize s') => Operand RW s -> Operand RW s' -> CodeLine + Cmov_ :: IsSize s => Condition -> Operand RW s -> Operand RW s -> CodeLine + Xchg_ :: IsSize s => Operand RW s -> Operand RW s -> CodeLine + Lea_ :: (IsSize s, IsSize s') => Operand RW s -> Operand RW s' -> CodeLine - Pop_ :: Operand RW S64 -> CodeLine - Push_ :: Operand r S64 -> CodeLine + Pop_ :: Operand RW S64 -> CodeLine + Push_ :: Operand r S64 -> CodeLine - Call_ :: Operand r S64 -> CodeLine - Jmpq_ :: Operand r S64 -> CodeLine + Call_ :: Operand r S64 -> CodeLine + Jmpq_ :: Operand r S64 -> CodeLine - J_ :: Condition -> Maybe Size -> Label -> CodeLine - Jmp_ :: Maybe Size -> Label -> CodeLine + J_ :: Condition -> Maybe Size -> Label -> CodeLine + Jmp_ :: Maybe Size -> Label -> CodeLine - Label_ :: CodeLine + Label_ :: CodeLine - Data_ :: Bytes -> CodeLine - Align_ :: Int -> CodeLine + Data_ :: Bytes -> CodeLine + Align_ :: Int -> CodeLine ------------------------- show code lines newLabel = do - i <- get - put $ i + 1 - return $ Label i + i <- get + put $ i + 1 + return $ Label i codeLine x = tell [x] @@ -598,80 +629,80 @@ showCodeLine :: CodeLine -> StateT Int (Writer [String]) () showCodeLine = \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 - Bsf op1 op2 -> showOp2 "bsf" op1 op2 - Bsr op1 op2 -> showOp2 "bsr" op1 op2 - Bt op1 op2 -> showOp2 "bt" op1 op2 - Rol_ op1 op2 -> showOp2 "rol" op1 op2 - Ror_ op1 op2 -> showOp2 "ror" op1 op2 - Rcl_ op1 op2 -> showOp2 "rcl" op1 op2 - Rcr_ op1 op2 -> showOp2 "rcr" op1 op2 - Shl_ op1 op2 -> showOp2 "shl" op1 op2 - Shr_ op1 op2 -> showOp2 "shr" op1 op2 - Sar_ op1 op2 -> showOp2 "sar" op1 op2 - Mov_ op1 op2 -> showOp2 "mov" op1 op2 - Cmov_ cc op1 op2 -> showOp2 ("cmov" ++ show cc) op1 op2 - Lea_ op1 op2 -> showOp2 "lea" op1 op2 - Xchg_ op1 op2 -> showOp2 "xchg" op1 op2 - Movd_ op1 op2 -> showOp2 "movd" op1 op2 - Movq_ op1 op2 -> showOp2 "movq" op1 op2 - Movdqa_ op1 op2 -> showOp2 "movdqa" op1 op2 - Paddb_ op1 op2 -> showOp2 "paddb" op1 op2 - Paddw_ op1 op2 -> showOp2 "paddw" op1 op2 - Paddd_ op1 op2 -> showOp2 "paddd" op1 op2 - Paddq_ op1 op2 -> showOp2 "paddq" op1 op2 - Psubb_ op1 op2 -> showOp2 "psubb" op1 op2 - Psubw_ op1 op2 -> showOp2 "psubw" op1 op2 - Psubd_ op1 op2 -> showOp2 "psubd" op1 op2 - Psubq_ op1 op2 -> showOp2 "psubq" op1 op2 - Pxor_ op1 op2 -> showOp2 "pxor" op1 op2 - Psllw_ op1 op2 -> showOp2 "psllw" op1 op2 - Pslld_ op1 op2 -> showOp2 "pslld" op1 op2 - Psllq_ op1 op2 -> showOp2 "psllq" op1 op2 - Pslldq_ op1 op2 -> showOp2 "pslldq" op1 op2 - Psrlw_ op1 op2 -> showOp2 "psrlw" op1 op2 - Psrld_ op1 op2 -> showOp2 "psrld" op1 op2 - Psrlq_ op1 op2 -> showOp2 "psrlq" op1 op2 - Psrldq_ op1 op2 -> showOp2 "psrldq" op1 op2 - Psraw_ op1 op2 -> showOp2 "psraw" op1 op2 - Psrad_ op1 op2 -> showOp2 "psrad" op1 op2 - Inc_ op -> showOp1 "inc" op - Dec_ op -> showOp1 "dec" op - Not_ op -> showOp1 "not" op - Neg_ op -> showOp1 "neg" op - Bswap op -> showOp1 "bswap" op - Pop_ op -> showOp1 "pop" op - Push_ op -> showOp1 "push" op - Call_ op -> showOp1 "call" op - Jmpq_ op -> showOp1 "jmp" op - Ret_ -> showOp0 "ret" - Nop_ -> showOp0 "nop" - PushF_ -> showOp0 "pushf" - PopF_ -> showOp0 "popf" - Cmc_ -> showOp0 "cmc" - Clc_ -> showOp0 "clc" - Stc_ -> showOp0 "stc" - Cli_ -> showOp0 "cli" - Sti_ -> showOp0 "sti" - Cld_ -> showOp0 "cld" - Std_ -> showOp0 "std" + 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 + Bsf op1 op2 -> showOp2 "bsf" op1 op2 + Bsr op1 op2 -> showOp2 "bsr" op1 op2 + Bt op1 op2 -> showOp2 "bt" op1 op2 + Rol_ op1 op2 -> showOp2 "rol" op1 op2 + Ror_ op1 op2 -> showOp2 "ror" op1 op2 + Rcl_ op1 op2 -> showOp2 "rcl" op1 op2 + Rcr_ op1 op2 -> showOp2 "rcr" op1 op2 + Shl_ op1 op2 -> showOp2 "shl" op1 op2 + Shr_ op1 op2 -> showOp2 "shr" op1 op2 + Sar_ op1 op2 -> showOp2 "sar" op1 op2 + Mov_ op1 op2 -> showOp2 "mov" op1 op2 + Cmov_ cc op1 op2 -> showOp2 ("cmov" ++ show cc) op1 op2 + Lea_ op1 op2 -> showOp2 "lea" op1 op2 + Xchg_ op1 op2 -> showOp2 "xchg" op1 op2 + Movd_ op1 op2 -> showOp2 "movd" op1 op2 + Movq_ op1 op2 -> showOp2 "movq" op1 op2 + Movdqa_ op1 op2 -> showOp2 "movdqa" op1 op2 + Paddb_ op1 op2 -> showOp2 "paddb" op1 op2 + Paddw_ op1 op2 -> showOp2 "paddw" op1 op2 + Paddd_ op1 op2 -> showOp2 "paddd" op1 op2 + Paddq_ op1 op2 -> showOp2 "paddq" op1 op2 + Psubb_ op1 op2 -> showOp2 "psubb" op1 op2 + Psubw_ op1 op2 -> showOp2 "psubw" op1 op2 + Psubd_ op1 op2 -> showOp2 "psubd" op1 op2 + Psubq_ op1 op2 -> showOp2 "psubq" op1 op2 + Pxor_ op1 op2 -> showOp2 "pxor" op1 op2 + Psllw_ op1 op2 -> showOp2 "psllw" op1 op2 + Pslld_ op1 op2 -> showOp2 "pslld" op1 op2 + Psllq_ op1 op2 -> showOp2 "psllq" op1 op2 + Pslldq_ op1 op2 -> showOp2 "pslldq" op1 op2 + Psrlw_ op1 op2 -> showOp2 "psrlw" op1 op2 + Psrld_ op1 op2 -> showOp2 "psrld" op1 op2 + Psrlq_ op1 op2 -> showOp2 "psrlq" op1 op2 + Psrldq_ op1 op2 -> showOp2 "psrldq" op1 op2 + Psraw_ op1 op2 -> showOp2 "psraw" op1 op2 + Psrad_ op1 op2 -> showOp2 "psrad" op1 op2 + Inc_ op -> showOp1 "inc" op + Dec_ op -> showOp1 "dec" op + Not_ op -> showOp1 "not" op + Neg_ op -> showOp1 "neg" op + Bswap op -> showOp1 "bswap" op + Pop_ op -> showOp1 "pop" op + Push_ op -> showOp1 "push" op + Call_ op -> showOp1 "call" op + Jmpq_ op -> showOp1 "jmp" op + Ret_ -> showOp0 "ret" + Nop_ -> showOp0 "nop" + PushF_ -> showOp0 "pushf" + PopF_ -> showOp0 "popf" + Cmc_ -> showOp0 "cmc" + Clc_ -> showOp0 "clc" + Stc_ -> showOp0 "stc" + Cli_ -> showOp0 "cli" + Sti_ -> showOp0 "sti" + Cld_ -> showOp0 "cld" + Std_ -> showOp0 "std" - Align_ s -> codeLine $ ".align " ++ show s - Data_ x - | 2 * length (filter isPrint x) > length x -> showOp "db" $ show (toEnum . fromIntegral <$> x :: String) - | otherwise -> showOp "db" $ intercalate ", " (show <$> x) - where - isPrint c = c >= 32 && c <= 126 + Align_ s -> codeLine $ ".align " ++ show s + Data_ x + | 2 * length (filter isPrint x) > length x -> showOp "db" $ show (toEnum . fromIntegral <$> x :: String) + | otherwise -> showOp "db" $ intercalate ", " (show <$> x) + where + isPrint c = c >= 32 && c <= 126 - J_ cc s l -> showOp ("j" ++ show cc) $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l - Jmp_ s l -> showOp "jmp" $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l - Label_ -> newLabel >>= codeLine . show + J_ cc s l -> showOp ("j" ++ show cc) $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l + Jmp_ s l -> showOp "jmp" $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l + Label_ -> newLabel >>= codeLine . show diff --git a/CodeGen/X86/CallConv.hs b/CodeGen/X86/CallConv.hs --- a/CodeGen/X86/CallConv.hs +++ b/CodeGen/X86/CallConv.hs @@ -2,7 +2,6 @@ {-# language NoMonomorphismRestriction #-} {-# language CPP #-} -{-# language BangPatterns #-} {-# language DataKinds #-} module CodeGen.X86.CallConv where @@ -19,33 +18,33 @@ -- On Win64 the caller have to reserve 32 byte "shadow space" on the stack (and clean up after) callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p = do - sub rsp 32 - mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) - call r - add rsp 32 + sub rsp 32 + mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) + call r + add rsp 32 #elif defined (darwin_HOST_OS) -- OSX requires 16 byte alignment of the stack... callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p = do - push r15 -- we will use r15 (non-volatile) to store old rsp - mov r15 15 -- 0xf - not_ r15 -- 0xffff ... fff0 - and_ r15 rsp -- align rsp into r15 - xchg r15 rsp -- new rsp = aligned, r15 = old rsp - mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) - call r - mov rsp r15 -- restore rsp - pop r15 -- restore r15 + push r15 -- we will use r15 (non-volatile) to store old rsp + mov r15 15 -- 0xf + not_ r15 -- 0xffff ... fff0 + and_ r15 rsp -- align rsp into r15 + xchg r15 rsp -- new rsp = aligned, r15 = old rsp + mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) + call r + mov rsp r15 -- restore rsp + pop r15 -- restore r15 #else -- helper to call a function callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p = do - mov r $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p - call r + mov r $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p + call r #endif @@ -91,16 +90,16 @@ result = rax prologue = do - push rbp - push rbx - push rdi - push rsi + push rbp + push rbx + push rdi + push rsi epilogue = do - pop rsi - pop rdi - pop rbx - pop rbp + pop rsi + pop rdi + pop rbx + pop rbp #else @@ -117,12 +116,12 @@ result = rax prologue = do - push rbp - push rbx + push rbp + push rbx epilogue = do - pop rbx - pop rbp + pop rbx + pop rbp #endif diff --git a/CodeGen/X86/CodeGen.hs b/CodeGen/X86/CodeGen.hs --- a/CodeGen/X86/CodeGen.hs +++ b/CodeGen/X86/CodeGen.hs @@ -1,20 +1,18 @@ -{-# language LambdaCase #-} -{-# language BangPatterns #-} -{-# language ViewPatterns #-} -{-# language PatternGuards #-} -{-# language PatternSynonyms #-} +{-# language GeneralizedNewtypeDeriving #-} {-# language NoMonomorphismRestriction #-} {-# language ScopedTypeVariables #-} -{-# language RankNTypes #-} +{-# language FlexibleInstances #-} +{-# language FlexibleContexts #-} +{-# language PatternSynonyms #-} +{-# language ViewPatterns #-} {-# language TypeFamilies #-} -{-# language GADTs #-} +{-# language RecursiveDo #-} +{-# language LambdaCase #-} +{-# language RankNTypes #-} {-# language DataKinds #-} -{-# language KindSignatures #-} {-# language PolyKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language RecursiveDo #-} +{-# language GADTs #-} +{-# language CPP #-} module CodeGen.X86.CodeGen where import Numeric @@ -60,7 +58,7 @@ ------------------------------------------------------- register packed with its size data SReg where - SReg :: IsSize s => Reg s -> SReg + SReg :: IsSize s => Reg s -> SReg phisicalReg :: SReg -> Reg S64 phisicalReg (SReg (HighReg x)) = NormalReg x @@ -71,9 +69,9 @@ regs :: IsSize s => Operand r s -> [SReg] regs = \case - MemOp (Addr r _ i) -> foldMap (pure . SReg) r ++ case i of NoIndex -> []; IndexReg _ x -> [SReg x] - RegOp r -> [SReg r] - _ -> mempty + MemOp (Addr r _ i) -> foldMap (pure . SReg) r ++ case i of NoIndex -> []; IndexReg _ x -> [SReg x] + RegOp r -> [SReg r] + _ -> mempty isRex (SReg x@(NormalReg r)) = r .&. 0x8 /= 0 || size x == S8 && r `shiftR` 2 == 1 isRex _ = False @@ -90,120 +88,131 @@ type CodeBuilderTardis = Tardis (Int, [Int]) (Int, [Int], LabelState) data CodeBuilder = CodeBuilder - { minLen, maxLen :: Int - , getCodeBuilder :: WriterT CodeBuilderRes CodeBuilderTardis () - } + { minLen, maxLen :: Int + , getCodeBuilder :: WriterT CodeBuilderRes CodeBuilderTardis () + } codeBuilderLength (CodeBuilder a b _) | a == b = a type LabelState = [[(Size, Int, Int)]] +#if MIN_VERSION_base(4,11,0) +instance Semigroup CodeBuilder where + CodeBuilder mi ma a <> CodeBuilder mi' ma' b = CodeBuilder (min mi mi') (max ma ma') $ a >> b +#endif + instance Monoid CodeBuilder where - mempty = CodeBuilder 0 0 $ return () - CodeBuilder mi ma a `mappend` CodeBuilder mi' ma' b = CodeBuilder (min mi mi') (max ma ma') $ a >> b + mempty = CodeBuilder 0 0 $ return () +#if !MIN_VERSION_base(4,11,0) + CodeBuilder mi ma a `mappend` CodeBuilder mi' ma' b = CodeBuilder (min mi mi') (max ma ma') $ a >> b +#endif codeBytes :: [Word8] -> CodeBuilder codeBytes bs = CodeBuilder n n $ do - c <- lift $ mdo - (c, ls, ps) <- getPast - sendFuture (c + n, ls, ps) - sendPast (ma + n, mls) - ~(ma, mls) <- getFuture - return c - tell $ Right <$> zip [c..] bs + c <- lift $ mdo + (c, ls, ps) <- getPast + sendFuture (c + n, ls, ps) + sendPast (ma + n, mls) + ~(ma, mls) <- getFuture + return c + tell $ Right <$> zip [c..] bs where - n = length bs + n = length bs codeByte :: Word8 -> CodeBuilder codeByte = codeBytes . (:[]) mkRef :: Size -> Int -> Label -> CodeBuilder mkRef s@(sizeLen -> sn) offset (Label l_) = CodeBuilder sn sn $ do - bs <- lift $ mdo - (n, ls, ps) <- getPast - sendFuture (n + sn, ls, ps') - sendPast (ma + sn, mls) - ~(ma, mls) <- getFuture - let i = ls !! (- l - 1) - vx = i - n - offset - z = case s of - S8 -> case vx of - Integral j -> toBytes (j :: Int8) - _ -> error $ show vx ++ " does not fit into an Int8" - S32 -> case vx of - Integral j -> toBytes (j :: Int32) - _ -> error $ show vx ++ " does not fit into an Int32" - ~(bs, ps') - | l < 0 = (z, ps) - | otherwise = ([], ins l (s, n, - n - offset) ps) - l = l_ - length ls - return $ zip [n..] bs - tell $ Right <$> bs + bs <- lift $ mdo + (n, ls, ps) <- getPast + sendFuture (n + sn, ls, ps') + sendPast (ma + sn, mls) + ~(ma, mls) <- getFuture + let i = ls !! (- l - 1) + vx = i - n - offset + z = case s of + S8 -> case vx of + Integral j -> toBytes (j :: Int8) + _ -> error $ show vx ++ " does not fit into an Int8" + S32 -> case vx of + Integral j -> toBytes (j :: Int32) + _ -> error $ show vx ++ " does not fit into an Int32" + ~(bs, ps') + | l < 0 = (z, ps) + | otherwise = ([], ins l (s, n, - n - offset) ps) + l = l_ - length ls + return $ zip [n..] bs + tell $ Right <$> bs ins :: Int -> a -> [[a]] -> [[a]] -ins 0 a [] = [a]: [] +ins 0 a [] = [[a]] ins 0 a (as:ass) = (a:as): ass ins n a [] = []: ins (n-1) a [] ins n a (as: ass) = as: ins (n-1) a ass mkAutoRef :: [(Size, Bytes)] -> Label -> CodeBuilder mkAutoRef ss (Label l_) = CodeBuilder (minimum sizes) (maximum sizes) $ do - bs <- lift $ mdo - (n, ls, ps) <- getPast - sendFuture (n + sn, ls, ps') - sendPast (ma + maximum sizes, mls) - ~(ma, mls) <- getFuture - let i = ls !! (- l - 1) - vx = i - n - z = g ss - g [] = error $ show vx ++ " does not fit into auto size" - g ((s, c): ss) = case (s, vx - length c - sizeLen s) of - (S8, Integral j) -> c <> toBytes (j :: Int8) - (S32, Integral j) -> c <> toBytes (j :: Int32) - _ -> g ss - ~(sn, bs, ps') - | l < 0 = (length z, z, ps) - | otherwise = (nz, z', ins l (s, n + length z', - n - nz) ps) - nz = length z' + sizeLen s - ma' = mls !! l - vx' = ma - ma' - (z', s) = g' ss - g' [] = error $ show vx' ++ " does not fit into auto size" - g' ((s, c): ss) = case (s, vx') of - (S8, Integral (j :: Int8)) -> (c, s) - (S32, Integral (j :: Int32)) -> (c, s) - _ -> g' ss - l = l_ - length ls - return $ zip [n..] bs - tell $ Right <$> bs + bs <- lift $ mdo + (n, ls, ps) <- getPast + sendFuture (n + sn, ls, ps') + sendPast (ma + maximum sizes, mls) + ~(ma, mls) <- getFuture + let i = ls !! (- l - 1) + vx = i - n + z = g ss + + g [] = error $ show vx ++ " does not fit into auto size" + g ((s, c): ss) = case (s, vx - length c - sizeLen s) of + (S8, Integral j) -> c <> toBytes (j :: Int8) + (S32, Integral j) -> c <> toBytes (j :: Int32) + _ -> g ss + + ~(sn, bs, ps') + | l < 0 = (length z, z, ps) + | otherwise = (nz, z', ins l (s, n + length z', - n - nz) ps) + + nz = length z' + sizeLen s + ma' = mls !! l + vx' = ma - ma' + (z', s) = g' ss + + g' [] = error $ show vx' ++ " does not fit into auto size" + g' ((s, c): ss) = case (s, vx') of + (S8, Integral (j :: Int8)) -> (c, s) + (S32, Integral (j :: Int32)) -> (c, s) + _ -> g' ss + + l = l_ - length ls + return $ zip [n..] bs + tell $ Right <$> bs where - sizes = map (\(s, c) -> sizeLen s + length c) ss + sizes = map (\(s, c) -> sizeLen s + length c) ss -- prebuild code preBuild :: Code -> Code preBuild c = CodeM $ tell $ Prebuilt (compactCode (buildCode lc)) lc where - lc = withLabels c + lc = withLabels c ------------------------------------------------------- code to code builder instance Show Code where - show = show . withLabels + show = show . withLabels instance Show LCode where - show c = unlines $ zipWith3 showLine is (takes (zipWith (-) (tail is ++ [s]) is) bs) ss - where - ss = snd . runWriter . flip evalStateT 0 . showCode $ c - (x, s) = buildCode c - bs = V.toList $ compactCode (x, s) - is = [i | Left i <- x] + show c = unlines $ zipWith3 showLine is (takes (zipWith (-) (tail is ++ [s]) is) bs) ss where + ss = snd . runWriter . flip evalStateT 0 . showCode $ c + (x, s) = buildCode c + bs = V.toList $ compactCode (x, s) + 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 + 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) ' ' + pad i xs = xs ++ replicate (i - length xs) ' ' - maxbytes = 12 + maxbytes = 12 compactCode :: (CodeBuilderRes, Int) -> V.Vector Word8 compactCode (x, s) = V.replicate s 0 V.// [p | Right p <- x] @@ -214,390 +223,395 @@ buildCode :: LCode -> (CodeBuilderRes, Int) buildCode x = (r, len) where - ((_, r), (_, (len, _, _))) = flip runTardis ((0, []), (0, [], [])) . runWriterT . getCodeBuilder . mkCodeBuilder $ x + ((_, r), (_, (len, _, _))) = flip runTardis ((0, []), (0, [], [])) . runWriterT . getCodeBuilder . mkCodeBuilder $ x mkCodeBuilder :: LCode -> CodeBuilder mkCodeBuilder = \case - CodeLine x _ -> x - Prebuilt v _ -> mkCodeBuilder' (Align_ 4) <> codeBytes (V.toList v) - AppendCode x _ _ -> x - EmptyCode -> mempty + CodeLine x _ -> x + Prebuilt v _ -> mkCodeBuilder' (Align_ 4) <> codeBytes (V.toList v) + AppendCode x _ _ -> x + EmptyCode -> mempty newtype CodeM a = CodeM {unCodeM :: StateT Int (Writer LCode) a} - deriving (Functor, Applicative, Monad, MonadFix) + deriving (Functor, Applicative, Monad, MonadFix) type Code = CodeM () withLabels :: Code -> LCode withLabels = - snd . runWriter . flip evalStateT 0 . unCodeM + snd . runWriter . flip evalStateT 0 . unCodeM -- multi-byte nop operations nops :: Int -> Bytes nops = \case - 0 -> [] - 1 -> [0x90] - 2 -> [0x66, 0x90] - 3 -> [0x0f, 0x1f, 0x00] - 4 -> [0x0f, 0x1f, 0x40, 0x00] - 5 -> [0x0f, 0x1f, 0x44, 0x00, 0x00] - 6 -> [0x66, 0x0f, 0x1f, 0x44, 0x00, 0x00] - 7 -> [0x0f, 0x1f, 0x80, 0x00, 0x00, 0x00, 0x00] - 8 -> [0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00] - 9 -> [0x66, 0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00] - ((+(-2)) -> Integral x) -> [0xeb] ++ toBytes (x :: Int8) ++ replicate (fromIntegral x) 0x00 - ((+(-5)) -> Integral x) -> [0xe9] ++ toBytes (x :: Int32) ++ replicate (fromIntegral x) 0x00 + 0 -> [] + 1 -> [0x90] + 2 -> [0x66, 0x90] + 3 -> [0x0f, 0x1f, 0x00] + 4 -> [0x0f, 0x1f, 0x40, 0x00] + 5 -> [0x0f, 0x1f, 0x44, 0x00, 0x00] + 6 -> [0x66, 0x0f, 0x1f, 0x44, 0x00, 0x00] + 7 -> [0x0f, 0x1f, 0x80, 0x00, 0x00, 0x00, 0x00] + 8 -> [0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00] + 9 -> [0x66, 0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00] + ((+(-2)) -> Integral x) -> [0xeb] ++ toBytes (x :: Int8) ++ replicate (fromIntegral x) 0x00 + ((+(-5)) -> Integral x) -> [0xe9] ++ toBytes (x :: Int32) ++ replicate (fromIntegral x) 0x00 mkCodeBuilder' :: CodeLine -> 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 + 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 + 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) + 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) + 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 mkImmU S32 <> mkImm S64 else mkImm (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 + Mov_ dest@(RegOp r) ((if size dest == S64 then mkImmU S32 <> mkImm S64 else mkImm (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 - Cmov_ (Condition c) dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte (0x40 .|. c) <> reg2x8 dest src - Bsf dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbc <> reg2x8 dest src - Bsr dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbd <> reg2x8 dest src - Bt src dest | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xa3 <> reg2x8 dest src + Cmov_ (Condition c) dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte (0x40 .|. c) <> reg2x8 dest src + Bsf dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbc <> reg2x8 dest src + Bsr dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbd <> reg2x8 dest src + Bt src dest | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xa3 <> reg2x8 dest src - Lea_ dest src | size dest /= S8 -> regprefix2' (resizeOperand' dest src) dest 0x46 $ reg2x8 dest src - where - resizeOperand' :: IsSize s1 => Operand x s1 -> Operand RW s2 -> Operand RW s1 - resizeOperand' _ = resizeOperand + Lea_ dest src | size dest /= S8 -> regprefix2' (resizeOperand' dest src) dest 0x46 $ reg2x8 dest src where + resizeOperand' :: IsSize s1 => Operand x s1 -> Operand RW s2 -> Operand RW s1 + 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 - Bswap a@RegOp{} | size a >= S32 -> op1 0x07 0x1 a - Bswap a -> error $ "wrong bswap operand: " ++ show a + Not_ a -> op1 0x7b 0x2 a + Neg_ a -> op1 0x7b 0x3 a + Inc_ a -> op1 0x7f 0x0 a + Dec_ a -> op1 0x7f 0x1 a + Bswap a@RegOp{} | size a >= S32 -> op1 0x07 0x1 a + Bswap a -> error $ "wrong bswap operand: " ++ show a - Call_ (ImmOp (LabelRelValue S32 l)) -> codeByte 0xe8 <> mkRef S32 4 l - Call_ a -> op1' 0xff 0x2 a + Call_ (ImmOp (LabelRelValue S32 l)) -> codeByte 0xe8 <> mkRef S32 4 l + Call_ a -> op1' 0xff 0x2 a - Movd_ a@OpXMM b -> sse 0x6e a b - Movd_ b a@OpXMM -> sse 0x7e a b - Movq_ b a@OpXMM -> sse 0xd6 a b - Movdqa_ a@OpXMM b -> sse 0x6f a b - Movdqa_ b a@OpXMM -> sse 0x7f a b - Paddb_ a b -> sse 0xfc a b - Paddw_ a b -> sse 0xfd a b - Paddd_ a b -> sse 0xfe a b - Paddq_ a b -> sse 0xd4 a b - Psubb_ a b -> sse 0xf8 a b - Psubw_ a b -> sse 0xf9 a b - Psubd_ a b -> sse 0xfa a b - Psubq_ a b -> sse 0xfb a b - Pxor_ a b -> sse 0xef a b - Psllw_ a b -> sseShift 0x71 0x2 0xd1 a b - Pslld_ a b -> sseShift 0x72 0x2 0xd2 a b - Psllq_ a b -> sseShift 0x73 0x2 0xd3 a b - Pslldq_ a b -> sseShift 0x73 0x7 undefined a b - Psrlw_ a b -> sseShift 0x71 0x6 0xf1 a b - Psrld_ a b -> sseShift 0x72 0x6 0xf2 a b - Psrlq_ a b -> sseShift 0x73 0x6 0xf3 a b - Psrldq_ a b -> sseShift 0x73 0x3 undefined a b - Psraw_ a b -> sseShift 0x71 0x4 0xe1 a b - Psrad_ a b -> sseShift 0x72 0x4 0xe2 a b + Movd_ a@OpXMM b -> sse 0x6e a b + Movd_ b a@OpXMM -> sse 0x7e a b + Movq_ b a@OpXMM -> sse 0xd6 a b + Movdqa_ a@OpXMM b -> sse 0x6f a b + Movdqa_ b a@OpXMM -> sse 0x7f a b + Paddb_ a b -> sse 0xfc a b + Paddw_ a b -> sse 0xfd a b + Paddd_ a b -> sse 0xfe a b + Paddq_ a b -> sse 0xd4 a b + Psubb_ a b -> sse 0xf8 a b + Psubw_ a b -> sse 0xf9 a b + Psubd_ a b -> sse 0xfa a b + Psubq_ a b -> sse 0xfb a b + Pxor_ a b -> sse 0xef a b + Psllw_ a b -> sseShift 0x71 0x2 0xd1 a b + Pslld_ a b -> sseShift 0x72 0x2 0xd2 a b + Psllq_ a b -> sseShift 0x73 0x2 0xd3 a b + Pslldq_ a b -> sseShift 0x73 0x7 undefined a b + Psrlw_ a b -> sseShift 0x71 0x6 0xf1 a b + Psrld_ a b -> sseShift 0x72 0x6 0xf2 a b + Psrlq_ a b -> sseShift 0x73 0x6 0xf3 a b + Psrldq_ a b -> sseShift 0x73 0x3 undefined a b + Psraw_ a b -> sseShift 0x71 0x4 0xe1 a b + Psrad_ a b -> sseShift 0x72 0x4 0xe2 a b - Pop_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty - Pop_ dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty + Pop_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty + Pop_ dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty - Push_ (mkImmS S8 -> FJust (_, im)) -> codeByte 0x6a <> im - Push_ (mkImm S32 -> FJust (_, im)) -> codeByte 0x68 <> im - Push_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty - Push_ dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty + Push_ (mkImmS S8 -> FJust (_, im)) -> codeByte 0x6a <> im + Push_ (mkImm S32 -> FJust (_, im)) -> codeByte 0x68 <> im + Push_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty + Push_ dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty - Ret_ -> codeByte 0xc3 - Nop_ -> codeByte 0x90 - PushF_ -> codeByte 0x9c - PopF_ -> codeByte 0x9d - Cmc_ -> codeByte 0xf5 - Clc_ -> codeByte 0xf8 - Stc_ -> codeByte 0xf9 - Cli_ -> codeByte 0xfa - Sti_ -> codeByte 0xfb - Cld_ -> codeByte 0xfc - Std_ -> codeByte 0xfd + 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) (Just S8) l -> codeByte (0x70 .|. c) <> mkRef S8 1 l - J_ (Condition c) (Just S32) l -> codeByte 0x0f <> codeByte (0x80 .|. c) <> mkRef S32 4 l - J_ (Condition c) Nothing l -> mkAutoRef [(S8, [0x70 .|. c]), (S32, [0x0f, 0x80 .|. c])] l + J_ (Condition c) (Just S8) l -> codeByte (0x70 .|. c) <> mkRef S8 1 l + J_ (Condition c) (Just S32) l -> codeByte 0x0f <> codeByte (0x80 .|. c) <> mkRef S32 4 l + J_ (Condition c) Nothing l -> mkAutoRef [(S8, [0x70 .|. c]), (S32, [0x0f, 0x80 .|. c])] l - Jmp_ (Just S8) l -> codeByte 0xeb <> mkRef S8 1 l - Jmp_ (Just S32) l -> codeByte 0xe9 <> mkRef S32 4 l - Jmp_ Nothing l -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l + Jmp_ (Just S8) l -> codeByte 0xeb <> mkRef S8 1 l + Jmp_ (Just S32) l -> codeByte 0xe9 <> mkRef S32 4 l + Jmp_ Nothing l -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l - Jmpq_ (ImmOp (LabelRelValue S32 l)) -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l - Jmpq_ a -> op1' 0xff 0x4 a + Jmpq_ (ImmOp (LabelRelValue S32 l)) -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l + Jmpq_ a -> op1' 0xff 0x4 a - Label_ -> CodeBuilder 0 0 $ do - bs <- lift $ mdo - (n, ls, ps) <- getPast - sendFuture (n, n: ls, ps') - sendPast (ma, ma: mls) - ~(ma, mls) <- getFuture - let (bs, ps') = case ps of - [] -> ([], []) - corr: ps -> (concatMap g corr, ps) - g (size, p, v) = zip [p..] $ case (size, v + n) of - (S8, Integral v) -> toBytes (v :: Int8) - (S32, Integral v) -> toBytes (v :: Int32) - (s, i) -> error $ show i ++ " doesn't fit into " ++ show s - return bs - tell $ Right <$> bs + Label_ -> CodeBuilder 0 0 $ do + bs <- lift $ mdo + (n, ls, ps) <- getPast + sendFuture (n, n: ls, ps') + sendPast (ma, ma: mls) + ~(ma, mls) <- getFuture + let (bs, ps') = case ps of + [] -> ([], []) + corr: ps -> (concatMap g corr, ps) + g (size, p, v) = zip [p..] $ case (size, v + n) of + (S8, Integral v) -> toBytes (v :: Int8) + (S32, Integral v) -> toBytes (v :: Int32) + (s, i) -> error $ show i ++ " doesn't fit into " ++ show s + return bs + tell $ Right <$> bs - Data_ x -> codeBytes x + Data_ x -> codeBytes x - Align_ s -> CodeBuilder 0 (s-1) $ do - bs <- lift $ mdo - (n, ls, ps) <- getPast - sendFuture (n', ls, ps) - sendPast (ma + s-1, mls) - ~(ma, mls) <- getFuture - let n' = fromIntegral $ ((fromIntegral n - 1 :: Int64) .|. (fromIntegral s - 1)) + 1 - return $ zip [n..] $ nops $ n' - n - tell $ Right <$> bs + Align_ s -> CodeBuilder 0 (s-1) $ do + bs <- lift $ mdo + (n, ls, ps) <- getPast + sendFuture (n', ls, ps) + sendPast (ma + s-1, mls) + ~(ma, mls) <- getFuture + let n' = fromIntegral $ ((fromIntegral n - 1 :: Int64) .|. (fromIntegral s - 1)) + 1 + return $ zip [n..] $ nops $ n' - n + tell $ Right <$> bs where - convertImm :: Bool{-signed-} -> Size -> Operand r s -> First ((Bool, Size), CodeBuilder) - convertImm a b (ImmOp (Immediate c)) = First $ (,) (a, b) . codeBytes <$> integralToBytes a b c - convertImm True b (ImmOp (LabelRelValue s d)) | b == s = FJust $ (,) (True, b) $ mkRef s (sizeLen s) d - convertImm _ _ _ = FNothing + convertImm :: Bool{-signed-} -> Size -> Operand r s -> First ((Bool, Size), CodeBuilder) + convertImm a b (ImmOp (Immediate c)) = First $ (,) (a, b) . codeBytes <$> integralToBytes a b c + convertImm True b (ImmOp (LabelRelValue s d)) | b == s = FJust $ (,) (True, b) $ mkRef s (sizeLen s) d + convertImm _ _ _ = FNothing - mkImmS, mkImmU, mkImm, mkImmNo64 :: Size -> Operand r s -> First ((Bool, Size), CodeBuilder) - mkImmS = convertImm True - mkImmU = convertImm False - mkImm s = mkImmS s <> mkImmU s - mkImmNo64 s = mkImm (no64 s) + mkImmS, mkImmU, mkImm, mkImmNo64 :: Size -> Operand r s -> First ((Bool, Size), CodeBuilder) + mkImmS = convertImm True + mkImmU = convertImm False + mkImm s = mkImmS s <> mkImmU s + mkImmNo64 s = mkImm (no64 s) - xchg_a :: IsSize s => Operand r s -> CodeBuilder - xchg_a dest@(RegOp r) | size dest /= S8 = regprefix (size dest) dest (oneReg 0x12 r) mempty - xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty + xchg_a :: IsSize s => Operand r s -> CodeBuilder + xchg_a dest@(RegOp r) | size dest /= S8 = regprefix (size dest) dest (oneReg 0x12 r) mempty + xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty - toCode :: HasBytes a => a -> CodeBuilder - toCode = codeBytes . toBytes + toCode :: HasBytes a => a -> CodeBuilder + toCode = codeBytes . toBytes - sizePrefix_ :: [SReg] -> Size -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder - sizePrefix_ rs s r x c im - | noHighRex rs = pre <> c <> displacement r <> im - | otherwise = error "cannot use high register in rex instruction" - where - pre = case s of - S8 -> mem32pre r <> maybePrefix40 - S16 -> codeByte 0x66 <> mem32pre r <> prefix40 x - S32 -> mem32pre r <> prefix40 x - S64 -> mem32pre r <> prefix40 (0x8 .|. x) - S128 -> mem32pre r <> codeByte 0x66 <> maybePrefix40 + sizePrefix_ :: [SReg] -> Size -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder + sizePrefix_ rs s r x c im + | noHighRex rs = pre <> c <> displacement r <> im + | otherwise = error "cannot use high register in rex instruction" + where + pre = case s of + S8 -> mem32pre r <> maybePrefix40 + S16 -> codeByte 0x66 <> mem32pre r <> prefix40 x + S32 -> mem32pre r <> prefix40 x + S64 -> mem32pre r <> prefix40 (0x8 .|. x) + S128 -> mem32pre r <> codeByte 0x66 <> maybePrefix40 - mem32pre :: Operand r s -> CodeBuilder - mem32pre (MemOp r@Addr{}) | size r == S32 = codeByte 0x67 - mem32pre _ = mempty + mem32pre :: Operand r s -> CodeBuilder + mem32pre (MemOp r@Addr{}) | size r == S32 = codeByte 0x67 + mem32pre _ = mempty - prefix40 x = iff (x /= 0) $ prefix40_ x - prefix40_ x = codeByte $ 0x40 .|. x + prefix40 x = iff (x /= 0) $ prefix40_ x + prefix40_ x = codeByte $ 0x40 .|. x - maybePrefix40 = iff (any isRex rs || x /= 0) (prefix40_ x) + maybePrefix40 = iff (any isRex rs || x /= 0) (prefix40_ x) - displacement :: Operand r s -> CodeBuilder - displacement (IPMemOp (Immediate d)) = toCode d - displacement (IPMemOp (LabelRelValue s@S32 d)) = mkRef s (sizeLen s + fromIntegral (codeBuilderLength im)) d - displacement (MemOp (Addr b d i)) = mkSIB b i <> dispVal b d - where - mkSIB _ (IndexReg s (NormalReg 0x4)) = error "sp cannot be used as index" - mkSIB _ (IndexReg s i) = f s $ reg8_ i - mkSIB Nothing _ = f s1 0x4 - mkSIB (Just (reg8_ -> 0x4)) _ = f s1 0x4 - mkSIB _ _ = mempty + displacement :: Operand r s -> CodeBuilder + displacement (IPMemOp (Immediate d)) = toCode d + displacement (IPMemOp (LabelRelValue s@S32 d)) = mkRef s (sizeLen s + fromIntegral (codeBuilderLength im)) d + displacement (MemOp (Addr b d i)) = mkSIB b i <> dispVal b d + where + mkSIB _ (IndexReg s (NormalReg 0x4)) = error "sp cannot be used as index" + mkSIB _ (IndexReg s i) = f s $ reg8_ i + mkSIB Nothing _ = f s1 0x4 + mkSIB (Just (reg8_ -> 0x4)) _ = f s1 0x4 + mkSIB _ _ = mempty - f (Scale s) i = codeByte $ s `shiftL` 6 .|. i `shiftL` 3 .|. maybe 0x5 reg8_ b + 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 - displacement _ = mempty + 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 + displacement _ = mempty - reg8_ :: Reg t -> Word8 - reg8_ (NormalReg r) = r .&. 0x7 - reg8_ (HighReg r) = r .|. 0x4 - reg8_ (XMM r) = r .&. 0x7 + reg8_ :: Reg t -> Word8 + reg8_ (NormalReg r) = r .&. 0x7 + reg8_ (HighReg r) = r .|. 0x4 + reg8_ (XMM r) = r .&. 0x7 - regprefix :: IsSize s => Size -> Operand r s -> CodeBuilder -> CodeBuilder -> CodeBuilder - regprefix s r c im = sizePrefix_ (regs r) s r (extbits r) c im + regprefix :: IsSize s => Size -> Operand r s -> CodeBuilder -> CodeBuilder -> CodeBuilder + regprefix s r = sizePrefix_ (regs r) s r (extbits r) - regprefix2 :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> CodeBuilder -> CodeBuilder - regprefix2 r r' c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) c mempty + regprefix2 :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> CodeBuilder -> CodeBuilder + regprefix2 r r' c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) c mempty - regprefix'' :: IsSize s => Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder - regprefix'' r p c = regprefix (size r) r $ extension r p <> c + regprefix'' :: IsSize s => Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder + regprefix'' r p c = regprefix (size r) r $ extension r p <> c - regprefix2' :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder - regprefix2' r r' p c = regprefix2 r r' $ extension r p <> c + regprefix2' :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder + regprefix2' r r' p c = regprefix2 r r' $ extension r p <> c - sse :: IsSize s => Word8 -> Operand r S128 -> Operand r' s -> CodeBuilder - sse op a@OpXMM b = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg2x8 a b) mempty + sse :: IsSize s => Word8 -> Operand r S128 -> Operand r' s -> CodeBuilder + sse op a@OpXMM b = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg2x8 a b) mempty - sseShift :: Word8 -> Word8 -> Word8 -> Operand RW S128 -> Operand r S8 -> CodeBuilder - sseShift op x op' a@OpXMM b@(mkImmU S8 -> FJust (_, i)) = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg8 x a) i - -- TODO: xmm argument + sseShift :: Word8 -> Word8 -> Word8 -> Operand RW S128 -> Operand r S8 -> CodeBuilder + sseShift op x op' a@OpXMM b@(mkImmU S8 -> FJust (_, i)) = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg8 x a) i + -- TODO: xmm argument - extension :: HasSize a => a -> Word8 -> CodeBuilder - extension x p = codeByte $ p `shiftL` 1 .|. indicator (size x /= S8) + extension :: HasSize a => a -> Word8 -> CodeBuilder + extension x p = codeByte $ p `shiftL` 1 .|. indicator (size x /= S8) - extbits :: Operand r s -> Word8 - extbits = \case - MemOp (Addr b _ i) -> maybe 0 indexReg b .|. case i of NoIndex -> 0; IndexReg _ x -> indexReg x `shiftL` 1 - RegOp r -> indexReg r - _ -> 0 - where - indexReg (NormalReg r) = r `shiftR` 3 .&. 1 - indexReg _ = 0 + extbits :: Operand r s -> Word8 + extbits = \case + MemOp (Addr b _ i) -> maybe 0 indexReg b .|. case i of NoIndex -> 0; IndexReg _ x -> indexReg x `shiftL` 1 + RegOp r -> indexReg r + _ -> 0 + where + indexReg (NormalReg r) = r `shiftR` 3 .&. 1 + indexReg _ = 0 - reg8 :: Word8 -> Operand r s -> CodeBuilder - reg8 w x = codeByte $ operMode x `shiftL` 6 .|. w `shiftL` 3 .|. rc x - where - operMode :: Operand r s -> 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 _ = 0x3 + reg8 :: Word8 -> Operand r s -> CodeBuilder + reg8 w x = codeByte $ operMode x `shiftL` 6 .|. w `shiftL` 3 .|. rc x + where + operMode :: Operand r s -> 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 _ = 0x3 - rc :: Operand r s -> Word8 - rc (MemOp (Addr (Just r) _ NoIndex)) = reg8_ r - rc MemOp{} = 0x04 -- SIB byte - rc IPMemOp{} = 0x05 - rc (RegOp r) = reg8_ r + rc :: Operand r s -> Word8 + rc (MemOp (Addr (Just r) _ NoIndex)) = reg8_ r + rc MemOp{} = 0x04 -- SIB byte + rc IPMemOp{} = 0x05 + rc (RegOp r) = reg8_ r - op2 :: IsSize s => Word8 -> Operand RW s -> Operand r s -> CodeBuilder - op2 op dest@RegA src@(mkImmNo64 (size dest) -> FJust (_, im)) | size dest == S8 || isNothing (getFirst $ mkImmS S8 src) - = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im - op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im)) - = regprefix'' dest (0x40 .|. indicator (size dest /= S8 && k == S8)) (reg8 op dest) im - op2 op dest src = op2' (op `shiftL` 2) dest $ noImm "1" src + op2 :: IsSize s => Word8 -> Operand RW s -> Operand r s -> CodeBuilder + op2 op dest@RegA src@(mkImmNo64 (size dest) -> FJust (_, im)) | size dest == S8 || isNothing (getFirst $ mkImmS S8 src) + = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im + op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im)) + = regprefix'' dest (0x40 .|. indicator (size dest /= S8 && k == S8)) (reg8 op dest) im + op2 op dest src = op2' (op `shiftL` 2) dest $ noImm "1" src - noImm :: String -> Operand r s -> Operand RW s - 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 + noImm :: String -> Operand r s -> Operand RW s + 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 RW s -> Operand RW s -> CodeBuilder - op2' op dest src@RegOp{} = op2g op dest src - op2' op dest@RegOp{} src = op2g (op .|. 0x1) src dest + op2' :: IsSize s => Word8 -> Operand RW s -> Operand RW s -> CodeBuilder + op2' op dest src@RegOp{} = op2g op dest src + op2' op dest@RegOp{} src = op2g (op .|. 0x1) src dest - op2g :: (IsSize t, IsSize s) => Word8 -> Operand r s -> Operand r' t -> CodeBuilder - op2g op dest src = regprefix2' dest src op $ reg2x8 src dest + op2g :: (IsSize t, IsSize s) => Word8 -> Operand r s -> Operand r' t -> CodeBuilder + op2g op dest src = regprefix2' dest src op $ reg2x8 src dest - reg2x8 :: (IsSize s, IsSize s') => Operand r s -> Operand r' s' -> CodeBuilder - reg2x8 (RegOp r) x = reg8 (reg8_ r) x + reg2x8 :: (IsSize s, IsSize s') => Operand r s -> Operand r' s' -> CodeBuilder + reg2x8 (RegOp r) = reg8 (reg8_ r) - op1_ :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder -> CodeBuilder - op1_ r1 r2 dest im = regprefix'' dest r1 (reg8 r2 dest) im + op1_ :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder -> CodeBuilder + op1_ r1 r2 dest = regprefix'' dest r1 (reg8 r2 dest) - op1 :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder - op1 a b c = op1_ a b c mempty + op1 :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder + op1 a b c = op1_ a b c mempty - op1' :: Word8 -> Word8 -> Operand r S64 -> CodeBuilder - op1' r1 r2 dest = regprefix S32 dest (codeByte r1 <> reg8 r2 dest) mempty + op1' :: Word8 -> Word8 -> Operand r S64 -> CodeBuilder + op1' r1 r2 dest = regprefix S32 dest (codeByte r1 <> reg8 r2 dest) mempty - shiftOp :: IsSize s => Word8 -> Operand RW s -> Operand r S8 -> CodeBuilder - shiftOp c dest (ImmOp (Immediate 1)) = op1 0x68 c dest - shiftOp c dest (mkImmU S8 -> FJust (_, i)) = op1_ 0x60 c dest i - shiftOp c dest RegCl = op1 0x69 c dest - shiftOp _ _ _ = error "invalid shift operands" + shiftOp :: IsSize s => Word8 -> Operand RW s -> Operand r S8 -> CodeBuilder + shiftOp c dest (ImmOp (Immediate 1)) = op1 0x68 c dest + shiftOp c dest (mkImmU S8 -> FJust (_, i)) = op1_ 0x60 c dest i + shiftOp c dest RegCl = op1 0x69 c dest + shiftOp _ _ _ = error "invalid shift operands" - oneReg :: Word8 -> Reg t -> CodeBuilder - oneReg x r = codeByte $ x `shiftL` 3 .|. reg8_ r + oneReg :: Word8 -> Reg t -> CodeBuilder + oneReg x r = codeByte $ x `shiftL` 3 .|. reg8_ r pattern OpXMM <- RegOp XMM{} -------------------------------------------------------------- asm codes data LCode where - Prebuilt :: V.Vector Word8 -> LCode -> LCode - EmptyCode :: LCode - AppendCode :: CodeBuilder -> LCode -> LCode -> LCode - CodeLine :: CodeBuilder -> CodeLine -> LCode + Prebuilt :: V.Vector Word8 -> LCode -> LCode + EmptyCode :: LCode + AppendCode :: CodeBuilder -> LCode -> LCode -> LCode + CodeLine :: CodeBuilder -> CodeLine -> LCode +#if MIN_VERSION_base(4,11,0) +instance Semigroup LCode where + a <> b = AppendCode (mkCodeBuilder a <> mkCodeBuilder b) a b +#endif + instance Monoid LCode where - mempty = EmptyCode - mappend a b = AppendCode (mkCodeBuilder a <> mkCodeBuilder b) a b + mempty = EmptyCode -ret = mkCodeLine Ret_ -nop = mkCodeLine Nop_ -pushf = mkCodeLine PushF_ -popf = mkCodeLine PopF_ -cmc = mkCodeLine Cmc_ -clc = mkCodeLine Clc_ -stc = mkCodeLine Stc_ -cli = mkCodeLine Cli_ -sti = mkCodeLine Sti_ -cld = mkCodeLine Cld_ -std = mkCodeLine Std_ -inc a = mkCodeLine (Inc_ a) -dec a = mkCodeLine (Dec_ a) -not_ a = mkCodeLine (Not_ a) -neg a = mkCodeLine (Neg_ a) -bswap a = mkCodeLine (Bswap a) -bsf a b = mkCodeLine (Bsf a b) -bsr a b = mkCodeLine (Bsr a b) -bt a b = mkCodeLine (Bt a b) -add a b = mkCodeLine (Add_ a b) -or_ a b = mkCodeLine (Or_ a b) -adc a b = mkCodeLine (Adc_ a b) -sbb a b = mkCodeLine (Sbb_ a b) -and_ a b = mkCodeLine (And_ a b) -sub a b = mkCodeLine (Sub_ a b) -xor_ a b = mkCodeLine (Xor_ a b) -cmp a b = mkCodeLine (Cmp_ a b) -test a b = mkCodeLine (Test_ a b) -mov a b = mkCodeLine (Mov_ a b) +#if !MIN_VERSION_base(4,11,0) + mappend a b = AppendCode (mkCodeBuilder a <> mkCodeBuilder b) a b +#endif + +ret = mkCodeLine Ret_ +nop = mkCodeLine Nop_ +pushf = mkCodeLine PushF_ +popf = mkCodeLine PopF_ +cmc = mkCodeLine Cmc_ +clc = mkCodeLine Clc_ +stc = mkCodeLine Stc_ +cli = mkCodeLine Cli_ +sti = mkCodeLine Sti_ +cld = mkCodeLine Cld_ +std = mkCodeLine Std_ +inc a = mkCodeLine (Inc_ a) +dec a = mkCodeLine (Dec_ a) +not_ a = mkCodeLine (Not_ a) +neg a = mkCodeLine (Neg_ a) +bswap a = mkCodeLine (Bswap a) +bsf a b = mkCodeLine (Bsf a b) +bsr a b = mkCodeLine (Bsr a b) +bt a b = mkCodeLine (Bt a b) +add a b = mkCodeLine (Add_ a b) +or_ a b = mkCodeLine (Or_ a b) +adc a b = mkCodeLine (Adc_ a b) +sbb a b = mkCodeLine (Sbb_ a b) +and_ a b = mkCodeLine (And_ a b) +sub a b = mkCodeLine (Sub_ a b) +xor_ a b = mkCodeLine (Xor_ a b) +cmp a b = mkCodeLine (Cmp_ a b) +test a b = mkCodeLine (Test_ a b) +mov a b = mkCodeLine (Mov_ a b) cmov c a b = mkCodeLine (Cmov_ c a b) -rol a b = mkCodeLine (Rol_ a b) -ror a b = mkCodeLine (Ror_ a b) -rcl a b = mkCodeLine (Rcl_ a b) -rcr a b = mkCodeLine (Rcr_ a b) -shl a b = mkCodeLine (Shl_ a b) -shr a b = mkCodeLine (Shr_ a b) -sar a b = mkCodeLine (Sar_ a b) -xchg a b = mkCodeLine (Xchg_ a b) +rol a b = mkCodeLine (Rol_ a b) +ror a b = mkCodeLine (Ror_ a b) +rcl a b = mkCodeLine (Rcl_ a b) +rcr a b = mkCodeLine (Rcr_ a b) +shl a b = mkCodeLine (Shl_ a b) +shr a b = mkCodeLine (Shr_ a b) +sar a b = mkCodeLine (Sar_ a b) +xchg a b = mkCodeLine (Xchg_ a b) movd a b = mkCodeLine (Movd_ a b) movq a b = mkCodeLine (Movq_ a b) movdqa a b = mkCodeLine (Movdqa_ a b) @@ -620,36 +634,33 @@ psrldq a b = mkCodeLine (Psrldq_ a b) psraw a b = mkCodeLine (Psraw_ a b) psrad a b = mkCodeLine (Psrad_ a b) -lea a b = mkCodeLine (Lea_ a b) -j a c = mkCodeLine (J_ a Nothing c) -pop a = mkCodeLine (Pop_ a) -push a = mkCodeLine (Push_ a) -call a = mkCodeLine (Call_ a) -jmpq a = mkCodeLine (Jmpq_ a) -jmp b = mkCodeLine (Jmp_ Nothing b) -db a = mkCodeLine (Data_ a) -align a = mkCodeLine (Align_ a) +lea a b = mkCodeLine (Lea_ a b) +j a c = mkCodeLine (J_ a Nothing c) +pop a = mkCodeLine (Pop_ a) +push a = mkCodeLine (Push_ a) +call a = mkCodeLine (Call_ a) +jmpq a = mkCodeLine (Jmpq_ a) +jmp b = mkCodeLine (Jmp_ Nothing b) +db a = mkCodeLine (Data_ a) +align a = mkCodeLine (Align_ a) label :: CodeM Label label = do - i <- CodeM get - CodeM $ put $ i+1 - mkCodeLine Label_ - return $ Label i + i <- CodeM get + CodeM $ put $ i+1 + mkCodeLine Label_ + return $ Label i mkCodeLine :: CodeLine -> Code mkCodeLine x = CodeM $ tell $ CodeLine (tellAddr <> mkCodeBuilder' x) x tellAddr = CodeBuilder 0 0 $ do - (c, _, _) <- lift getPast - tell [Left c] - -------------- - + (c, _, _) <- lift getPast + tell [Left c] showCode = \case - EmptyCode -> return () - AppendCode _ a b -> showCode a >> showCode b - Prebuilt _ c -> showCodeLine (Align_ 4) >> codeLine "{" >> showCode c >> codeLine "}" - CodeLine _ x -> showCodeLine x + EmptyCode -> return () + AppendCode _ a b -> showCode a >> showCode b + Prebuilt _ c -> showCodeLine (Align_ 4) >> codeLine "{" >> showCode c >> codeLine "}" + CodeLine _ x -> showCodeLine x diff --git a/CodeGen/X86/Examples.hs b/CodeGen/X86/Examples.hs deleted file mode 100644 --- a/CodeGen/X86/Examples.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module CodeGen.X86.Examples where - -import Foreign - -import CodeGen.X86 - -foreign import ccall "dynamic" callWW :: FunPtr (Word64 -> Word64) -> Word64 -> Word64 -instance Callable (Word64 -> Word64) where dynCCall = callWW - -foreign import ccall "dynamic" callPW :: FunPtr (Ptr a -> Word64) -> Ptr a -> Word64 -instance Callable (Ptr a -> Word64) where dynCCall = callPW - -foreign import ccall "dynamic" callIO :: FunPtr (IO ()) -> IO () -instance Callable (IO ()) where dynCCall = callIO - -foreign import ccall "wrapper" createPtrWord64_Word64 :: (Word64 -> Word64) -> IO (FunPtr (Word64 -> Word64)) -instance CallableHs (Word64 -> Word64) where createHsPtr = createPtrWord64_Word64 - ------------------------------------------------------------------------------- --- * examples - --- | Example: identity function in Assembly (look at the source code) --- --- Input: @rdi@ on Linux \/ System V, @rcx@ on Win64 --- --- Output: @rax@ -idCode = do - mov result arg1 - ret - -idFun :: Word64 -> Word64 -idFun = compile idCode - --- | Example: Fibonacci function in Assembly -fibCode = saveNonVolatile $ do - mov rdi arg1 - inc rdi - xor_ rdx rdx - mov rax 1 - doWhile NZ $ do - mov rcx rax - mov rax rdx - add rdx rcx - dec rdi - -fibFun :: Word64 -> Word64 -fibFun = compile fibCode - --- | Example: trace a register in Assembly -tracedFibCode = saveNonVolatile $ do - mov rdi arg1 - inc rdi - xor_ rdx rdx - mov rax 1 - doWhile NZ $ do - mov rcx rax - mov rax rdx - add rdx rcx - dec rdi - traceReg "d" rax - -tracedFibFun :: Word64 -> Word64 -tracedFibFun = compile tracedFibCode - --- | Example: call Haskell @fib@ function from Assembly -callHsCode = do - callFun r11 (hsPtr fib) - ret - -fib :: Word64 -> Word64 -fib n = go n 0 1 - where - go 0 a b = b `seq` a - go n a b = go (n-1) b (a+b) - -callHsFun :: Word64 -> Word64 -callHsFun = compile callHsCode - --- | Example: call C @printf@ function from Assembly --- -callCCode name = saveNonVolatile $ do - leaData arg1 $ CString "Hello %s!\n" - leaData arg2 $ CString name - xor_ rax rax -- zero XMM arguments ????? - callFun r11 printf - -callCFun :: String -> IO () -callCFun name = compile $ callCCode name - -------------------------------------------------------- - -memTestFun :: Word64 -> IO Bool -memTestFun v = do - r <- mallocBytes 8 -- this is not required to be aligned (and in any case malloc aligns to machine words) - pokeByteOff r 0 (v :: Word64) - let code = saveNonVolatile $ do - mov rdi arg1 - mov rax (addr rdi) - return $ compile code (r :: Ptr Word8) == v - - diff --git a/CodeGen/X86/FFI.hs b/CodeGen/X86/FFI.hs --- a/CodeGen/X86/FFI.hs +++ b/CodeGen/X86/FFI.hs @@ -1,10 +1,8 @@ -{-# language CPP #-} -{-# language ForeignFunctionInterface #-} -{-# language BangPatterns #-} -{-# language ViewPatterns #-} {-# language FlexibleInstances #-} {-# language FlexibleContexts #-} +{-# language ViewPatterns #-} {-# language TypeFamilies #-} +{-# language CPP #-} module CodeGen.X86.FFI where ------------------------------------------------------- diff --git a/CodeGen/X86/Tests.hs b/CodeGen/X86/Tests.hs --- a/CodeGen/X86/Tests.hs +++ b/CodeGen/X86/Tests.hs @@ -1,418 +1,456 @@ -{-# 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 RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} -module CodeGen.X86.Tests (runTests) where - -import Data.Monoid -import Data.Maybe -import Data.List -import Data.Bits -import Data.Int -import Data.Word - -import Test.QuickCheck hiding ((.&.), label) -import Debug.Trace - -import CodeGen.X86.Asm -import CodeGen.X86.CodeGen -import CodeGen.X86.FFI -import CodeGen.X86.Utils - -import Foreign - -foreign import ccall "dynamic" dcb :: FunPtr Bool -> Bool -instance Callable Bool where dynCCall = dcb - ------------------------------------------------------------------------------- - -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 $ ipRel $ Label 0 - -instance Arbitrary (Addr S64) where - arbitrary = suchThat (Addr <$> base <*> disp <*> index) ok - where - ok (Addr Nothing _ NoIndex) = False - ok (Addr Nothing _ (IndexReg 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 RW s) where - arbitrary = oneof - [ genRegs - , genMems - , genIPBase - ] - -instance IsSize s => Arbitrary (Operand R s) where - arbitrary = oneof - [ fromIntegral <$> oneof (arbVal <$> [S8, S16, S32, S64]) - , genRegs - , genMems - , genIPBase - ] - -instance Arbitrary CodeLine 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 RW s -> Operand R s -> CodeLine) -> Gen CodeLine - op2 op = oneof - [ f op (arbitrary :: Gen (Operand RW S8)) arbitrary - , f op (arbitrary :: Gen (Operand RW S16)) arbitrary - , f op (arbitrary :: Gen (Operand RW S32)) arbitrary - , f op (arbitrary :: Gen (Operand RW S64)) arbitrary - ] - where - f :: forall s . IsSize s => (Operand RW s -> Operand R s -> CodeLine) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen CodeLine - 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 RW s -> Operand R s -> CodeLine) -> Gen CodeLine - op2'' op = oneof - [ f op (arbitrary :: Gen (Operand RW S8)) arbitrary - , f op (arbitrary :: Gen (Operand RW S16)) arbitrary - , f op (arbitrary :: Gen (Operand RW S32)) arbitrary - , f op (arbitrary :: Gen (Operand RW S64)) arbitrary - ] - where - f :: forall s . IsSize s => (Operand RW s -> Operand R s -> CodeLine) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen CodeLine - 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 RW s -> Operand R S8 -> CodeLine) -> Gen CodeLine - op2' op = oneof - [ f op (arbitrary :: Gen (Operand RW S8)) arb - , f op (arbitrary :: Gen (Operand RW S16)) arb - , f op (arbitrary :: Gen (Operand RW S32)) arb - , f op (arbitrary :: Gen (Operand RW S64)) arb - ] - where - arb = oneof - [ fromIntegral <$> (arbitrary :: Gen Word8) - , return cl - ] - - f :: forall s . IsSize s => (Operand RW s -> Operand R S8 -> CodeLine) -> Gen (Operand RW s) -> Gen (Operand R S8) -> Gen CodeLine - 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) (ImmOp (Immediate i)) = isJust (integralToBytes True (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{} (ImmOp (Immediate i)) = isJust (integralToBytes True (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) => CodeLine -> 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') => CodeLine -> (Operand RW s -> Operand r s' -> CodeLine) -> Operand RW s -> Operand r s' -> 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 RW s -> Operand k s' -> 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 = mdo - mapM_ push sr - mov f1 rsp - pushf - pop rax - push rax - popf - initab (initcf >> cc >> mova) - mkRes - mov rsp f1 {- <> traceReg "X" rdx' -} - mapM_ pop $ reverse sr - ret - - sr = [rsi, rdi, rbx, rbp, r12, r13, r14, r15] - - cc = mkCodeLine i - initcf = if cF then stc else clc - mova = case a of - RegOp (NormalReg 0x2) -> return () - _ -> mov rdx' a - mkRes = otest i $ if_ (if cF' then C else NC) (xor_ rax rax) $ do - xor_ rax rax - mov rcx res - cmp rcx' rdx' - unless 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 RW s - rdx' = resizeOperand rdx :: Operand RW s - sa = size a - - ((cF', oF'), res) = case sa of - S8 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word8) - S16 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word16) - S32 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word32) - S64 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word64) - - msg = unlines [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 cc $ 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 RW S64 -> Operand k s -> Gen (Int64, Code -> Code) - mkVal _ o@(ImmOp (Immediate w)) = return (w, id) - mkVal _ o@(RegOp x) = do - v <- arbVal $ size o - return (v, (mov (RegOp x) (fromIntegral v) >>)) - mkVal helper x@(IPMemOp LabelRelValue{}) = do - v <- arbVal $ size x - return (v, \c -> mdo - jmp l - db $ toBytes v - l <- label - c) - mkVal helper o@(MemOp (Addr (Just x) d i)) = do - v <- arbVal $ size o - (vi, setvi) <- case i of - NoIndex -> return (0, return ()) - IndexReg sc i -> do - x <- arbVal $ size i - return (scaleFactor sc * x, mov (RegOp i) (fromIntegral x)) - let - d' = (vi :: Int64) + case d of - NoDisp -> 0 - Disp v -> fromIntegral v - rx = resizeOperand $ RegOp x :: Operand RW S64 - return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper >> setvi) >>)) - mkVal helper o@(MemOp (Addr Nothing d (IndexReg sc x))) = do - v <- arbVal $ size o - let - d' = case d of - NoDisp -> 0 :: Int64 - Disp v -> fromIntegral v - rx = resizeOperand $ RegOp x :: Operand RW S64 - return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper) >>)) - - -propInstr (IT _ c) = compile c :: Bool - -tests num = quickCheckWith stdArgs { maxSuccess = num } propInstr - ------------------------------------------ - -return [] - --- | Run all tests -runTests = do - $quickCheckAll - tests 2000 - +{-# language LambdaCase #-} +{-# language BangPatterns #-} +{-# language ViewPatterns #-} +{-# language PatternGuards #-} +{-# language PatternSynonyms #-} +{-# language NoMonomorphismRestriction #-} +{-# language ScopedTypeVariables #-} +{-# language RankNTypes #-} +{-# language TypeFamilies #-} +{-# language GADTs #-} +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} +module CodeGen.X86.Tests + ( runTests + ) +where + +import Data.Monoid +import Data.Maybe +import Data.List +import Data.Bits +import Data.Int +import Data.Word + +import Test.QuickCheck hiding ( (.&.) + , label + ) +import Debug.Trace + +import CodeGen.X86.Asm +import CodeGen.X86.CodeGen +import CodeGen.X86.FFI +import CodeGen.X86.Utils + +import Foreign + +foreign import ccall "dynamic" dcb :: FunPtr Bool -> Bool +instance Callable Bool where + dynCCall = dcb + +------------------------------------------------------------------------------ + +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 $ ipRel $ Label 0 + +instance Arbitrary (Addr S64) where + arbitrary = suchThat (Addr <$> base <*> disp <*> index) ok + where + ok (Addr Nothing _ NoIndex) = False + ok (Addr Nothing _ (IndexReg 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 RW s) where + arbitrary = oneof [genRegs, genMems, genIPBase] + +instance IsSize s => Arbitrary (Operand R s) where + arbitrary = oneof [fromIntegral <$> oneof (arbVal <$> [S8, S16, S32, S64]), genRegs, genMems, genIPBase] + +instance Arbitrary CodeLine 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 RW s -> Operand R s -> CodeLine) -> Gen CodeLine + op2 op = oneof + [ f op (arbitrary :: Gen (Operand RW S8)) arbitrary + , f op (arbitrary :: Gen (Operand RW S16)) arbitrary + , f op (arbitrary :: Gen (Operand RW S32)) arbitrary + , f op (arbitrary :: Gen (Operand RW S64)) arbitrary + ] + where + f + :: forall s + . IsSize s + => (Operand RW s -> Operand R s -> CodeLine) + -> Gen (Operand RW s) + -> Gen (Operand R s) + -> Gen CodeLine + 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 RW s -> Operand R s -> CodeLine) -> Gen CodeLine + op2'' op = oneof + [ f op (arbitrary :: Gen (Operand RW S8)) arbitrary + , f op (arbitrary :: Gen (Operand RW S16)) arbitrary + , f op (arbitrary :: Gen (Operand RW S32)) arbitrary + , f op (arbitrary :: Gen (Operand RW S64)) arbitrary + ] + where + f + :: forall s + . IsSize s + => (Operand RW s -> Operand R s -> CodeLine) + -> Gen (Operand RW s) + -> Gen (Operand R s) + -> Gen CodeLine + 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 RW s -> Operand R S8 -> CodeLine) -> Gen CodeLine + op2' op = oneof + [ f op (arbitrary :: Gen (Operand RW S8)) arb + , f op (arbitrary :: Gen (Operand RW S16)) arb + , f op (arbitrary :: Gen (Operand RW S32)) arb + , f op (arbitrary :: Gen (Operand RW S64)) arb + ] + where + arb = oneof [fromIntegral <$> (arbitrary :: Gen Word8), return cl] + + f + :: forall s + . IsSize s + => (Operand RW s -> Operand R S8 -> CodeLine) + -> Gen (Operand RW s) + -> Gen (Operand R S8) + -> Gen CodeLine + 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) (ImmOp (Immediate i)) = isJust (integralToBytes True (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{} (ImmOp (Immediate i)) = isJust (integralToBytes True (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) + => CodeLine + -> 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_ (-) (const a) + Test_{} -> mk_ (.&.) (const 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') + => CodeLine + -> (Operand RW s -> Operand r s' -> CodeLine) + -> Operand RW s + -> Operand r s' + -> 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 RW s -> Operand k s' -> 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 = mdo + mapM_ push sr + mov f1 rsp + pushf + pop rax + push rax + popf + initab (initcf >> cc >> mova) + mkRes + mov rsp f1 {- <> traceReg "X" rdx' -} + mapM_ pop $ reverse sr + ret + + sr = [rsi, rdi, rbx, rbp, r12, r13, r14, r15] + + cc = mkCodeLine i + initcf = if cF then stc else clc + mova = case a of + RegOp (NormalReg 0x2) -> return () + _ -> mov rdx' a + mkRes = otest i $ if_ (if cF' then C else NC) (xor_ rax rax) $ do + xor_ rax rax + mov rcx res + cmp rcx' rdx' + unless 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 RW s + rdx' = resizeOperand rdx :: Operand RW s + sa = size a + + ((cF', oF'), res) = case sa of + S8 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word8) + S16 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word16) + S32 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word32) + S64 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word64) + + msg = unlines + [ 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 cc $ 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 RW S64 -> Operand k s -> Gen (Int64, Code -> Code) + mkVal _ o@(ImmOp (Immediate w)) = return (w, id) + mkVal _ o@(RegOp x ) = do + v <- arbVal $ size o + return (v, (mov (RegOp x) (fromIntegral v) >>)) + mkVal helper x@(IPMemOp LabelRelValue{}) = do + v <- arbVal $ size x + return + ( v + , \c -> mdo + jmp l + db $ toBytes v + l <- label + c + ) + mkVal helper o@(MemOp (Addr (Just x) d i)) = do + v <- arbVal $ size o + (vi, setvi) <- case i of + NoIndex -> return (0, return ()) + IndexReg sc i -> do + x <- arbVal $ size i + return (scaleFactor sc * x, mov (RegOp i) (fromIntegral x)) + let d' = (vi :: Int64) + case d of + NoDisp -> 0 + Disp v -> fromIntegral v + rx = resizeOperand $ RegOp x :: Operand RW S64 + return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper >> setvi) >>)) + mkVal helper o@(MemOp (Addr Nothing d (IndexReg sc x))) = do + v <- arbVal $ size o + let d' = case d of + NoDisp -> 0 :: Int64 + Disp v -> fromIntegral v + rx = resizeOperand $ RegOp x :: Operand RW S64 + return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper) >>)) + + +propInstr (IT _ c) = compile c :: Bool + +tests num = quickCheckWith stdArgs { maxSuccess = num } propInstr + +----------------------------------------- + +return [] + +-- | Run all tests +runTests = do + $quickCheckAll + tests 2000 + diff --git a/CodeGen/X86/Utils.hs b/CodeGen/X86/Utils.hs --- a/CodeGen/X86/Utils.hs +++ b/CodeGen/X86/Utils.hs @@ -1,92 +1,111 @@ -{-# language CPP #-} -{-# language BangPatterns #-} -{-# language NoMonomorphismRestriction #-} -{-# language ScopedTypeVariables #-} -{-# language DataKinds #-} -{-# language ForeignFunctionInterface #-} -{-# language RecursiveDo #-} -module CodeGen.X86.Utils where - -import Data.Char -import Data.Monoid -import Control.Monad -import Foreign -import System.Environment -import Debug.Trace - -import CodeGen.X86.Asm -import CodeGen.X86.CodeGen -import CodeGen.X86.CallConv - --------------------------------------------------------------- derived constructs - --- | execute code unless condition is true -unless cc x = mdo - j cc l - x - l <- label - return () - --- | do while loop construction -doWhile cc x = do - l <- label - x - j cc l - --- | if-then-else -if_ cc a b = mdo - j (N cc) l1 - a - jmp l2 - l1 <- label - b - l2 <- label - return () - -leaData r d = mdo - lea r $ ipRel8 l1 - jmp l2 - l1 <- label - db $ toBytes d - l2 <- label - return () - ------------------------------------------------------------------------------- - -foreign import ccall "static stdio.h &printf" printf :: FunPtr a - ------------------------------------------------------------------------------- --- * utils - -mov' :: forall s s' r . IsSize s' => Operand RW s -> Operand r s' -> Code -mov' a b = mov (resizeOperand a :: Operand RW s') b - -newtype CString = CString String - -instance HasBytes CString where - toBytes (CString cs) = mconcat $ toBytes . (fromIntegral :: Int -> Word8) . fromEnum <$> (cs ++ "\0") - --- | we should implement PUSHA and POPA later -all_regs_except_rsp :: [Operand rw S64] -all_regs_except_rsp = [ rax, rcx, rdx, rbx, {- rsp, -} rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 ] - -push_all = sequence_ [ push r | r <- all_regs_except_rsp ] -pop_all = sequence_ [ pop r | r <- reverse all_regs_except_rsp ] - -traceReg :: IsSize s => String -> Operand RW s -> Code -traceReg d r = do - pushf - push_all - mov' arg2 r - leaData arg1 (CString $ show r ++ " = %" ++ s ++ d ++ "\n") - xor_ rax rax - callFun r11 printf - pop_all - popf - where - s = case size r of - S8 -> "hh" - S16 -> "h" - S32 -> "" - S64 -> "l" - +{-# language NoMonomorphismRestriction #-} +{-# language ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language ForeignFunctionInterface #-} +{-# language RecursiveDo #-} +module CodeGen.X86.Utils where + +import Data.Char +import Data.Monoid +import Control.Monad +import Foreign +import System.Environment +import Debug.Trace + +import CodeGen.X86.Asm +import CodeGen.X86.CodeGen +import CodeGen.X86.CallConv + +-------------------------------------------------------------- derived constructs + +-- | execute code unless condition is true +unless cc x = mdo + j cc l + x + l <- label + return () + +-- | do while loop construction +doWhile cc x = do + l <- label + x + j cc l + +-- | if-then-else +if_ cc a b = mdo + j (N cc) l1 + a + jmp l2 + l1 <- label + b + l2 <- label + return () + +leaData r d = mdo + lea r $ ipRel8 l1 + jmp l2 + l1 <- label + db $ toBytes d + l2 <- label + return () + +------------------------------------------------------------------------------ + +foreign import ccall "static stdio.h &printf" printf :: FunPtr a + +------------------------------------------------------------------------------ +-- * utils + +mov' :: forall s s' r . IsSize s' => Operand RW s -> Operand r s' -> Code +mov' a = mov (resizeOperand a :: Operand RW s') + +newtype CString = CString String + +instance HasBytes CString where + toBytes (CString cs) = mconcat $ toBytes . (fromIntegral :: Int -> Word8) . fromEnum <$> (cs ++ "\0") + +-- | we should implement PUSHA and POPA later +{- HLINT ignore all_regs_except_rsp -} +all_regs_except_rsp :: [Operand rw S64] +all_regs_except_rsp = + [ rax + , rcx + , rdx + , rbx + , {- rsp, -} + rbp + , rsi + , rdi + , r8 + , r9 + , r10 + , r11 + , r12 + , r13 + , r14 + , r15 + ] + +{- HLINT ignore push_all -} +push_all = sequence_ [ push r | r <- all_regs_except_rsp ] + +{- HLINT ignore pop_all -} +pop_all = sequence_ [ pop r | r <- reverse all_regs_except_rsp ] + +traceReg :: IsSize s => String -> Operand RW s -> Code +traceReg d r = do + pushf + push_all + mov' arg2 r + leaData arg1 (CString $ show r ++ " = %" ++ s ++ d ++ "\n") + xor_ rax rax + callFun r11 printf + pop_all + popf + where + s = case size r of + S8 -> "hh" + S16 -> "h" + S32 -> "" + S64 -> "l" + diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,4 +1,4 @@ -import CodeGen.X86 - -main = runTests - +import CodeGen.X86.Tests + +main = runTests + diff --git a/x86-64bit.cabal b/x86-64bit.cabal --- a/x86-64bit.cabal +++ b/x86-64bit.cabal @@ -1,87 +1,89 @@ -name: x86-64bit -version: 0.4.5 -homepage: https://github.com/divipp/x86-64 -synopsis: Runtime code generation for x86 64 bit machine code -description: The primary goal of x86-64bit is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. See README.md for further details. -license: BSD3 -license-file: LICENSE -author: Péter Diviánszky -maintainer: divipp@gmail.com -category: Code Generation -build-type: Simple -cabal-version: >=1.10 -stability: Experimental -tested-with: GHC == 8.0.1 -extra-source-files: README.md - CHANGELOG.md - TODO.md - -source-repository head - type: git - location: https://github.com/divipp/x86-64 - -library - exposed-modules: - CodeGen.X86 - CodeGen.X86.Examples - other-modules: - Control.DeeperSeq - CodeGen.X86.Asm - CodeGen.X86.CodeGen - CodeGen.X86.CallConv - CodeGen.X86.FFI - CodeGen.X86.Utils - CodeGen.X86.Tests - - default-language: Haskell2010 - other-extensions: - NoMonomorphismRestriction - LambdaCase - PatternSynonyms - ViewPatterns - TypeSynonymInstances - FlexibleInstances - TypeFamilies - GADTs - RankNTypes - RecordWildCards - DeriveFunctor - DeriveFoldable - DeriveTraversable - DataKinds - GeneralizedNewtypeDeriving - OverloadedStrings - TupleSections - ExistentialQuantification - ScopedTypeVariables - - build-depends: - base >=4.8 && <4.10, - monads-tf >=0.1 && <0.2, - tardis >= 0.4 && <0.5, - vector >=0.11 && <0.12, - QuickCheck >=2.8 && <2.10, - deepseq - - if os(windows) - build-depends: Win32 - - default-language: Haskell2010 - -test-suite test-x86-64bit - type: exitcode-stdio-1.0 - main-is: Test.hs - - build-depends: - base >=4.8 && <4.10, - monads-tf >=0.1 && <0.2, - tardis >= 0.4 && <0.5, - vector >=0.11 && <0.12, - QuickCheck >=2.8 && <2.10, - deepseq - - if os(windows) - build-depends: Win32 - - default-language: Haskell2010 - +name: x86-64bit +version: 0.4.6 +homepage: https://github.com/divipp/x86-64 +synopsis: Runtime code generation for x86 64 bit machine code +description: The primary goal of x86-64bit is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. See README.md for further details. +license: BSD3 +license-file: LICENSE +author: Péter Diviánszky +maintainer: divipp@gmail.com +category: Code Generation +build-type: Simple +cabal-version: >=1.10 +stability: Experimental +tested-with: GHC == 8.0.1 +extra-source-files: README.md + CHANGELOG.md + TODO.md + +source-repository head + type: git + location: https://github.com/divipp/x86-64 + +library + exposed-modules: CodeGen.X86 + other-modules: + Control.DeeperSeq + CodeGen.X86.Asm + CodeGen.X86.CodeGen + CodeGen.X86.CallConv + CodeGen.X86.FFI + CodeGen.X86.Utils + + default-language: Haskell2010 + other-extensions: + NoMonomorphismRestriction + LambdaCase + PatternSynonyms + ViewPatterns + TypeSynonymInstances + FlexibleInstances + TypeFamilies + GADTs + RankNTypes + RecordWildCards + DeriveFunctor + DeriveFoldable + DeriveTraversable + DataKinds + GeneralizedNewtypeDeriving + OverloadedStrings + TupleSections + ExistentialQuantification + ScopedTypeVariables + + build-depends: + base >= 4.8 && <4.14, + monads-tf >= 0.1 && <0.2, + tardis >= 0.4 && <0.5, + vector >= 0.11 && <0.13, + deepseq + + if os(windows) + build-depends: Win32 + +test-suite test-x86-64bit + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + Control.DeeperSeq + CodeGen.X86.Asm + CodeGen.X86.CodeGen + CodeGen.X86.CallConv + CodeGen.X86.FFI + CodeGen.X86.Utils + CodeGen.X86.Tests + + build-depends: + base >= 4.8 && <4.14, + monads-tf >= 0.1 && <0.2, + tardis >= 0.4 && <0.5, + vector >= 0.11 && <0.13, + QuickCheck >= 2.8 && <2.14, + deepseq + + if os(windows) + build-depends: Win32 + + default-language: Haskell2010 +