x86-64bit 0.1.4 → 0.2

raw patch · 11 files changed

+698/−319 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• CodeGen/X86.hs +95/−9
• CodeGen/X86/Asm.hs +245/−146
• CodeGen/X86/CallConv.hs +12/−10
• CodeGen/X86/CodeGen.hs +250/−107
• CodeGen/X86/Examples.hs +3/−3
• CodeGen/X86/FFI.hs +18/−0
• CodeGen/X86/Tests.hs +29/−29
• CodeGen/X86/Utils.hs +29/−14
• TODO.md +1/−0
• x86-64bit.cabal +1/−1

@@ -1,3 +1,18 @@+# Version 0.2
+
+-   simpler API for immediate values: `Add ax, 1`
+-   redesigned addressing API: `Add ax (addr $ rax + 4*rdi + 3)`
+-   support near jumps
+-   support automatic decision between short and near jumps (conditional jumps too)
+-   support more registers and instructions:
+    -   cmovCC instructions
+    -   SSE registers: xmm0 - xmm7
+    -   SSE instructions: movd, movq, movdqa, paddb, paddw, paddd, paddq, psubb, psubw, psubd, psubq, pxor
+    -   SSE instructions (partial support): psllw, pslld, psllq, pslldq, psrlw, psrld, psrlq, psrldq, psraw, psraq
+-   bugfixes
+    -   throw an error if an immediate value does not fit
+    -   fix show instance of shift instructions
+
 # Version 0.1.4
 
 -   OS X operating system support (Balázs Kőműves)

@@ -8,18 +8,16 @@     , Size (..)
     , HasSize (..)
     , IsSize
-    -- * Addresses
-    , base
-    , disp
-    , index1, index2, index4, index8
     -- * Operands
     , Access (..)
     , Operand
     , resizeOperand
-    -- ** Immediate values
-    , imm
     -- ** Memory references
     , addr
+    , addr8
+    , addr16
+    , addr32
+    , addr64
     , ipBase
     -- ** Registers
     -- *** 64 bit registers
@@ -32,15 +30,103 @@     , al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b
     -- *** 8 bit high registers
     , ah, ch, dh, bh
+    -- *** SSE registers
+    , xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7
     -- * Conditions
     , Condition
-    , pattern O, pattern NO, pattern C, pattern NC, pattern Z, pattern NZ, pattern BE, pattern NBE, pattern S, pattern NS, pattern P, pattern NP, pattern L, pattern NL, pattern LE, pattern NLE
+    , pattern O
+    , pattern NO
+    , pattern B,  pattern C
+    , pattern NB, pattern NC
+    , pattern E,  pattern Z
+    , pattern NE, pattern NZ
+    , pattern NA, pattern BE
+    , pattern A,  pattern NBE
+    , pattern S
+    , pattern NS
+    , pattern P
+    , pattern NP
+    , pattern L
+    , pattern NL
+    , pattern NG, pattern LE
+    , pattern G,  pattern NLE
     -- * Assembly codes
-    , Code (..)
+    , 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
     , (<>)
     , (<.>), (<:>)
-    , j, j_back, if_
+    , jmp, jmp_back, jmp8, jmp32
+    , j, j8, j32
+    , j_back, j_back8, j_back32
+    , if_
     , lea8
     , leaData
     -- * Compilation

