diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/CodeGen/X86.hs b/CodeGen/X86.hs --- a/CodeGen/X86.hs +++ b/CodeGen/X86.hs @@ -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 diff --git a/CodeGen/X86/Asm.hs b/CodeGen/X86/Asm.hs --- a/CodeGen/X86/Asm.hs +++ b/CodeGen/X86/Asm.hs @@ -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 diff --git a/CodeGen/X86/CallConv.hs b/CodeGen/X86/CallConv.hs --- a/CodeGen/X86/CallConv.hs +++ b/CodeGen/X86/CallConv.hs @@ -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 diff --git a/CodeGen/X86/CodeGen.hs b/CodeGen/X86/CodeGen.hs --- a/CodeGen/X86/CodeGen.hs +++ b/CodeGen/X86/CodeGen.hs @@ -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 diff --git a/CodeGen/X86/Examples.hs b/CodeGen/X86/Examples.hs --- a/CodeGen/X86/Examples.hs +++ b/CodeGen/X86/Examples.hs @@ -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 diff --git a/CodeGen/X86/Tests.hs b/CodeGen/X86/Tests.hs --- a/CodeGen/X86/Tests.hs +++ b/CodeGen/X86/Tests.hs @@ -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 diff --git a/CodeGen/X86/Utils.hs b/CodeGen/X86/Utils.hs --- a/CodeGen/X86/Utils.hs +++ b/CodeGen/X86/Utils.hs @@ -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" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/x86-64bit.cabal b/x86-64bit.cabal --- a/x86-64bit.cabal +++ b/x86-64bit.cabal @@ -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