x86-64bit 0.2 → 0.3
raw patch · 10 files changed
+599/−524 lines, 10 filesdep +tardis
Dependencies added: tardis
Files
- CHANGELOG.md +5/−0
- CodeGen/X86.hs +102/−100
- CodeGen/X86/Asm.hs +49/−51
- CodeGen/X86/CallConv.hs +35/−35
- CodeGen/X86/CodeGen.hs +217/−171
- CodeGen/X86/Examples.hs +35/−25
- CodeGen/X86/Tests.hs +110/−92
- CodeGen/X86/Utils.hs +41/−47
- README.md +2/−2
- x86-64bit.cabal +3/−1
CHANGELOG.md view
@@ -1,3 +1,8 @@+# Version 0.3 + +- simpler API for label handling + (the idea of labels as De-Bruijn indices is abandoned) + # Version 0.2 - simpler API for immediate values: `Add ax, 1`
CodeGen/X86.hs view
@@ -8,30 +8,30 @@ , Size (..) , HasSize (..) , IsSize - -- * Operands - , Access (..) - , Operand - , resizeOperand - -- ** Memory references - , addr - , addr8 - , addr16 - , addr32 - , addr64 - , ipBase - -- ** Registers - -- *** 64 bit registers + -- * Registers + -- ** 64 bit registers , rax, rcx, rdx, rbx, rsp, rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 - -- *** 32 bit registers + -- ** 32 bit registers , eax, ecx, edx, ebx, esp, ebp, esi, edi, r8d, r9d, r10d, r11d, r12d, r13d, r14d, r15d - -- *** 16 bit registers + -- ** 16 bit registers , ax, cx, dx, bx, sp, bp, si, di, r8w, r9w, r10w, r11w, r12w, r13w, r14w, r15w - -- *** 8 bit low registers + -- ** 8 bit low registers , al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b - -- *** 8 bit high registers + -- ** 8 bit high registers , ah, ch, dh, bh - -- *** SSE registers + -- ** SSE registers , xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7 + -- * Addresses + , addr + , addr8 + , addr16 + , addr32 + , addr64 + , ipBase + -- * Operands + , Access (..) + , Operand + , resizeOperand -- * Conditions , Condition , pattern O @@ -50,100 +50,102 @@ , pattern NL , pattern NG, pattern LE , pattern G, pattern NLE - -- * Assembly codes - , Code - , pattern Ret - , pattern Nop - , pattern PushF - , pattern PopF - , pattern Cmc - , pattern Clc - , pattern Stc - , pattern Cli - , pattern Sti - , pattern Cld - , pattern Std - , pattern Inc - , pattern Dec - , pattern Not - , pattern Neg - , pattern Add - , pattern Or - , pattern Adc - , pattern Sbb - , pattern And - , pattern Sub - , pattern Xor - , pattern Cmp - , pattern Test - , pattern Mov - , pattern Cmov - , pattern Rol - , pattern Ror - , pattern Rcl - , pattern Rcr - , pattern Shl - , pattern Shr - , pattern Sar - , pattern Xchg - , pattern Movd - , pattern Movq - , pattern Movdqa - , pattern Paddb - , pattern Paddw - , pattern Paddd - , pattern Paddq - , pattern Psubb - , pattern Psubw - , pattern Psubd - , pattern Psubq - , pattern Pxor - , pattern Psllw - , pattern Pslld - , pattern Psllq - , pattern Pslldq - , pattern Psrlw - , pattern Psrld - , pattern Psrlq - , pattern Psrldq - , pattern Psraw - , pattern Psrad - , pattern Lea - , pattern J - , pattern Pop - , pattern Push - , pattern Call - , pattern Jmpq - , pattern Jmp - , pattern Data - , pattern Align - , pattern Label - , pattern Scope - , pattern Up - -- * Compound assembly codes - , (<>) - , (<.>), (<:>) - , jmp, jmp_back, jmp8, jmp32 - , j, j8, j32 - , j_back, j_back8, j_back32 + -- * Instructions + , Code, CodeM + -- ** Pseudo instructions + , db + , align + , Label + , label + -- ** Control + , j + , jmp + , jmpq + , call + , ret + -- ** Flags + , cmc + , clc + , stc + , cli + , sti + , cld + , std + , pushf + , popf + , cmp + , test + -- ** Arithmetic + , inc + , dec + , not_ + , neg + , add + , adc + , sub + , sbb + , and_ + , or_ + , xor_ + , rol + , ror + , rcl + , rcr + , shl + , shr + , sar + , lea + -- ** Other + , nop + , xchg + , mov + , cmov + , pop + , push + -- ** SSE + , movd + , movq + , movdqa + , paddb + , paddw + , paddd + , paddq + , psubb + , psubw + , psubd + , psubq + , pxor + , psllw + , pslld + , psllq + , pslldq + , psrlw + , psrld + , psrlq + , psrldq + , psraw + , psrad + -- * Compound instructions + , unless + , doWhile , if_ - , lea8 , leaData + , traceReg -- * Compilation , Callable , compile - -- * Calling C and Haskell from Assembly - , callFun + -- * Calling convention , saveNonVolatile , arg1, arg2, arg3, arg4 , result + -- * Calling C and Haskell from Assembly + , callFun + , printf , CallableHs , hsPtr + , CString (..) -- * Misc , runTests - , CString (..) - , traceReg - , printf ) where import Data.Monoid
CodeGen/X86/Asm.hs view
@@ -46,24 +46,14 @@ ------------------------------------------------------- byte sequences -newtype Bytes = Bytes {getBytes :: [Word8]}- deriving (Eq, Monoid)--instance Show Bytes where- show (Bytes ws) = unwords $ map (concatMap showByte) $ everyNth 4 ws--showBytes (Bytes ws) = unlines $ zipWith showLine [0 ::Int ..] $ everyNth 16 ws- where- showLine n bs = [showNibble 2 n, showNibble 1 n, showNibble 0 n, '0', ' ', ' '] ++ show (Bytes bs)--bytesCount (Bytes x) = length x+type Bytes = [Word8] class HasBytes a where toBytes :: a -> Bytes -instance HasBytes Word8 where toBytes w = Bytes [w]-instance HasBytes Word16 where toBytes w = Bytes [fromIntegral w, fromIntegral $ w `shiftR` 8]-instance HasBytes Word32 where toBytes w = Bytes [fromIntegral $ w `shiftR` n | n <- [0, 8.. 24]]-instance HasBytes Word64 where toBytes w = Bytes [fromIntegral $ w `shiftR` n | n <- [0, 8.. 56]]+instance HasBytes 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)@@ -177,24 +167,32 @@ addr :: IsSize s => Address s -> Operand rw s' addr = MemOp . makeAddr +-- | `addr` with specialized type addr8 :: IsSize s => Address s -> Operand rw S8 addr8 = addr +-- | `addr` with specialized type addr16 :: IsSize s => Address s -> Operand rw S16 addr16 = addr +-- | `addr` with specialized type addr32 :: IsSize s => Address s -> Operand rw S32 addr32 = addr +-- | `addr` with specialized type addr64 :: IsSize s => Address s -> Operand rw S64 addr64 = addr data Immediate a = Immediate a- | LabelRelValue Size{-size hint-} !LabelIndex+ | LabelRelValue Size{-size hint-} Label -type LabelIndex = Int+-- Type of labels+newtype Label = Label {unLabel :: Int} +instance Show Label where+ show (Label i) = ".l" ++ show i+ -- | Operand access modes data Access = R -- ^ readable operand@@ -224,7 +222,7 @@ pattern NoIndex = Nothing pattern IndexReg a b = Just (a, b) -ipBase = IPMemOp $ LabelRelValue S32 0+ipBase l = IPMemOp $ LabelRelValue S32 l instance IsSize s => Show (Reg s) where show = \case@@ -260,20 +258,18 @@ f False = " - " instance IsSize s => Show (Operand a s) where- show = showOperand show--showOperand mklab = \case- ImmOp w -> showImm w- RegOp r -> show r- r@(MemOp a) -> show (size r) ++ " [" ++ show a ++ "]"- r@(IPMemOp x) -> show (size r) ++ " [" ++ "rel " ++ showImm x ++ "]"- where- showp x | x < 0 = " - " ++ show (-x)- showp x = " + " ++ show x+ 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 - showImm :: Show a => Immediate a -> String- showImm (Immediate x) = show x- showImm (LabelRelValue _ x) = mklab x+instance Show a => Show (Immediate a) where+ show (Immediate x) = show x+ show (LabelRelValue s x) = show x instance IsSize s => HasSize (Operand a s) where size _ = size (ssize :: SSize s)@@ -293,12 +289,14 @@ instance IsSize s => HasSize (IndexReg s) where size _ = size (ssize :: SSize s) -imm :: (Integral a, Bits a) => a -> Operand R s-imm (Integral x) = ImmOp $ Immediate x- instance (rw ~ R) => Num (Operand rw s) where- negate (ImmOp (Immediate x)) = imm (negate x)- fromInteger = imm+ negate (ImmOp (Immediate x)) = ImmOp $ Immediate $ negate x+ fromInteger (Integral x) = ImmOp $ Immediate x+ (+) = error "(+) @Operand"+ (-) = error "(-) @Operand"+ (*) = error "(*) @Operand"+ abs = error "abs @Operand"+ signum = error "signum @Operand" instance Monoid (Addr s) where mempty = Addr (getFirst mempty) (getFirst mempty) (getFirst mempty)@@ -347,6 +345,8 @@ 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@@ -549,8 +549,8 @@ Call_ :: Operand RW S64 -> CodeLine Jmpq_ :: Operand RW S64 -> CodeLine - J_ :: Condition -> Maybe Size -> CodeLine- Jmp_ :: Maybe Size -> CodeLine+ J_ :: Condition -> Maybe Size -> Label -> CodeLine+ Jmp_ :: Maybe Size -> Label -> CodeLine Label_ :: CodeLine @@ -559,21 +559,19 @@ ------------------------- show code lines -getLabel i = ($ i) <$> getLabels--getLabels = f <$> ask- where- f xs i = case drop i xs of- [] -> ".l?"- (i: _) -> ".l" ++ show i+newLabel = do+ i <- get+ put $ i + 1+ return $ Label i codeLine x = tell [x] showOp0 s = codeLine s showOp s a = showOp0 $ s ++ " " ++ a-showOp1 s a = getLabels >>= \f -> showOp s $ showOperand f a-showOp2 s a b = getLabels >>= \f -> showOp s $ showOperand f a ++ ", " ++ showOperand f b+showOp1 s a = showOp s $ show a+showOp2 s a b = showOp s $ show a ++ ", " ++ show b +showCodeLine :: CodeLine -> StateT Int (Writer [String]) () showCodeLine = \case Add_ op1 op2 -> showOp2 "add" op1 op2 Or_ op1 op2 -> showOp2 "or" op1 op2@@ -638,13 +636,13 @@ Std_ -> showOp0 "std" Align_ s -> codeLine $ ".align " ++ show s- Data_ (Bytes x)+ 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 -> getLabel 0 >>= \l -> showOp ("j" ++ show cc) $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ l- Jmp_ s -> getLabel 0 >>= \l -> showOp "jmp" $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ l- Label_ -> getLabel 0 >>= codeLine+ 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
CodeGen/X86/CallConv.hs view
@@ -18,34 +18,34 @@ -- 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 - = Sub rsp 32- <> Mov r (imm $ ptrToIntPtr $ castFunPtrToPtr p)- <> Call r - <> Add rsp 32+callFun r p = do+ sub rsp 32+ mov r (imm $ 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 - = 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 (imm $ ptrToIntPtr $ castFunPtrToPtr p)- <> Call r - <> Mov rsp r15 -- restore rsp- <> Pop r15 -- restore r15+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 (imm $ 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 - = Mov r (imm $ ptrToIntPtr $ castFunPtrToPtr p)- <> Call r+callFun r p = do+ mov r $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p+ call r #endif @@ -57,7 +57,7 @@ -- This is the responsability of the user (this won't save them). -- saveNonVolatile :: Code -> Code-saveNonVolatile code = prologue <> code <> epilogue <> Ret+saveNonVolatile code = prologue >> code >> epilogue >> ret ------------------------------------------------------------------------------ -- calling conventions@@ -74,17 +74,17 @@ result = rax -prologue - = Push rbp- <> Push rbx- <> Push rdi- <> Push rsi+prologue = do+ push rbp+ push rbx+ push rdi+ push rsi -epilogue- = Pop rsi- <> Pop rdi- <> Pop rbx- <> Pop rbp +epilogue = do+ pop rsi+ pop rdi+ pop rbx+ pop rbp #else @@ -100,13 +100,13 @@ result = rax -prologue - = Push rbp- <> Push rbx+prologue = do+ push rbp+ push rbx -epilogue- = Pop rbx- <> Pop rbp +epilogue = do+ pop rbx+ pop rbp #endif
CodeGen/X86/CodeGen.hs view
@@ -14,6 +14,7 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GeneralizedNewtypeDeriving #-}+{-# language RecursiveDo #-} module CodeGen.X86.CodeGen where import Numeric@@ -27,6 +28,7 @@ import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State+import Control.Monad.Tardis import Debug.Trace import CodeGen.X86.Asm@@ -83,87 +85,110 @@ ------------------------------------------------------- code builder -data CodeBuilder- = CodeBuilder !Int !Int (CodeBuilderState -> (CodeBuilderRes, CodeBuilderState))--pattern ExactCodeBuilder len f <- (getExactCodeBuilder -> Just (len, f))- where ExactCodeBuilder len f = CodeBuilder len len $ \st@(n, _) -> second ((,) (n + len)) $ f st--getExactCodeBuilder (CodeBuilder i j f) | i == j = Just (i, second snd . f)-getExactCodeBuilder _ = Nothing--codeBuilderLength (ExactCodeBuilder len _) = len--buildCode :: CodeBuilder -> CodeBuilderState -> (CodeBuilderRes, CodeBuilderState)-buildCode (CodeBuilder _ _ f) st = f st--mapLabelState g (CodeBuilder i j f) = CodeBuilder i j $ \(n, g -> (fx, xs)) -> second (second fx) $ f (n, xs)+type CodeBuilderRes = [Either Int (Int, Word8)] -censorCodeBuilder g (CodeBuilder i j f) = CodeBuilder i j $ \st -> first (g st) $ f st+type CodeBuilderTardis = Tardis (Int, [Int]) (Int, [Int], LabelState) -type CodeBuilderRes = [Either Int (Int, Word8)]+data CodeBuilder = CodeBuilder+ { minLen, maxLen :: Int+ , getCodeBuilder :: WriterT CodeBuilderRes CodeBuilderTardis ()+ } -type CodeBuilderState = (Int, LabelState)+codeBuilderLength (CodeBuilder a b _) | a == b = a -type LabelState = [Either [(Size, Int, Int)] Int]+type LabelState = [[(Size, Int, Int)]] instance Monoid CodeBuilder where- mempty = ExactCodeBuilder 0 $ \(_, st) -> (mempty, st)- f `mappend` g = CodeBuilder (i1+i2) (j1+j2) $ \(buildCode f -> (a, buildCode g -> (b, st))) -> (a ++ b, st)- where- (i1, j1) = bounds f- (i2, j2) = bounds g+ mempty = CodeBuilder 0 0 $ return ()+ CodeBuilder mi ma a `mappend` CodeBuilder mi' ma' b = CodeBuilder (min mi mi') (max ma ma') $ a >> b -bounds (CodeBuilder i j _) = (i, j)+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+ where+ n = length bs codeByte :: Word8 -> CodeBuilder-codeByte c = ExactCodeBuilder 1 $ \(n, labs) -> ([Right (n, c)], labs)+codeByte = codeBytes . (:[]) -mkRef :: Size -> Int -> Int -> CodeBuilder-mkRef s@(sizeLen -> sn) offset bs = ExactCodeBuilder sn f- where- f (n, labs) | bs >= length labs = error "missing scope"- f (n, labs) = case labs !! bs of- Right i -> (Right <$> zip [n..] z, labs)- where+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 = getBytes $ case s of+ 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"- Left cs -> (mempty, labs')- where- labs' = take bs labs ++ Left ((s, n, - n - offset): cs): drop (bs + 1) labs+ ~(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 -mkAutoRef :: [(Size, Bytes)] -> Int -> Int -> CodeBuilder-mkAutoRef ss offset bs = CodeBuilder (minimum sizes) (maximum sizes) f- where- sizes = map (\(s, c) -> sizeLen s + bytesCount c) ss+ins :: Int -> a -> [[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 - f (n, labs) | bs >= length labs = error "missing scope"- f (n, labs) = case labs !! bs of- Left cs -> error "auto length computation for forward references is not supported"- Right i -> (Right <$> zip [n..] z, (n + length z, labs))- where- vx = i - n - offset+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 - bytesCount c - sizeLen s) of- (S8, Integral j) -> getBytes $ c <> toBytes (j :: Int8)- (S32, Integral j) -> getBytes $ c <> toBytes (j :: Int32)+ 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' - length c - sizeLen s) 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 ------------------------------------------------------- code to code builder instance Show Code where+ 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 . flip runReaderT [] . showCode $ c- (x, s) = second fst $ buildCode (mkCodeBuilder c) (0, replicate 10{-TODO-} $ Left [])+ ss = snd . runWriter . flip evalStateT 0 . showCode $ c+ (x, s) = buildCode c bs = V.toList $ V.replicate s 0 V.// [p | Right p <- x] is = [i | Left i <- x] @@ -174,29 +199,34 @@ maxbytes = 12 +{- codeBytes c = Bytes $ V.toList $ V.replicate s 0 V.// [p | Right p <- x] where (x, s) = buildTheCode c--buildTheCode x = second fst $ buildCode (mkCodeBuilder x) (0, [])+-}+buildTheCode :: Code -> (CodeBuilderRes, Int)+buildTheCode = buildCode . withLabels -bytesToCodeBuilder :: Bytes -> CodeBuilder-bytesToCodeBuilder x = ExactCodeBuilder (bytesCount x) $ \(n, labs) -> (Right <$> zip [n..] (getBytes x), labs)+buildCode :: LCode -> (CodeBuilderRes, Int)+buildCode x = (r, len)+ where+ ((_, r), (_, (len, _, _))) = flip runTardis ((0, []), (0, [], [])) . runWriterT . getCodeBuilder . mkCodeBuilder $ x -mkCodeBuilder :: Code -> CodeBuilder+mkCodeBuilder :: LCode -> CodeBuilder mkCodeBuilder = \case+ CodeLine x _ -> x+ Group x _ -> x+ AppendCode x _ _ -> x EmptyCode -> mempty- AppendCode cb _ _ -> cb - Up a -> mapLabelState (\(x: xs) -> ((x:), xs)) $ mkCodeBuilder a+newtype CodeM a = CodeM {unCodeM :: StateT Int (Writer LCode) a}+ deriving (Functor, Applicative, Monad, MonadFix) - Scope x -> ExactCodeBuilder 0 begin <> mkCodeBuilder x <> ExactCodeBuilder 0 end- where- begin (n, labs) = (mempty, Left []: labs)- end (n, Right _: labs) = (mempty, labs)- end (n, _: labs) = trace "warning: missing label" (mempty, labs)+type Code = CodeM () - CodeLine_ cb _ -> censorCodeBuilder (\(addr, _) -> (Left addr:)) cb+withLabels :: Code -> LCode+withLabels =+ snd . runWriter . flip evalStateT 0 . unCodeM mkCodeBuilder' :: CodeLine -> CodeBuilder mkCodeBuilder' = \case@@ -295,36 +325,46 @@ Cld_ -> codeByte 0xfc Std_ -> codeByte 0xfd - J_ (Condition c) (Just S8) -> codeByte (0x70 .|. c) <> mkRef S8 1 0- J_ (Condition c) (Just S32) -> codeByte 0x0f <> codeByte (0x80 .|. c) <> mkRef S32 4 0- J_ (Condition c) Nothing -> mkAutoRef [(S8, Bytes [0x70 .|. c]), (S32, Bytes [0x0f, 0x80 .|. c])] 0 0+ 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) -> codeByte 0xeb <> mkRef S8 1 0- Jmp_ (Just S32) -> codeByte 0xe9 <> mkRef S32 4 0- Jmp_ Nothing -> mkAutoRef [(S8, Bytes [0xeb]), (S32, Bytes [0xe9])] 0 0+ 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 - Label_ -> ExactCodeBuilder 0 lab- where- lab :: CodeBuilderState -> (CodeBuilderRes, LabelState)- lab (n, labs) = (Right <$> concatMap g corr, labs')- where- (corr, labs') = replL (Right n) labs+ 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 - g (size, p, v) = zip [p..] $ getBytes $ 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 - replL x (Left z: zs) = (z, x: zs)- replL x (z: zs) = second (z:) $ replL x zs+ Data_ x -> codeBytes x - Data_ x -> bytesToCodeBuilder x- Align_ s -> CodeBuilder 0 s $ \(n, labs) -> let- n' = fromIntegral $ ((fromIntegral n - 1 :: Int64) .|. (fromIntegral s - 1)) + 1- in (Right <$> zip [n..] (replicate (n' - n) 0x90), (n', labs))+ 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..] $ replicate (n' - n) 0x90+ tell $ Right <$> bs+ where convertImm :: Bool{-signed-} -> Size -> Operand r s -> First ((Bool, Size), CodeBuilder)- convertImm a b (ImmOp (Immediate c)) = First $ (,) (a, b) . bytesToCodeBuilder <$> integralToBytes a b c+ 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 @@ -338,7 +378,7 @@ xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty toCode :: HasBytes a => a -> CodeBuilder- toCode = bytesToCodeBuilder . toBytes+ toCode = codeBytes . toBytes sizePrefix_ :: [SReg] -> Size -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder sizePrefix_ rs s r x c im@@ -480,96 +520,102 @@ -------------------------------------------------------------- asm codes -data Code where- Scope :: Code -> Code- Up :: Code -> Code- EmptyCode :: Code- AppendCode :: CodeBuilder -> Code -> Code -> Code- CodeLine_ :: CodeBuilder -> CodeLine -> Code+data LCode where+ Group :: CodeBuilder -> LCode -> LCode+ EmptyCode :: LCode+ AppendCode :: CodeBuilder -> LCode -> LCode -> LCode+ CodeLine :: CodeBuilder -> CodeLine -> LCode -instance Monoid Code where+instance Monoid LCode where mempty = EmptyCode mappend a b = AppendCode (mkCodeBuilder a <> mkCodeBuilder b) a b -pattern CodeLine x <- CodeLine_ _ x- where CodeLine x = CodeLine_ (mkCodeBuilder' x) x+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)+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)+movd a b = mkCodeLine (Movd_ a b)+movq a b = mkCodeLine (Movq_ a b)+movdqa a b = mkCodeLine (Movdqa_ a b)+paddb a b = mkCodeLine (Paddb_ a b)+paddw a b = mkCodeLine (Paddw_ a b)+paddd a b = mkCodeLine (Paddd_ a b)+paddq a b = mkCodeLine (Paddq_ a b)+psubb a b = mkCodeLine (Psubb_ a b)+psubw a b = mkCodeLine (Psubw_ a b)+psubd a b = mkCodeLine (Psubd_ a b)+psubq a b = mkCodeLine (Psubq_ a b)+pxor a b = mkCodeLine (Pxor_ a b)+psllw a b = mkCodeLine (Psllw_ a b)+pslld a b = mkCodeLine (Pslld_ a b)+psllq a b = mkCodeLine (Psllq_ a b)+pslldq a b = mkCodeLine (Pslldq_ a b)+psrlw a b = mkCodeLine (Psrlw_ a b)+psrld a b = mkCodeLine (Psrld_ a b)+psrlq a b = mkCodeLine (Psrlq_ a b)+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) -pattern Ret = CodeLine Ret_-pattern Nop = CodeLine Nop_-pattern PushF = CodeLine PushF_-pattern PopF = CodeLine PopF_-pattern Cmc = CodeLine Cmc_-pattern Clc = CodeLine Clc_-pattern Stc = CodeLine Stc_-pattern Cli = CodeLine Cli_-pattern Sti = CodeLine Sti_-pattern Cld = CodeLine Cld_-pattern Std = CodeLine Std_-pattern Inc a = CodeLine (Inc_ a)-pattern Dec a = CodeLine (Dec_ a)-pattern Not a = CodeLine (Not_ a)-pattern Neg a = CodeLine (Neg_ a)-pattern Add a b = CodeLine (Add_ a b)-pattern Or a b = CodeLine (Or_ a b)-pattern Adc a b = CodeLine (Adc_ a b)-pattern Sbb a b = CodeLine (Sbb_ a b)-pattern And a b = CodeLine (And_ a b)-pattern Sub a b = CodeLine (Sub_ a b)-pattern Xor a b = CodeLine (Xor_ a b)-pattern Cmp a b = CodeLine (Cmp_ a b)-pattern Test a b = CodeLine (Test_ a b)-pattern Mov a b = CodeLine (Mov_ a b)-pattern Cmov c a b = CodeLine (Cmov_ c a b)-pattern Rol a b = CodeLine (Rol_ a b)-pattern Ror a b = CodeLine (Ror_ a b)-pattern Rcl a b = CodeLine (Rcl_ a b)-pattern Rcr a b = CodeLine (Rcr_ a b)-pattern Shl a b = CodeLine (Shl_ a b)-pattern Shr a b = CodeLine (Shr_ a b)-pattern Sar a b = CodeLine (Sar_ a b)-pattern Xchg a b = CodeLine (Xchg_ a b)-pattern Movd a b = CodeLine (Movd_ a b)-pattern Movq a b = CodeLine (Movq_ a b)-pattern Movdqa a b = CodeLine (Movdqa_ a b)-pattern Paddb a b = CodeLine (Paddb_ a b)-pattern Paddw a b = CodeLine (Paddw_ a b)-pattern Paddd a b = CodeLine (Paddd_ a b)-pattern Paddq a b = CodeLine (Paddq_ a b)-pattern Psubb a b = CodeLine (Psubb_ a b)-pattern Psubw a b = CodeLine (Psubw_ a b)-pattern Psubd a b = CodeLine (Psubd_ a b)-pattern Psubq a b = CodeLine (Psubq_ a b)-pattern Pxor a b = CodeLine (Pxor_ a b)-pattern Psllw a b = CodeLine (Psllw_ a b)-pattern Pslld a b = CodeLine (Pslld_ a b)-pattern Psllq a b = CodeLine (Psllq_ a b)-pattern Pslldq a b = CodeLine (Pslldq_ a b)-pattern Psrlw a b = CodeLine (Psrlw_ a b)-pattern Psrld a b = CodeLine (Psrld_ a b)-pattern Psrlq a b = CodeLine (Psrlq_ a b)-pattern Psrldq a b = CodeLine (Psrldq_ a b)-pattern Psraw a b = CodeLine (Psraw_ a b)-pattern Psrad a b = CodeLine (Psrad_ a b)-pattern Lea a b = CodeLine (Lea_ a b)-pattern J a b = CodeLine (J_ a b)-pattern Pop a = CodeLine (Pop_ a)-pattern Push a = CodeLine (Push_ a)-pattern Call a = CodeLine (Call_ a)-pattern Jmpq a = CodeLine (Jmpq_ a)-pattern Jmp a = CodeLine (Jmp_ a)-pattern Data a = CodeLine (Data_ a)-pattern Align a = CodeLine (Align_ a)-pattern Label = CodeLine (Label_)+label :: CodeM Label+label = do+ 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]+ ------------- + showCode = \case EmptyCode -> return () AppendCode _ a b -> showCode a >> showCode b-- Scope c -> get >>= \i -> put (i+1) >> local (i:) (showCode c)-- Up c -> local tail $ showCode c-- CodeLine x -> showCodeLine x+ Group _ c -> codeLine "{" >> showCode c >> codeLine "}"+ CodeLine _ x -> showCodeLine x
CodeGen/X86/Examples.hs view
@@ -12,39 +12,48 @@ -- Input: @rdi@ on Linux \/ System V, @rcx@ on Win64 -- -- Output: @rax@ -idCode - = Mov result arg1 - <> Ret +idCode = do + mov result arg1 + ret idFun :: Word64 -> Word64 idFun = compile idCode -- | Example: Fibonacci function in Assembly -fibCode = saveNonVolatile - $ Mov rdi arg1 - <> Inc rdi - <> Xor rdx rdx - <> Mov rax 1 - <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> Dec rdi) `j_back` NZ +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 - $ Mov rdi arg1 - <> Inc rdi - <> Xor rdx rdx - <> Mov rax 1 - <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> traceReg "d" rax {- <> traceReg "d" rdi -} <> Dec rdi) `j_back` NZ +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 - = callFun r11 (hsPtr fib) - <> Ret +callHsCode = do + callFun r11 (hsPtr fib) + ret fib :: Word64 -> Word64 fib n = go n 0 1 @@ -57,11 +66,11 @@ -- | Example: call C @printf@ function from Assembly -- -callCCode name = saveNonVolatile - $ leaData arg1 (CString "Hello %s!\n") - <> leaData arg2 (CString name) - <> Xor rax rax -- zero XMM arguments ????? - <> callFun r11 printf +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 @@ -72,8 +81,9 @@ memTestFun v = do r <- mallocBytes 8 -- this is not required to be aligned (and in any case malloc aligns to machine words) pokeByteOff r 0 (v :: Word64) - let code = saveNonVolatile - $ Mov rdi arg1 <> Mov rax (addr rdi) + let code = saveNonVolatile $ do + mov rdi arg1 + mov rax (addr rdi) return $ compile code r == v
CodeGen/X86/Tests.hs view
@@ -14,6 +14,7 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GeneralizedNewtypeDeriving #-} +{-# language RecursiveDo #-} {-# LANGUAGE TemplateHaskell #-} module CodeGen.X86.Tests (runTests) where @@ -24,7 +25,7 @@ import Data.Int import Data.Word -import Test.QuickCheck hiding ((.&.)) +import Test.QuickCheck hiding ((.&.), label) import Debug.Trace import CodeGen.X86.Asm @@ -99,7 +100,7 @@ genRegs = RegOp <$> arbitrary -genIPBase = pure ipBase +genIPBase = pure $ ipBase $ Label 0 instance Arbitrary (Addr S64) where arbitrary = suchThat (Addr <$> base <*> disp <*> index) ok @@ -132,34 +133,34 @@ instance IsSize s => Arbitrary (Operand R s) where arbitrary = oneof - [ imm <$> oneof (arbVal <$> [S8, S16, S32, S64]) + [ fromIntegral <$> oneof (arbVal <$> [S8, S16, S32, S64]) , genRegs , genMems , genIPBase ] -instance Arbitrary Code where +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 + [ 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 -> Code) -> Gen Code + 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 @@ -167,10 +168,10 @@ , f op (arbitrary :: Gen (Operand RW S64)) arbitrary ] where - f :: forall s . IsSize s => (Operand RW s -> Operand R s -> Code) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen Code + 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 -> Code) -> Gen Code + 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 @@ -178,10 +179,10 @@ , f op (arbitrary :: Gen (Operand RW S64)) arbitrary ] where - f :: forall s . IsSize s => (Operand RW s -> Operand R s -> Code) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen Code + 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 -> Code) -> Gen Code + 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 @@ -190,11 +191,11 @@ ] where arb = oneof - [ imm <$> (arbitrary :: Gen Word8) + [ fromIntegral <$> (arbitrary :: Gen Word8) , return cl ] - f :: forall s . IsSize s => (Operand RW s -> Operand R S8 -> Code) -> Gen (Operand RW s) -> Gen (Operand R S8) -> Gen Code + 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 @@ -212,25 +213,25 @@ --------------------------------------------------- -evalOp :: forall a . (HasSigned a, Integral a, Integral (Signed a), FiniteBits (Signed a), Num a, FiniteBits a) => Code -> Bool -> a -> a -> ((Bool, Bool), a) +evalOp :: 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) + 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) @@ -271,7 +272,7 @@ arbitrary = do i <- arbitrary cF <- arbitrary - let fff :: forall s s' r . (IsSize s, IsSize s') => Code -> (Operand RW s -> Operand r s' -> Code) -> Operand RW s -> Operand r s' -> Gen InstrTest + 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] @@ -291,85 +292,102 @@ (av, bv, initab) <- ff a b let - code = foldMap Push sr <> Mov f1 rsp <> PushF <> Pop rax <> Push rax <> PopF - <> initab (initcf <> cc <> mova) <> mkRes - <> Mov rsp f1 {- <> traceReg "X" rdx' -} <> foldMap Pop (reverse sr) <> Ret + 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 = i - initcf = if cF then Stc else Clc + cc = mkCodeLine i + initcf = if cF then stc else clc mova = case a of - RegOp (NormalReg 0x2) -> mempty - _ -> Mov rdx' a - mkRes = otest cc (if_ (if cF' then C else NC) (Xor rax rax) (Xor rax rax <> Mov rcx res <> Cmp rcx' rdx' <> j NZ (Inc rax))) + 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 + 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 + 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 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word8) - S16 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word16) - S32 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word32) - S64 -> imm <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word64) + 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 i, "code: " ++ show cc, "input a: " ++ show av, "input b: " ++ show bv, "input flags: " ++ show cF, "output: " ++ show res, "output flags: " ++ show cF' ++ " " ++ show oF'] + 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 i $ IT msg code + 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_ + 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) (imm v) <>)) + return (v, (mov (RegOp x) (fromIntegral v) >>)) mkVal helper x@(IPMemOp LabelRelValue{}) = do v <- arbVal $ size x - return (v, \c -> Scope $ Up jmp8 {- <> align (size x) -} <:> Data (toBytes v) <.> c) + 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, mempty) + NoIndex -> return (0, return ()) IndexReg sc i -> do x <- arbVal $ size i - return (scaleFactor sc * x, Mov (RegOp i) (imm x)) + 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 (imm d') <> Sub rx helper <> setvi) <>)) + return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper >> setvi) >>)) mkVal helper o@(MemOp (Addr Nothing d (Just (sc, x)))) = do v <- arbVal $ size o let @@ -377,7 +395,7 @@ NoDisp -> 0 :: Int64 Disp v -> fromIntegral v rx = resizeOperand $ RegOp x :: Operand RW S64 - return (v, ((leaData rx v <> Mov helper (imm d') <> Sub rx helper) <>)) + return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper) >>)) propInstr (IT _ c) = compile c :: Bool
CodeGen/X86/Utils.hs view
@@ -4,6 +4,7 @@ {-# language ScopedTypeVariables #-} {-# language DataKinds #-} {-# language ForeignFunctionInterface #-} +{-# language RecursiveDo #-} module CodeGen.X86.Utils where import Data.Char @@ -19,51 +20,39 @@ -------------------------------------------------------------- derived constructs -(<.>) :: Code -> Code -> Code -a <.> b = a <> Label <> b - -a <:> b = Scope $ a <.> b - -infixr 5 <:>, <.> - --- | auto size backward jump -jmp_back = Jmp Nothing - --- | auto size jump; the extra argument is the code between the jump and the label -jmp x = if snd (bounds $ mkCodeBuilder x) <= 127 then jmp8 else jmp32 - --- | short jump -jmp8 = Jmp $ Just S8 - --- | near jump -jmp32 = Jmp $ Just S32 - --- | auto size conditional forward jump -j c x = if snd (bounds $ mkCodeBuilder x) <= 127 then j8 c x else j32 c x - --- | short conditional forward jump -j8 c x = J c (Just S8) <> Up x <:> mempty - --- | near conditional forward jump -j32 c x = J c (Just S32) <> Up x <:> mempty - --- | auto size conditional backward jump -x `j_back` c = mempty <:> Up x <> J c Nothing - --- | short conditional backward jump -x `j_back8` c = mempty <:> Up x <> J c (Just S8) +-- | execute code unless condition is true +unless cc x = mdo + j cc l + x + l <- label + return () --- | near conditional backward jump -x `j_back32` c = mempty <:> Up x <> J c (Just S32) +-- | do while loop construction +doWhile cc x = do + l <- label + x + j cc l -if_ c a b = (J c (Just S8) <> Up (Up a <> jmp b) <:> mempty) <> Up b <:> mempty +-- | if-then-else +if_ cc a b = mdo + j cc l1 + a + jmp l2 + l1 <- label + b + l2 <- label + return () lea8 :: IsSize s => Operand RW s -> Operand RW S8 -> Code -lea8 = Lea +lea8 = lea -leaData r d = (lea8 r ipBase <> Up (jmp db) <:> mempty) <> db <:> mempty - where - db = Data (toBytes d) +leaData r d = mdo + lea8 r $ ipBase l1 + jmp l2 + l1 <- label + db $ toBytes d + l2 <- label + return () ------------------------------------------------------------------------------ @@ -73,7 +62,7 @@ -- * 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 +mov' a b = mov (resizeOperand a :: Operand RW s') b newtype CString = CString String @@ -84,14 +73,19 @@ 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 = mconcat [ Push r | r <- all_regs_except_rsp ] -pop_all = mconcat [ Pop r | r <- reverse all_regs_except_rsp ] +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 = - PushF <> push_all - <> mov' arg2 r <> leaData arg1 (CString $ show r ++ " = %" ++ s ++ d ++ "\n") <> Xor rax rax <> callFun r11 printf - <> pop_all <> PopF +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"
README.md view
@@ -5,9 +5,9 @@ Features: - The size of operands are statically checked. For example, exchanging `rax` with `eax` raises a compile time error rather than a code-generation time error. As a consequence, code generation is faster because the sizes are statically known. -- Immediate values are automatically converted to smaller size if possible. -- De Bruijn indices are used instead of named labels - Quickcheck tests: You can quickcheck your x86 processor! Please report failures, there is a higher chance that the error is in this library rather than in your processor. +- Immediate values are automatically converted to smaller size if possible. +- Automatic calculation of short and near distances The package is available on HackageDB: http://hackage.haskell.org/package/x86-64bit
x86-64bit.cabal view
@@ -1,5 +1,5 @@ name: x86-64bit -version: 0.2 +version: 0.3 homepage: https://github.com/divipp/x86-64 synopsis: Runtime code generation for x86 64 bit machine code description: The primary goal of x86-64bit is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. See README.md for further details. @@ -56,6 +56,7 @@ 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 @@ -71,6 +72,7 @@ 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