@@ -14,6 +14,7 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GeneralizedNewtypeDeriving #-}+{-# language StandaloneDeriving #-} module CodeGen.X86.Asm where  import Numeric@@ -41,6 +42,8 @@  showHex' x = "0x" ++ showHex x "" +pattern Integral xs <- (toIntegralSized -> Just xs)+ ------------------------------------------------------- byte sequences  newtype Bytes = Bytes {getBytes :: [Word8]}@@ -69,26 +72,29 @@  ------------------------------------------------------- sizes -data Size = S8 | S16 | S32 | S64+data Size = S8 | S16 | S32 | S64 | S128     deriving (Eq, Ord)  instance Show Size where     show = \case-        S8  -> "byte"-        S16 -> "word"-        S32 -> "dword"-        S64 -> "qword"+        S8   -> "byte"+        S16  -> "word"+        S32  -> "dword"+        S64  -> "qword"+        S128 -> "oword" -mkSize 1 = S8-mkSize 2 = S16-mkSize 4 = S32-mkSize 8 = S64+mkSize  1 = S8+mkSize  2 = S16+mkSize  4 = S32+mkSize  8 = S64+mkSize 16 = S128  sizeLen = \case-    S8  -> 1-    S16 -> 2-    S32 -> 4-    S64 -> 8+    S8   ->  1+    S16  ->  2+    S32  ->  4+    S64  ->  8+    S128 -> 16  class HasSize a where size :: a -> Size @@ -103,25 +109,28 @@  -- | Singleton type for size data SSize (s :: Size) where-    SSize8  :: SSize S8-    SSize16 :: SSize S16-    SSize32 :: SSize S32-    SSize64 :: SSize S64+    SSize8   :: SSize S8+    SSize16  :: SSize S16+    SSize32  :: SSize S32+    SSize64  :: SSize S64+    SSize128 :: SSize S128  instance HasSize (SSize s) where     size = \case-        SSize8  -> S8-        SSize16 -> S16-        SSize32 -> S32-        SSize64 -> S64+        SSize8   -> S8+        SSize16  -> S16+        SSize32  -> S32+        SSize64  -> S64+        SSize128 -> S128  class IsSize (s :: Size) where     ssize :: SSize s -instance IsSize S8  where ssize = SSize8-instance IsSize S16 where ssize = SSize16-instance IsSize S32 where ssize = SSize32-instance IsSize S64 where ssize = SSize64+instance IsSize S8   where ssize = SSize8+instance IsSize S16  where ssize = SSize16+instance IsSize S32  where ssize = SSize32+instance IsSize S64  where ssize = SSize64+instance IsSize S128 where ssize = SSize128  data EqT s s' where     Refl :: EqT s s@@ -145,6 +154,12 @@ s4 = Scale 0x2 s8 = Scale 0x3 +toScale = \case+    1 -> s1+    2 -> s2+    4 -> s4+    8 -> s8+ scaleFactor (Scale i) = case i of     0x0 -> 1     0x1 -> 2@@ -153,14 +168,27 @@  ------------------------------------------------------- operand -data Operand :: Size -> Access -> * where-    ImmOp     :: Immediate Int64 -> Operand s R-    RegOp     :: Reg s -> Operand s rw-    MemOp     :: IsSize s' => Addr s' -> Operand s rw-    IPMemOp   :: Immediate Int32 -> Operand s rw+data Operand :: Access -> Size -> * where+    ImmOp     :: Immediate Int64 -> Operand R s+    RegOp     :: Reg s -> Operand rw s+    MemOp     :: IsSize s' => Addr s' -> Operand rw s+    IPMemOp   :: Immediate Int32 -> Operand rw s -addr = MemOp+addr :: IsSize s => Address s -> Operand rw s'+addr = MemOp . makeAddr +addr8 :: IsSize s => Address s -> Operand rw S8+addr8 = addr++addr16 :: IsSize s => Address s -> Operand rw S16+addr16 = addr++addr32 :: IsSize s => Address s -> Operand rw S32+addr32 = addr++addr64 :: IsSize s => Address s -> Operand rw S64+addr64 = addr+ data Immediate a     = Immediate a     | LabelRelValue Size{-size hint-} !LabelIndex@@ -175,7 +203,11 @@ data Reg :: Size -> * where     NormalReg :: Word8 -> Reg s     HighReg   :: Word8 -> Reg S8+    XMM       :: Word8 -> Reg S128 +deriving instance Eq (Reg s)+deriving instance Ord (Reg s)+ data Addr s = Addr     { baseReg        :: BaseReg s     , displacement   :: Displacement@@ -194,19 +226,15 @@  ipBase = IPMemOp $ LabelRelValue S32 0 -instance Eq (Reg s) where-    NormalReg a == NormalReg b = a == b-    HighReg a == HighReg b = a == b-    _ == _ = False- instance IsSize s => Show (Reg s) where     show = \case+        XMM i -> "xmm" ++ show i         HighReg i -> (["ah"," ch", "dh", "bh"] ++ repeat err) !! fromIntegral i         r@(NormalReg i) -> (!! fromIntegral i) . (++ repeat err) $ case size r of-            S8  -> ["al", "cl", "dl", "bl", "spl", "bpl", "sil", "dil"] ++ map (++ "b") r8-            S16 -> r0 ++ map (++ "w") r8-            S32 -> map ('e':) r0 ++ map (++ "d") r8-            S64 -> map ('r':) r0 ++ r8+            S8   -> ["al", "cl", "dl", "bl", "spl", "bpl", "sil", "dil"] ++ map (++ "b") r8+            S16  -> r0 ++ map (++ "w") r8+            S32  -> map ('e':) r0 ++ map (++ "d") r8+            S64  -> map ('r':) r0 ++ r8           where             r0 = ["ax", "cx", "dx", "bx", "sp", "bp", "si", "di"]             r8 = ["r8", "r9", "r10", "r11", "r12", "r13", "r14", "r15"]@@ -231,7 +259,7 @@         f True = " + "         f False = " - " -instance IsSize s => Show (Operand s a) where+instance IsSize s => Show (Operand a s) where     show = showOperand show  showOperand mklab = \case@@ -247,12 +275,15 @@     showImm (Immediate x) = show x     showImm (LabelRelValue _ x) = mklab x -instance IsSize s => HasSize (Operand s a) where+instance IsSize s => HasSize (Operand a s) where     size _ = size (ssize :: SSize s)  instance IsSize s => HasSize (Addr s) where     size _ = size (ssize :: SSize s) +instance IsSize s => HasSize (Address s) where+    size _ = size (ssize :: SSize s)+ instance IsSize s => HasSize (BaseReg s) where     size _ = size (ssize :: SSize s) @@ -262,9 +293,13 @@ instance IsSize s => HasSize (IndexReg s) where     size _ = size (ssize :: SSize s) -imm :: Integral a => a -> Operand s R-imm = ImmOp . Immediate . fromIntegral+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+ instance Monoid (Addr s) where     mempty = Addr (getFirst mempty) (getFirst mempty) (getFirst mempty)     Addr a b c `mappend` Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (getFirst $ First c <> First c')@@ -274,23 +309,67 @@     i `mappend` NoIndex = i     NoIndex `mappend` i = i -base :: Operand s RW -> Addr s-base (RegOp x) = Addr (Just x) NoDisp NoIndex+base :: Reg s -> Addr s+base x = Addr (Just x) NoDisp NoIndex -index :: Scale -> Operand s RW -> Addr s-index sc (RegOp x) = Addr Nothing NoDisp (IndexReg sc x)+index :: Scale -> Reg s -> Addr s+index sc x = Addr Nothing NoDisp (IndexReg sc x) +index' :: Int -> Reg s -> Addr s+index' sc x = Addr Nothing NoDisp (IndexReg (toScale sc) x)+ index1 = index s1 index2 = index s2 index4 = index s4 index8 = index s8 -disp :: Int32 -> Addr s-disp x = Addr Nothing (Disp x) NoIndex+disp :: (Bits a, Integral a) => a -> Addr s+disp (Integral x)+    | x == 0 = mempty+    | otherwise = Addr Nothing (Disp x) NoIndex -reg = RegOp . NormalReg+data Address :: Size -> * where+    Address :: [(Int, Reg s)] -> Int -> Address s -rax, rcx, rdx, rbx, rsp, rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 :: Operand S64 rw+scaleAddress :: (Int -> Int) -> Address s -> Address s+scaleAddress f (Address rs d) = Address (first f <$> rs) $ f d++instance Num (Address s) where+    fromInteger d = Address [] $ fromInteger d+    negate = scaleAddress negate+    Address [] t * a = scaleAddress (t*) a+    a * Address [] t = scaleAddress (t*) a+    Address rs d + Address rs' d' = Address (f rs rs') (d + d') where+        f [] rs = rs+        f rs [] = rs+        f (p@(t, r): rs) (p'@(t', r'): rs') = case compare r r' of+            LT -> p: f rs (p': rs')+            GT -> p': f (p: rs) rs'+            EQ | t + t' == 0 -> f rs rs'+               | otherwise   -> (t + t', r): f rs rs'++makeAddr :: Address s -> Addr s+makeAddr (Address [(1, r)] d) = base r <> disp d+makeAddr (Address [(t, r)] d) = index' t r <> disp d+makeAddr (Address [(1, r), (1, r'@(NormalReg 0x4))] d) = base r' <> index1 r <> disp d+makeAddr (Address [(1, r), (t, r')] d) = base r <> index' t r' <> disp d+makeAddr (Address [(t, r'), (1, r)] d) = base r <> index' t r' <> disp d++class FromReg c where+    fromReg :: Reg s -> c s++instance FromReg Reg where+    fromReg = id++instance FromReg (Operand r) where+    fromReg = RegOp++instance FromReg Address where+    fromReg r = Address [(1, r)] 0++reg = fromReg . NormalReg++rax, rcx, rdx, rbx, rsp, rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 :: FromReg c => c S64 rax  = reg 0x0 rcx  = reg 0x1 rdx  = reg 0x2@@ -308,7 +387,7 @@ r14  = reg 0xe r15  = reg 0xf -eax, ecx, edx, ebx, esp, ebp, esi, edi, r8d, r9d, r10d, r11d, r12d, r13d, r14d, r15d :: Operand S32 rw+eax, ecx, edx, ebx, esp, ebp, esi, edi, r8d, r9d, r10d, r11d, r12d, r13d, r14d, r15d :: FromReg c => c S32 eax  = reg 0x0 ecx  = reg 0x1 edx  = reg 0x2@@ -326,7 +405,7 @@ r14d = reg 0xe r15d = reg 0xf -ax, cx, dx, bx, sp, bp, si, di, r8w, r9w, r10w, r11w, r12w, r13w, r14w, r15w :: Operand S16 rw+ax, cx, dx, bx, sp, bp, si, di, r8w, r9w, r10w, r11w, r12w, r13w, r14w, r15w :: FromReg c => c S16 ax   = reg 0x0 cx   = reg 0x1 dx   = reg 0x2@@ -344,7 +423,7 @@ r14w = reg 0xe r15w = reg 0xf -al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b :: Operand S8 rw+al, cl, dl, bl, spl, bpl, sil, dil, r8b, r9b, r10b, r11b, r12b, r13b, r14b, r15b :: FromReg c => c S8 al   = reg 0x0 cl   = reg 0x1 dl   = reg 0x2@@ -362,19 +441,30 @@ r14b = reg 0xe r15b = reg 0xf -ah   = RegOp $ HighReg 0x0-ch   = RegOp $ HighReg 0x1-dh   = RegOp $ HighReg 0x2-bh   = RegOp $ HighReg 0x3+ah, ch, dh, bh :: FromReg c => c S8+ah   = fromReg $ HighReg 0x0+ch   = fromReg $ HighReg 0x1+dh   = fromReg $ HighReg 0x2+bh   = fromReg $ HighReg 0x3 +xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7 :: FromReg c => c S128+xmm0 = fromReg $ XMM 0x0+xmm1 = fromReg $ XMM 0x1+xmm2 = fromReg $ XMM 0x2+xmm3 = fromReg $ XMM 0x3+xmm4 = fromReg $ XMM 0x4+xmm5 = fromReg $ XMM 0x5+xmm6 = fromReg $ XMM 0x6+xmm7 = fromReg $ XMM 0x7+ pattern RegA = RegOp (NormalReg 0x0) -pattern RegCl :: Operand S8 r+pattern RegCl :: Operand r S8 pattern RegCl = RegOp (NormalReg 0x1)  -------------------------------------------------------------- -resizeOperand :: IsSize s' => Operand s RW -> Operand s' RW+resizeOperand :: IsSize s' => Operand RW s -> Operand RW s' resizeOperand (RegOp x) = RegOp $ resizeRegCode x resizeOperand (MemOp a) = MemOp a resizeOperand (IPMemOp a) = IPMemOp a@@ -436,56 +526,38 @@         0xe -> "le"         0xf -> "nle" --------------------------------------------------------------- asm code--data Code where-    Ret, Nop, PushF, PopF, Cmc, Clc, Stc, Cli, Sti, Cld, Std   :: Code--    Inc, Dec, Not, Neg                                :: IsSize s => Operand s RW -> Code-    Add, Or, Adc, Sbb, And, Sub, Xor, Cmp, Test, Mov  :: IsSize s => Operand s RW -> Operand s  r -> Code-    Rol, Ror, Rcl, Rcr, Shl, Shr, Sar                 :: IsSize s => Operand s RW -> Operand S8 r -> Code--    Xchg :: IsSize s => Operand s RW -> Operand s RW -> Code-    Lea  :: (IsSize s, IsSize s') => Operand s RW -> Operand s' RW -> Code--    Pop  :: Operand S64 RW -> Code-    Push :: Operand S64 r  -> Code--    Call :: Operand S64 RW -> Code-    Jmpq :: Operand S64 RW -> Code--    J    :: Maybe Size -> Condition -> Code-    Jmp  :: Code+-------------------------------------------------------------- asm code lines -    Label :: Code-    Scope :: Code -> Code-    Up    :: Code -> Code+data CodeLine where+    Ret_, Nop_, PushF_, PopF_, Cmc_, Clc_, Stc_, Cli_, Sti_, Cld_, Std_   :: CodeLine -    Data  :: Bytes -> Code-    Align :: Size  -> Code+    Inc_, Dec_, Not_, Neg_                                :: IsSize s => Operand RW s -> CodeLine+    Add_, Or_, Adc_, Sbb_, And_, Sub_, Xor_, Cmp_, Test_, Mov_  :: IsSize s => Operand RW s -> Operand r s -> CodeLine+    Rol_, Ror_, Rcl_, Rcr_, Shl_, Shr_, Sar_                 :: IsSize s => Operand RW s -> Operand r S8 -> CodeLine -    EmptyCode  :: Code-    AppendCode :: Code -> Code -> Code+    Movdqa_, Paddb_, Paddw_, Paddd_, Paddq_, Psubb_, Psubw_, Psubd_, Psubq_, Pxor_ :: Operand RW S128 -> Operand r S128 -> CodeLine+    Psllw_, Pslld_, Psllq_, Pslldq_, Psrlw_, Psrld_, Psrlq_, Psrldq_, Psraw_, Psrad_ :: Operand RW S128 -> Operand r S8 -> CodeLine+    Movd_, Movq_ :: (IsSize s, IsSize s') => Operand RW s -> Operand r s' -> CodeLine -instance Monoid Code where-    mempty  = EmptyCode-    mappend = AppendCode+    Cmov_ :: IsSize s => Condition -> Operand RW s -> Operand RW s -> CodeLine+    Xchg_ :: IsSize s => Operand RW s -> Operand RW s -> CodeLine+    Lea_  :: (IsSize s, IsSize s') => Operand RW s -> Operand RW s' -> CodeLine --------------+    Pop_  :: Operand RW S64 -> CodeLine+    Push_ :: Operand r  S64 -> CodeLine -showCode = \case-    EmptyCode  -> return ()-    AppendCode a b -> showCode a >> showCode b+    Call_ :: Operand RW S64 -> CodeLine+    Jmpq_ :: Operand RW S64 -> CodeLine -    Scope c -> get >>= \i -> put (i+1) >> local (i:) (showCode c)+    J_    :: Condition -> Maybe Size -> CodeLine+    Jmp_  :: Maybe Size -> CodeLine -    Up c -> local tail $ showCode c+    Label_ :: CodeLine -    J s cc -> getLabel 0 >>= \l -> showOp ("j" ++ show cc) $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ l-    Jmp   -> getLabel 0 >>= \l -> showOp "jmp" l-    Label -> getLabel 0 >>= codeLine+    Data_  :: Bytes -> CodeLine+    Align_ :: Int   -> CodeLine -    x -> showCodeFrag x+------------------------- show code lines  getLabel i = ($ i) <$> getLabels @@ -497,55 +569,82 @@  codeLine x = tell [x] -showCodeFrag = \case-    Add  op1 op2 -> showOp2 "add"  op1 op2-    Or   op1 op2 -> showOp2 "or"   op1 op2-    Adc  op1 op2 -> showOp2 "adc"  op1 op2-    Sbb  op1 op2 -> showOp2 "sbb"  op1 op2-    And  op1 op2 -> showOp2 "and"  op1 op2-    Sub  op1 op2 -> showOp2 "sub"  op1 op2-    Xor  op1 op2 -> showOp2 "xor"  op1 op2-    Cmp  op1 op2 -> showOp2 "cmp"  op1 op2-    Test op1 op2 -> showOp2 "test" op1 op2-    Rol  op1 op2 -> showOp2 "rol"  op1 op2-    Ror  op1 op2 -> showOp2 "rol"  op1 op2-    Rcl  op1 op2 -> showOp2 "rol"  op1 op2-    Rcr  op1 op2 -> showOp2 "rol"  op1 op2-    Shl  op1 op2 -> showOp2 "rol"  op1 op2-    Shr  op1 op2 -> showOp2 "rol"  op1 op2-    Sar  op1 op2 -> showOp2 "rol"  op1 op2-    Mov  op1 op2 -> showOp2 "mov"  op1 op2-    Lea  op1 op2 -> showOp2 "lea"  op1 op2-    Xchg op1 op2 -> showOp2 "xchg" op1 op2-    Inc  op -> showOp1 "inc"  op-    Dec  op -> showOp1 "dec"  op-    Not  op -> showOp1 "not"  op-    Neg  op -> showOp1 "neg"  op-    Pop  op -> showOp1 "pop"  op-    Push op -> showOp1 "push" op-    Call op -> showOp1 "call" op-    Jmpq op -> showOp1 "jmp"  op-    Ret   -> showOp0 "ret"-    Nop   -> showOp0 "nop"-    PushF -> showOp0 "pushf"-    PopF  -> showOp0 "popf"-    Cmc   -> showOp0 "cmc"-    Clc   -> showOp0 "clc"-    Stc   -> showOp0 "stc"-    Cli   -> showOp0 "cli"-    Sti   -> showOp0 "sti"-    Cld   -> showOp0 "cld"-    Std   -> showOp0 "std"+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 -    Align s -> codeLine $ ".align " ++ show s-    Data (Bytes x)+showCodeLine = \case+    Add_  op1 op2 -> showOp2 "add"  op1 op2+    Or_   op1 op2 -> showOp2 "or"   op1 op2+    Adc_  op1 op2 -> showOp2 "adc"  op1 op2+    Sbb_  op1 op2 -> showOp2 "sbb"  op1 op2+    And_  op1 op2 -> showOp2 "and"  op1 op2+    Sub_  op1 op2 -> showOp2 "sub"  op1 op2+    Xor_  op1 op2 -> showOp2 "xor"  op1 op2+    Cmp_  op1 op2 -> showOp2 "cmp"  op1 op2+    Test_ op1 op2 -> showOp2 "test" op1 op2+    Rol_  op1 op2 -> showOp2 "rol"  op1 op2+    Ror_  op1 op2 -> showOp2 "ror"  op1 op2+    Rcl_  op1 op2 -> showOp2 "rcl"  op1 op2+    Rcr_  op1 op2 -> showOp2 "rcr"  op1 op2+    Shl_  op1 op2 -> showOp2 "shl"  op1 op2+    Shr_  op1 op2 -> showOp2 "shr"  op1 op2+    Sar_  op1 op2 -> showOp2 "sar"  op1 op2+    Mov_  op1 op2 -> showOp2 "mov"  op1 op2+    Cmov_ cc op1 op2 -> showOp2 ("cmov" ++ show cc) op1 op2+    Lea_  op1 op2 -> showOp2 "lea"  op1 op2+    Xchg_ op1 op2 -> showOp2 "xchg" op1 op2+    Movd_   op1 op2 -> showOp2 "movd"   op1 op2+    Movq_   op1 op2 -> showOp2 "movq"   op1 op2+    Movdqa_ op1 op2 -> showOp2 "movdqa" op1 op2+    Paddb_  op1 op2 -> showOp2 "paddb"  op1 op2+    Paddw_  op1 op2 -> showOp2 "paddw"  op1 op2+    Paddd_  op1 op2 -> showOp2 "paddd"  op1 op2+    Paddq_  op1 op2 -> showOp2 "paddq"  op1 op2+    Psubb_  op1 op2 -> showOp2 "psubb"  op1 op2+    Psubw_  op1 op2 -> showOp2 "psubw"  op1 op2+    Psubd_  op1 op2 -> showOp2 "psubd"  op1 op2+    Psubq_  op1 op2 -> showOp2 "psubq"  op1 op2+    Pxor_   op1 op2 -> showOp2 "pxor"   op1 op2+    Psllw_  op1 op2 -> showOp2 "psllw"  op1 op2+    Pslld_  op1 op2 -> showOp2 "pslld"  op1 op2+    Psllq_  op1 op2 -> showOp2 "psllq"  op1 op2+    Pslldq_ op1 op2 -> showOp2 "pslldq" op1 op2+    Psrlw_  op1 op2 -> showOp2 "psrlw"  op1 op2+    Psrld_  op1 op2 -> showOp2 "psrld"  op1 op2+    Psrlq_  op1 op2 -> showOp2 "psrlq"  op1 op2+    Psrldq_ op1 op2 -> showOp2 "psrldq" op1 op2+    Psraw_  op1 op2 -> showOp2 "psraw"  op1 op2+    Psrad_  op1 op2 -> showOp2 "psrad"  op1 op2+    Inc_  op -> showOp1 "inc"  op+    Dec_  op -> showOp1 "dec"  op+    Not_  op -> showOp1 "not"  op+    Neg_  op -> showOp1 "neg"  op+    Pop_  op -> showOp1 "pop"  op+    Push_ op -> showOp1 "push" op+    Call_ op -> showOp1 "call" op+    Jmpq_ op -> showOp1 "jmp"  op+    Ret_   -> showOp0 "ret"+    Nop_   -> showOp0 "nop"+    PushF_ -> showOp0 "pushf"+    PopF_  -> showOp0 "popf"+    Cmc_   -> showOp0 "cmc"+    Clc_   -> showOp0 "clc"+    Stc_   -> showOp0 "stc"+    Cli_   -> showOp0 "cli"+    Sti_   -> showOp0 "sti"+    Cld_   -> showOp0 "cld"+    Std_   -> showOp0 "std"++    Align_ s -> codeLine $ ".align " ++ show s+    Data_ (Bytes 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 -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+    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 

@@ -1,6 +1,6 @@- -- | Calling conventions. There are basically only two: System V (Linux, OSX, BSD) and Win64\/fastcall +{-# language NoMonomorphismRestriction #-} {-# language CPP #-} {-# language BangPatterns #-} {-# language DataKinds #-}@@ -8,31 +8,33 @@  import Foreign import Data.Monoid+ import CodeGen.X86.Asm+import CodeGen.X86.CodeGen  ------------------------------------------------------------------------------   #if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS)  -- On Win64 the caller have to reserve 32 byte "shadow space" on the stack (and clean up after)-callFun :: Operand S64 RW -> FunPtr a -> Code+callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p -  =  Sub rsp (imm 32) -  <> Mov r (imm $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) +  =  Sub rsp 32+  <> Mov r (imm $ ptrToIntPtr $ castFunPtrToPtr p)   <> Call r -  <> Add rsp (imm 32)+  <> Add rsp 32  #elif defined (darwin_HOST_OS)  -- OSX requires 16 byte alignment of the stack...-callFun :: Operand S64 RW -> FunPtr a -> Code+callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p    =  Push r15              -- we will use r15 (non-volatile) to store old rsp-  <> Mov r15 (imm 15)      -- 0xf+  <> 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 $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) +  <> Mov r (imm $ ptrToIntPtr $ castFunPtrToPtr p)   <> Call r    <> Mov rsp r15           -- restore rsp   <> Pop r15               -- restore r15@@ -40,9 +42,9 @@ #else  -- helper to call a function-callFun :: Operand S64 RW -> FunPtr a -> Code+callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p -  =  Mov r (imm $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p) +  =  Mov r (imm $ ptrToIntPtr $ castFunPtrToPtr p)   <> Call r  #endif

@@ -45,8 +45,6 @@ pattern FJust a = First (Just a) pattern FNothing = First Nothing -pattern Integral xs <- (toIntegralSized -> Just xs)- integralToBytes :: (Bits a, Integral a) => Bool{-signed-} -> Size -> a -> Maybe Bytes integralToBytes False S64 w = toBytes <$> (toIntegralSized w :: Maybe Word64) integralToBytes False S32 w = toBytes <$> (toIntegralSized w :: Maybe Word32)@@ -69,7 +67,7 @@ isHigh (SReg HighReg{}) = True isHigh _ = False -regs :: forall s k . IsSize s => Operand s k -> [SReg]+regs :: IsSize s => Operand r s -> [SReg] regs = \case     MemOp (Addr r _ i) -> foldMap (pure . SReg) r ++ foldMap (pure . SReg . snd) i     RegOp r -> [SReg r]@@ -86,20 +84,22 @@ ------------------------------------------------------- code builder  data CodeBuilder-    = CodeBuilder (CodeBuilderState -> (CodeBuilderRes, CodeBuilderState))-    | ExactCodeBuilder Int (CodeBuilderState -> (CodeBuilderRes, LabelState))   -- ^ CodeBuilder with known length+    = 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-buildCode (ExactCodeBuilder len f) (n, st) = second ((,) (n + len)) $ f (n, st)+buildCode (CodeBuilder _ _ f) st = f st -mapLabelState g (CodeBuilder f) = CodeBuilder $ \(n, g -> (fx, xs)) -> second (second fx) $ f (n, xs)-mapLabelState g (ExactCodeBuilder len f) = ExactCodeBuilder len $ \(n, g -> (fx, xs)) -> second fx $ f (n, xs)+mapLabelState g (CodeBuilder i j f) = CodeBuilder i j $ \(n, g -> (fx, xs)) -> second (second fx) $ f (n, xs) -censorCodeBuilder g (CodeBuilder f) = CodeBuilder $ \st -> first (g st) $ f st-censorCodeBuilder g (ExactCodeBuilder len f) = ExactCodeBuilder len $ \st -> first (g st) $ f st+censorCodeBuilder g (CodeBuilder i j f) = CodeBuilder i j $ \st -> first (g st) $ f st  type CodeBuilderRes = [Either Int (Int, Word8)] @@ -109,12 +109,13 @@  instance Monoid CodeBuilder where     mempty = ExactCodeBuilder 0 $ \(_, st) -> (mempty, st)-    ExactCodeBuilder len f `mappend` ExactCodeBuilder len' g = ExactCodeBuilder (len + len') $ \st -> let-            (a, st') = f st-            (b, st'') = g (len + fst st, st')-        in (a ++ b, st'')-    f `mappend` g = CodeBuilder $ \(buildCode f -> (a, buildCode g -> (b, st))) -> (a ++ b, 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 +bounds (CodeBuilder i j _) = (i, j)+ codeByte :: Word8 -> CodeBuilder codeByte c = ExactCodeBuilder 1 $ \(n, labs) -> ([Right (n, c)], labs) @@ -138,8 +139,10 @@             labs' = take bs labs ++ Left ((s, n, - n - offset): cs): drop (bs + 1) labs  mkAutoRef :: [(Size, Bytes)] -> Int -> Int -> CodeBuilder-mkAutoRef ss offset bs = CodeBuilder f+mkAutoRef ss offset bs = CodeBuilder (minimum sizes) (maximum sizes) f   where+    sizes = map (\(s, c) -> sizeLen s + bytesCount c) ss+     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"@@ -183,7 +186,7 @@ mkCodeBuilder :: Code -> CodeBuilder mkCodeBuilder = \case     EmptyCode -> mempty-    AppendCode a b -> mkCodeBuilder a <> mkCodeBuilder b+    AppendCode cb _ _ -> cb      Up a -> mapLabelState (\(x: xs) -> ((x:), xs)) $ mkCodeBuilder a @@ -193,86 +196,114 @@         end (n, Right _: labs) = (mempty, labs)         end (n, _: labs) = trace "warning: missing label" (mempty, labs) -    x -> censorCodeBuilder (\(addr, _) -> (Left addr:)) $ mkCodeBuilder' x+    CodeLine_ cb _ -> censorCodeBuilder (\(addr, _) -> (Left addr:)) cb -mkCodeBuilder' :: Code -> CodeBuilder+mkCodeBuilder' :: CodeLine -> CodeBuilder mkCodeBuilder' = \case-    Add  a b -> op2 0x0 a b-    Or   a b -> op2 0x1 a b-    Adc  a b -> op2 0x2 a b-    Sbb  a b -> op2 0x3 a b-    And  a b -> op2 0x4 a b-    Sub  a b -> op2 0x5 a b-    Xor  a b -> op2 0x6 a b-    Cmp  a b -> op2 0x7 a b+    Add_  a b -> op2 0x0 a b+    Or_   a b -> op2 0x1 a b+    Adc_  a b -> op2 0x2 a b+    Sbb_  a b -> op2 0x3 a b+    And_  a b -> op2 0x4 a b+    Sub_  a b -> op2 0x5 a b+    Xor_  a b -> op2 0x6 a b+    Cmp_  a b -> op2 0x7 a b -    Rol a b -> shiftOp 0x0 a b-    Ror a b -> shiftOp 0x1 a b-    Rcl a b -> shiftOp 0x2 a b-    Rcr a b -> shiftOp 0x3 a b-    Shl a b -> shiftOp 0x4 a b -- sal-    Shr a b -> shiftOp 0x5 a b-    Sar a b -> shiftOp 0x7 a b+    Rol_ a b -> shiftOp 0x0 a b+    Ror_ a b -> shiftOp 0x1 a b+    Rcl_ a b -> shiftOp 0x2 a b+    Rcr_ a b -> shiftOp 0x3 a b+    Shl_ a b -> shiftOp 0x4 a b -- sal+    Shr_ a b -> shiftOp 0x5 a b+    Sar_ a b -> shiftOp 0x7 a b -    Xchg x@RegA r -> xchg_a r-    Xchg r x@RegA -> xchg_a r-    Xchg dest src -> op2' 0x43 dest' src+    Xchg_ x@RegA r -> xchg_a r+    Xchg_ r x@RegA -> xchg_a r+    Xchg_ dest src -> op2' 0x43 dest' src       where         (dest', src') = if isMemOp src then (src, dest) else (dest, src) -    Test dest (mkImmNo64 (size dest) -> FJust (_, im)) -> case dest of+    Test_ dest (mkImmNo64 (size dest) -> FJust (_, im)) -> case dest of         RegA -> regprefix'' dest 0x54 mempty im         _ -> regprefix'' dest 0x7b (reg8 0x0 dest) im-    Test dest (noImm "" -> src) -> op2' 0x42 dest' src'+    Test_ dest (noImm "" -> src) -> op2' 0x42 dest' src'       where         (dest', src') = if isMemOp src then (src, dest) else (dest, src) -    Mov dest@(RegOp r) ((if size dest == S64 then mkImm S32 <> mkImmS S32 <> mkImmS S64 else mkImmS (size dest)) -> FJust ((se, si), im))+    Mov_ dest@(RegOp r) ((if size dest == S64 then mkImm S32 <> mkImmS S32 <> mkImmS S64 else mkImmS (size dest)) -> FJust ((se, si), im))         | (se, si, size dest) /= (True, S32, S64) -> regprefix si dest (oneReg (0x16 .|. indicator (size dest /= S8)) r) im         | otherwise -> regprefix'' dest 0x63 (reg8 0x0 dest) im-    Mov dest@(size -> s) (mkImmNo64 s -> FJust (_, im)) -> regprefix'' dest 0x63 (reg8 0x0 dest) im-    Mov dest src -> op2' 0x44 dest $ noImm (show (dest, src)) src+    Mov_ dest@(size -> s) (mkImmNo64 s -> FJust (_, im)) -> regprefix'' dest 0x63 (reg8 0x0 dest) im+    Mov_ dest src -> op2' 0x44 dest $ noImm (show (dest, src)) src -    Lea dest@(RegOp r) src | size dest /= S8 -> regprefix2 (resizeOperand' dest src) dest 0x46 $ reg8 (reg8_ r) src+    Cmov_ (Condition c) dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte (0x40 .|. c) <> reg2x8 dest src++    Lea_ dest src | size dest /= S8 -> regprefix2' (resizeOperand' dest src) dest 0x46 $ reg2x8 dest src       where-        resizeOperand' :: IsSize s1 => Operand s1 x -> Operand s2 RW -> Operand s1 RW+        resizeOperand' :: IsSize s1 => Operand x s1 -> Operand RW s2 -> Operand RW s1         resizeOperand' _ = resizeOperand -    Not  a -> op1 0x7b 0x2 a-    Neg  a -> op1 0x7b 0x3 a-    Inc  a -> op1 0x7f 0x0 a-    Dec  a -> op1 0x7f 0x1 a-    Call a -> op1' 0xff 0x2 a-    Jmpq a -> op1' 0xff 0x4 a+    Not_  a -> op1 0x7b 0x2 a+    Neg_  a -> op1 0x7b 0x3 a+    Inc_  a -> op1 0x7f 0x0 a+    Dec_  a -> op1 0x7f 0x1 a+    Call_ a -> op1' 0xff 0x2 a+    Jmpq_ a -> op1' 0xff 0x4 a -    Pop dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty-    Pop dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty+    Movd_ a@OpXMM b -> sse 0x6e a b+    Movd_ b a@OpXMM -> sse 0x7e a b+    Movq_ b a@OpXMM -> sse 0xd6 a b+    Movdqa_ a@OpXMM b -> sse 0x6f a b+    Movdqa_ b a@OpXMM -> sse 0x7f a b+    Paddb_  a b -> sse 0xfc a b+    Paddw_  a b -> sse 0xfd a b+    Paddd_  a b -> sse 0xfe a b+    Paddq_  a b -> sse 0xd4 a b+    Psubb_  a b -> sse 0xf8 a b+    Psubw_  a b -> sse 0xf9 a b+    Psubd_  a b -> sse 0xfa a b+    Psubq_  a b -> sse 0xfb a b+    Pxor_   a b -> sse 0xef a b+    Psllw_  a b -> sseShift 0x71 0x2 0xd1 a b+    Pslld_  a b -> sseShift 0x72 0x2 0xd2 a b+    Psllq_  a b -> sseShift 0x73 0x2 0xd3 a b+    Pslldq_ a b -> sseShift 0x73 0x7 undefined a b+    Psrlw_  a b -> sseShift 0x71 0x6 0xf1 a b+    Psrld_  a b -> sseShift 0x72 0x6 0xf2 a b+    Psrlq_  a b -> sseShift 0x73 0x6 0xf3 a b+    Psrldq_ a b -> sseShift 0x73 0x3 undefined a b+    Psraw_  a b -> sseShift 0x71 0x4 0xe1 a b+    Psrad_  a b -> sseShift 0x72 0x4 0xe2 a b -    Push (mkImmS S8 -> FJust (_, im))  -> codeByte 0x6a <> im-    Push (mkImmS S32 -> FJust (_, im)) -> codeByte 0x68 <> im-    Push dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty-    Push dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty+    Pop_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty+    Pop_ dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty -    Ret   -> codeByte 0xc3-    Nop   -> codeByte 0x90-    PushF -> codeByte 0x9c-    PopF  -> codeByte 0x9d-    Cmc   -> codeByte 0xf5-    Clc   -> codeByte 0xf8-    Stc   -> codeByte 0xf9-    Cli   -> codeByte 0xfa-    Sti   -> codeByte 0xfb-    Cld   -> codeByte 0xfc-    Std   -> codeByte 0xfd+    Push_ (mkImmS S8 -> FJust (_, im))  -> codeByte 0x6a <> im+    Push_ (mkImmS S32 -> FJust (_, im)) -> codeByte 0x68 <> im+    Push_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty+    Push_ dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty -    J (Just S8)  (Condition c) -> codeByte (0x70 .|. c) <> mkRef S8 1 0-    J (Just S32) (Condition c) -> codeByte 0x0f <> codeByte (0x80 .|. c) <> mkRef S32 4 0-    J Nothing    (Condition c) -> mkAutoRef [(S8, Bytes [0x70 .|. c]), (S32, Bytes [0x0f, 0x80 .|. c])] 0 0+    Ret_   -> codeByte 0xc3+    Nop_   -> codeByte 0x90+    PushF_ -> codeByte 0x9c+    PopF_  -> codeByte 0x9d+    Cmc_   -> codeByte 0xf5+    Clc_   -> codeByte 0xf8+    Stc_   -> codeByte 0xf9+    Cli_   -> codeByte 0xfa+    Sti_   -> codeByte 0xfb+    Cld_   -> codeByte 0xfc+    Std_   -> codeByte 0xfd -    -- short jump-    Jmp -> codeByte 0xeb <> mkRef S8 1 0+    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 -    Label -> ExactCodeBuilder 0 lab+    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++    Label_ -> ExactCodeBuilder 0 lab       where         lab :: CodeBuilderState -> (CodeBuilderRes, LabelState)         lab (n, labs) = (Right <$> concatMap g corr, labs')@@ -282,55 +313,55 @@             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 -> bytesToCodeBuilder x-    Align s -> CodeBuilder $ \(n, labs) -> let-                    n' = fromIntegral $ (fromIntegral n - 1 :: Int64) .|. f s + 1+    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))-      where-        f :: Size -> Int64-        f s = sizeLen s - 1   where-    convertImm :: Bool{-signed-} -> Size -> Operand s k -> First ((Bool, Size), CodeBuilder)+    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 True b (ImmOp (LabelRelValue s d)) | b == s = FJust $ (,) (True, b) $ mkRef s (sizeLen s) d     convertImm _ _ _ = FNothing -    mkImmS, mkImm, mkImmNo64 :: Size -> Operand s k -> First ((Bool, Size), CodeBuilder)+    mkImmS, mkImm, mkImmNo64 :: Size -> Operand r s -> First ((Bool, Size), CodeBuilder)     mkImmS = convertImm True     mkImm  = convertImm False     mkImmNo64 s = mkImmS (no64 s) -    xchg_a :: IsSize s => Operand s a -> CodeBuilder+    xchg_a :: IsSize s => Operand r s -> CodeBuilder     xchg_a dest@(RegOp r) | size dest /= S8 = regprefix (size dest) dest (oneReg 0x12 r) mempty     xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty      toCode :: HasBytes a => a -> CodeBuilder     toCode = bytesToCodeBuilder . toBytes -    sizePrefix_ :: [SReg] -> Size -> Operand s a -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder+    sizePrefix_ :: [SReg] -> Size -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder     sizePrefix_ rs s r x c im         | noHighRex rs = pre <> c <> displacement r <> im         | otherwise = error "cannot use high register in rex instruction"       where         pre = case s of-            S8  -> mem32pre r <> iff (any isRex rs || x /= 0) (prefix40_ x)+            S8  -> mem32pre r <> maybePrefix40             S16 -> codeByte 0x66 <> mem32pre r <> prefix40 x             S32 -> mem32pre r <> prefix40 x             S64 -> mem32pre r <> prefix40 (0x8 .|. x)+            S128 -> mem32pre r <> codeByte 0x66 <> maybePrefix40 -        mem32pre :: Operand s k -> CodeBuilder+        mem32pre :: Operand r s -> CodeBuilder         mem32pre (MemOp r@Addr{}) | size r == S32 = codeByte 0x67         mem32pre _ = mempty          prefix40 x = iff (x /= 0) $ prefix40_ x         prefix40_ x = codeByte $ 0x40 .|. x -        displacement :: Operand s a -> CodeBuilder-        displacement RegOp{} = mempty+        maybePrefix40 = iff (any isRex rs || x /= 0) (prefix40_ x)++        displacement :: Operand r s -> CodeBuilder         displacement (IPMemOp (Immediate d)) = toCode d         displacement (IPMemOp (LabelRelValue s@S32 d)) = mkRef s (sizeLen s + fromIntegral (codeBuilderLength im)) d         displacement (MemOp (Addr b d i)) = mkSIB b i <> dispVal b d@@ -348,80 +379,95 @@             dispVal Nothing _ = toCode (0 :: Int32)      -- [rbp] --> [rbp + 0]             dispVal (Just (reg8_ -> 0x5)) _ = codeByte 0      -- [rbp] --> [rbp + 0]             dispVal _ _ = mempty+        displacement _ = mempty      reg8_ :: Reg t -> Word8     reg8_ (NormalReg r) = r .&. 0x7     reg8_ (HighReg r) = r .|. 0x4+    reg8_ (XMM r) = r .&. 0x7 -    regprefix :: IsSize s => Size -> Operand s a -> CodeBuilder -> CodeBuilder -> CodeBuilder+    regprefix :: IsSize s => Size -> Operand r s -> CodeBuilder -> CodeBuilder -> CodeBuilder     regprefix s r c im = sizePrefix_ (regs r) s r (extbits r) c im -    regprefix2 :: (IsSize s1, IsSize s) => Operand s1 a1 -> Operand s a -> Word8 -> CodeBuilder -> CodeBuilder-    regprefix2 r r' p c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) (extension r p <> c) mempty+    regprefix2 :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> CodeBuilder -> CodeBuilder+    regprefix2 r r' c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) c mempty -    regprefix'' :: IsSize s => Operand s a -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder+    regprefix'' :: IsSize s => Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder     regprefix'' r p c = regprefix (size r) r $ extension r p <> c +    regprefix2' :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder+    regprefix2' r r' p c = regprefix2 r r' $ extension r p <> c++    sse :: IsSize s => Word8 -> Operand r S128 -> Operand r' s -> CodeBuilder+    sse op a@OpXMM b = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg2x8 a b) mempty++    sseShift :: Word8 -> Word8 -> Word8 -> Operand RW S128 -> Operand r S8 -> CodeBuilder+    sseShift op x op' a@OpXMM b@(mkImm S8 -> FJust (_, i)) = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg8 x a) i+    -- TODO: xmm argument+     extension :: HasSize a => a -> Word8 -> CodeBuilder     extension x p = codeByte $ p `shiftL` 1 .|. indicator (size x /= S8) -    extbits :: Operand s a -> Word8+    extbits :: Operand r s -> Word8     extbits = \case         MemOp (Addr b _ i) -> maybe 0 indexReg b .|. maybe 0 ((`shiftL` 1) . indexReg . snd) i         RegOp r -> indexReg r-        IPMemOp{} -> 0+        _ -> 0       where         indexReg (NormalReg r) = r `shiftR` 3 .&. 1         indexReg _ = 0 -    reg8 :: Word8 -> Operand s a -> CodeBuilder+    reg8 :: Word8 -> Operand r s -> CodeBuilder     reg8 w x = codeByte $ operMode x `shiftL` 6 .|. w `shiftL` 3 .|. rc x       where-        operMode :: Operand s a -> Word8+        operMode :: Operand r s -> Word8         operMode (MemOp (Addr (Just (reg8_ -> 0x5)) NoDisp _)) = 0x1   -- [rbp] --> [rbp + 0]         operMode (MemOp (Addr Nothing _ _)) = 0x0         operMode (MemOp (Addr _ NoDisp _))  = 0x0         operMode (MemOp (Addr _ (Disp (Integral (_ :: Int8))) _))  = 0x1         operMode (MemOp (Addr _ Disp{} _))  = 0x2         operMode IPMemOp{}                  = 0x0-        operMode RegOp{}                    = 0x3+        operMode _                          = 0x3 -        rc :: Operand s a -> Word8+        rc :: Operand r s -> Word8         rc (MemOp (Addr (Just r) _ NoIndex)) = reg8_ r         rc MemOp{}   = 0x04      -- SIB byte         rc IPMemOp{} = 0x05         rc (RegOp r) = reg8_ r -    op2 :: IsSize s => Word8 -> Operand s RW -> Operand s k -> CodeBuilder+    op2 :: IsSize s => Word8 -> Operand RW s -> Operand r s -> CodeBuilder     op2 op dest@RegA src@(mkImmNo64 (size dest) -> FJust (_, im)) | size dest == S8 || isNothing (getFirst $ mkImmS S8 src)         = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im     op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im))         = regprefix'' dest (0x40 .|. indicator (size dest /= S8 && k == S8)) (reg8 op dest) im     op2 op dest src = op2' (op `shiftL` 2) dest $ noImm "1" src -    noImm :: String -> Operand s k -> Operand s RW+    noImm :: String -> Operand r s -> Operand RW s     noImm _ (RegOp r) = RegOp r     noImm _ (MemOp a) = MemOp a     noImm _ (IPMemOp a) = IPMemOp a     noImm er _ = error $ "immediate value of this size is not supported: " ++ er -    op2' :: IsSize s => Word8 -> Operand s RW -> Operand s RW -> CodeBuilder+    op2' :: IsSize s => Word8 -> Operand RW s -> Operand RW s -> CodeBuilder     op2' op dest src@RegOp{} = op2g op dest src     op2' op dest@RegOp{} src = op2g (op .|. 0x1) src dest -    op2g :: (IsSize t, IsSize s) => Word8 -> Operand s a1 -> Operand t a -> CodeBuilder-    op2g op dest src@(RegOp r) = regprefix2 dest src op $ reg8 (reg8_ r) dest+    op2g :: (IsSize t, IsSize s) => Word8 -> Operand r s -> Operand r' t -> CodeBuilder+    op2g op dest src = regprefix2' dest src op $ reg2x8 src dest -    op1_ :: IsSize s => Word8 -> Word8 -> Operand s a -> CodeBuilder -> CodeBuilder+    reg2x8 :: (IsSize s, IsSize s') => Operand r s -> Operand r' s' -> CodeBuilder+    reg2x8 (RegOp r) x = reg8 (reg8_ r) x++    op1_ :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder -> CodeBuilder     op1_ r1 r2 dest im = regprefix'' dest r1 (reg8 r2 dest) im -    op1 :: IsSize s => Word8 -> Word8 -> Operand s a -> CodeBuilder+    op1 :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder     op1 a b c = op1_ a b c mempty -    op1' :: Word8 -> Word8 -> Operand S64 RW -> CodeBuilder+    op1' :: Word8 -> Word8 -> Operand RW S64 -> CodeBuilder     op1' r1 r2 dest = regprefix S32 dest (codeByte r1 <> reg8 r2 dest) mempty -    shiftOp :: IsSize s => Word8 -> Operand s RW -> Operand S8 k -> CodeBuilder+    shiftOp :: IsSize s => Word8 -> Operand RW s -> Operand r S8 -> CodeBuilder     shiftOp c dest (ImmOp (Immediate 1)) = op1 0x68 c dest     shiftOp c dest (mkImm S8 -> FJust (_, i)) = op1_ 0x60 c dest i     shiftOp c dest RegCl = op1 0x69 c dest@@ -429,4 +475,101 @@      oneReg :: Word8 -> Reg t -> CodeBuilder     oneReg x r = codeByte $ x `shiftL` 3 .|. reg8_ r++pattern OpXMM <- RegOp XMM{}++-------------------------------------------------------------- asm codes++data Code where+    Scope       :: Code -> Code+    Up          :: Code -> Code+    EmptyCode   :: Code+    AppendCode  :: CodeBuilder -> Code -> Code -> Code+    CodeLine_   :: CodeBuilder -> CodeLine -> Code++instance Monoid Code 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++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_)++-------------++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 

@@ -24,7 +24,7 @@     $  Mov rdi arg1
     <> Inc rdi
     <> Xor rdx rdx
-    <> Mov rax (imm 1)
+    <> Mov rax 1
     <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> Dec rdi) `j_back` NZ
 
 fibFun :: Word64 -> Word64
@@ -35,7 +35,7 @@     $  Mov rdi arg1
     <> Inc rdi
     <> Xor rdx rdx
-    <> Mov rax (imm 1)
+    <> Mov rax 1
     <> (Mov rcx rax <> Mov rax rdx <> Add rdx rcx <> traceReg "d" rax {- <> traceReg "d" rdi -} <> Dec rdi) `j_back` NZ
 
 tracedFibFun :: Word64 -> Word64
@@ -73,7 +73,7 @@     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 $ base rdi)
+             $ Mov rdi arg1 <> Mov rax (addr rdi)
     return $ compile code r == v
 
 

@@ -37,10 +37,19 @@ foreign import ccall "dynamic" callWord32           :: FunPtr Word32                -> Word32 foreign import ccall "dynamic" callWord16           :: FunPtr Word16                -> Word16 foreign import ccall "dynamic" callWord8            :: FunPtr Word8                 -> Word8+foreign import ccall "dynamic" callWord             :: FunPtr Word                  -> Word+foreign import ccall "dynamic" callInt64            :: FunPtr Int64                 -> Int64+foreign import ccall "dynamic" callInt32            :: FunPtr Int32                 -> Int32+foreign import ccall "dynamic" callInt16            :: FunPtr Int16                 -> Int16+foreign import ccall "dynamic" callInt8             :: FunPtr Int8                  -> Int8+foreign import ccall "dynamic" callInt              :: FunPtr Int                   -> Int foreign import ccall "dynamic" callBool             :: FunPtr Bool                  -> Bool foreign import ccall "dynamic" callIOUnit           :: FunPtr (IO ())               -> IO () foreign import ccall "dynamic" callWord64_Word64    :: FunPtr (Word64 -> Word64)    -> Word64 -> Word64 foreign import ccall "dynamic" callPtr_Word64       :: FunPtr (Ptr a -> Word64)     -> Ptr a -> Word64+foreign import ccall "dynamic" callPtr_Word         :: FunPtr (Ptr a -> Word)       -> Ptr a -> Word+foreign import ccall "dynamic" callPtr_Int64        :: FunPtr (Ptr a -> Int64)      -> Ptr a -> Int64+foreign import ccall "dynamic" callPtr_Int          :: FunPtr (Ptr a -> Int)        -> Ptr a -> Int  unsafeCallForeignPtr0 call p = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p)) <* touchForeignPtr p @@ -55,10 +64,19 @@ instance Callable Word32                where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord32 instance Callable Word16                where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord16 instance Callable Word8                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord8+instance Callable Word                  where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord+instance Callable Int64                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt64+instance Callable Int32                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt32+instance Callable Int16                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt16+instance Callable Int8                  where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt8+instance Callable Int                   where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt instance Callable Bool                  where unsafeCallForeignPtr = unsafeCallForeignPtr0 callBool instance Callable (IO ())               where unsafeCallForeignPtr = unsafeCallForeignPtrIO0 callIOUnit instance Callable (Word64 -> Word64)    where unsafeCallForeignPtr = unsafeCallForeignPtr1 callWord64_Word64 instance Callable (Ptr a -> Word64)     where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word64+instance Callable (Ptr a -> Word)       where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word+instance Callable (Ptr a -> Int64)      where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Int64+instance Callable (Ptr a -> Int)        where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Int  ------------------------------------------------------- 

@@ -123,14 +123,14 @@ 
 genMems = MemOp <$> (arbitrary :: Gen (Addr S64))
 
-instance IsSize s => Arbitrary (Operand s RW) where
+instance IsSize s => Arbitrary (Operand RW s) where
     arbitrary = oneof
         [ genRegs
         , genMems
         , genIPBase
         ]
 
-instance IsSize s => Arbitrary (Operand s R) where
+instance IsSize s => Arbitrary (Operand R s) where
     arbitrary = oneof
         [ imm <$> oneof (arbVal <$> [S8, S16, S32, S64])
         , genRegs
@@ -159,42 +159,42 @@         , op2'' Mov
         ]
       where
-        op2 :: (forall s . IsSize s => Operand s RW -> Operand s R -> Code) -> Gen Code
+        op2 :: (forall s . IsSize s => Operand RW s -> Operand R s -> Code) -> Gen Code
         op2 op = oneof
-            [ f op (arbitrary :: Gen (Operand S8 RW))  arbitrary
-            , f op (arbitrary :: Gen (Operand S16 RW)) arbitrary
-            , f op (arbitrary :: Gen (Operand S32 RW)) arbitrary
-            , f op (arbitrary :: Gen (Operand S64 RW)) arbitrary
+            [ f op (arbitrary :: Gen (Operand RW S8))  arbitrary
+            , f op (arbitrary :: Gen (Operand RW S16)) arbitrary
+            , f op (arbitrary :: Gen (Operand RW S32)) arbitrary
+            , f op (arbitrary :: Gen (Operand RW S64)) arbitrary
             ]
           where
-            f :: forall s . IsSize s => (Operand s RW -> Operand s R -> Code) -> Gen (Operand s RW) -> Gen (Operand s R) -> Gen Code
+            f :: forall s . IsSize s => (Operand RW s -> Operand R s -> Code) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen Code
             f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b)
 
-        op2'' :: (forall s . IsSize s => Operand s RW -> Operand s R -> Code) -> Gen Code
+        op2'' :: (forall s . IsSize s => Operand RW s -> Operand R s -> Code) -> Gen Code
         op2'' op = oneof
-            [ f op (arbitrary :: Gen (Operand S8 RW))  arbitrary
-            , f op (arbitrary :: Gen (Operand S16 RW)) arbitrary
-            , f op (arbitrary :: Gen (Operand S32 RW)) arbitrary
-            , f op (arbitrary :: Gen (Operand S64 RW)) arbitrary
+            [ f op (arbitrary :: Gen (Operand RW S8))  arbitrary
+            , f op (arbitrary :: Gen (Operand RW S16)) arbitrary
+            , f op (arbitrary :: Gen (Operand RW S32)) arbitrary
+            , f op (arbitrary :: Gen (Operand RW S64)) arbitrary
             ]
           where
-            f :: forall s . IsSize s => (Operand s RW -> Operand s R -> Code) -> Gen (Operand s RW) -> Gen (Operand s R) -> Gen Code
+            f :: forall s . IsSize s => (Operand RW s -> Operand R s -> Code) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen Code
             f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && oki a b)
 
-        op2' :: (forall s . IsSize s => Operand s RW -> Operand S8 R -> Code) -> Gen Code
+        op2' :: (forall s . IsSize s => Operand RW s -> Operand R S8 -> Code) -> Gen Code
         op2' op = oneof
-            [ f op (arbitrary :: Gen (Operand S8 RW))  arb
-            , f op (arbitrary :: Gen (Operand S16 RW)) arb
-            , f op (arbitrary :: Gen (Operand S32 RW)) arb
-            , f op (arbitrary :: Gen (Operand S64 RW)) arb
+            [ f op (arbitrary :: Gen (Operand RW S8))  arb
+            , f op (arbitrary :: Gen (Operand RW S16)) arb
+            , f op (arbitrary :: Gen (Operand RW S32)) arb
+            , f op (arbitrary :: Gen (Operand RW S64)) arb
             ]
           where
             arb = oneof
-                [ imm . fromIntegral <$> (arbitrary :: Gen Word8)
+                [ imm <$> (arbitrary :: Gen Word8)
                 , return cl
                 ]
 
-            f :: forall s . IsSize s => (Operand s RW -> Operand S8 R -> Code) -> Gen (Operand s RW) -> Gen (Operand S8 R) -> Gen Code
+            f :: forall s . IsSize s => (Operand RW s -> Operand R S8 -> Code) -> Gen (Operand RW s) -> Gen (Operand R S8) -> Gen Code
             f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b && noteqreg a b)
 
         noteqreg a b = x == nub x where x = map phisicalReg $ regs a ++ regs b
@@ -271,13 +271,13 @@     arbitrary = do
         i <- arbitrary
         cF <- arbitrary
-        let   fff :: forall s s' r . (IsSize s, IsSize s') => Code -> (Operand s RW -> Operand s' r -> Code) -> Operand s RW -> Operand s' r -> Gen InstrTest
+        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
               fff op op' a b = do
                 let
                     (f1: f2: _) = map RegOp $ filter (`notElem` (regi a ++ regi b)) $ NormalReg <$> [8..15]
                     regi = map phisicalReg . regs
 
-                    ff :: Operand s RW -> Operand s' k -> Gen (Int64, Int64, Code -> Code)
+                    ff :: Operand RW s -> Operand k s' -> Gen (Int64, Int64, Code -> Code)
                     ff a@(RegOp x) (RegOp x') | Just Refl <- sizeEqCheck x x', x == x' = do
                         (av, inita) <- mkVal f2 a
                         return (av, av, inita)
@@ -315,8 +315,8 @@                     otest i x | isShift i = x
                     otest _ x = if_ (if oF' then O else NO) (Xor rax rax) x
 
-                    rcx' = resizeOperand rcx :: Operand s RW
-                    rdx' = resizeOperand rdx :: Operand s RW
+                    rcx' = resizeOperand rcx :: Operand RW s
+                    rdx' = resizeOperand rdx :: Operand RW s
                     sa = size a
 
                     ((cF', oF'), res) = case sa of
@@ -349,14 +349,14 @@             Mov a_ b_ -> fff i Mov a_ b_
 
       where
-        mkVal :: IsSize s => Operand S64 RW -> Operand s k -> Gen (Int64, Code -> Code)
+        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) <>))
         mkVal helper x@(IPMemOp LabelRelValue{}) = do
             v <- arbVal $ size x
-            return (v, \c -> Scope $ Up Jmp {- <> align (size x) -} <:> Data (toBytes v) <.> c)
+            return (v, \c -> Scope $ Up jmp8 {- <> align (size x) -} <:> Data (toBytes v) <.> c)
         mkVal helper o@(MemOp (Addr (Just x) d i)) = do
             v <- arbVal $ size o
             (vi, setvi) <- case i of
@@ -368,7 +368,7 @@                 d' = (vi :: Int64) + case d of
                     NoDisp -> 0
                     Disp v -> fromIntegral v
-                rx = resizeOperand $ RegOp x :: Operand S64 RW
+                rx = resizeOperand $ RegOp x :: Operand RW S64
             return (v, ((leaData rx v <> Mov helper (imm d') <> Sub rx helper <> setvi) <>))
         mkVal helper o@(MemOp (Addr Nothing d (Just (sc, x)))) = do
             v <- arbVal $ size o
@@ -376,7 +376,7 @@                 d' = case d of
                     NoDisp -> 0 :: Int64
                     Disp v -> fromIntegral v
-                rx = resizeOperand $ RegOp x :: Operand S64 RW
+                rx = resizeOperand $ RegOp x :: Operand RW S64
             return (v, ((leaData rx v <> Mov helper (imm d') <> Sub rx helper) <>))
 
 

@@ -14,6 +14,7 @@ import Debug.Trace
 
 import CodeGen.X86.Asm
+import CodeGen.X86.CodeGen
 import CodeGen.X86.CallConv
 
 -------------------------------------------------------------- derived constructs
@@ -25,30 +26,44 @@ 
 infixr 5 <:>, <.>
 
--- | short conditional forward jump (no auto size available for forward jumps)
-j = j8
+-- | 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 (Just S8) c <> Up x <:> mempty
+j8 c x = J c (Just S8) <> Up x <:> mempty
 
 -- | near conditional forward jump
-j32 c x = J (Just S32) c <> Up x <:> mempty
+j32 c x = J c (Just S32) <> Up x <:> mempty
 
 -- | auto size conditional backward jump
-x `j_back` c = mempty <:> Up x <> J Nothing c
+x `j_back` c = mempty <:> Up x <> J c Nothing
 
 -- | short conditional backward jump
-x `j_back8` c = mempty <:> Up x <> J (Just S8) c
+x `j_back8` c = mempty <:> Up x <> J c (Just S8)
 
 -- | near conditional backward jump
-x `j_back32` c = mempty <:> Up x <> J (Just S32) c
+x `j_back32` c = mempty <:> Up x <> J c (Just S32)
 
-if_ c a b = (J (Just S8) c <> Up (Up a <> Jmp) <:> mempty) <> Up b <:> mempty
+if_ c a b = (J c (Just S8) <> Up (Up a <> jmp b) <:> mempty) <> Up b <:> mempty
 
-lea8 :: IsSize s => Operand s RW -> Operand S8 RW -> Code
+lea8 :: IsSize s => Operand RW s -> Operand RW S8 -> Code
 lea8 = Lea
 
-leaData r d = (lea8 r ipBase <> Up Jmp <:> mempty) <> Data (toBytes d) <:> mempty
+leaData r d = (lea8 r ipBase <> Up (jmp db) <:> mempty) <> db <:> mempty
+  where
+    db = Data (toBytes d)
 
 ------------------------------------------------------------------------------ 
 
@@ -57,8 +72,8 @@ ------------------------------------------------------------------------------ 
 -- * utils
 
-mov' :: forall s s' r . IsSize s' => Operand s RW -> Operand s' r -> Code
-mov' a b = Mov (resizeOperand a :: Operand s' RW) b
+mov' :: forall s s' r . IsSize s' => Operand RW s -> Operand r s' -> Code
+mov' a b = Mov (resizeOperand a :: Operand RW s') b
 
 newtype CString = CString String
 
@@ -66,13 +81,13 @@     toBytes (CString cs) = mconcat $ toBytes . (fromIntegral :: Int -> Word8) . fromEnum <$> (cs ++ "\0")
 
 -- | we should implement PUSHA and POPA later
-all_regs_except_rsp :: [Operand S64 rw]
+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 ]
 
-traceReg :: IsSize s => String -> Operand s RW -> Code
+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

@@ -11,6 +11,7 @@ -   codeBytes -> compile -   Bytes -> MachineCode ? -   Data -> DB+-   traceReg -> traceOp  # Documentation 

@@ -1,5 +1,5 @@ name:                x86-64bit
-version:             0.1.4
+version:             0.2
 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.