x86-64bit 0.4.5 → 0.4.6

raw patch · 11 files changed

+1427/−1437 lines, 11 filesdep ~QuickCheckdep ~basedep ~vectorsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck, base, vector

API changes (from Hackage documentation)

Files

• CodeGen/X86.hs +1/−5
• CodeGen/X86/Asm.hs +308/−277
• CodeGen/X86/CallConv.hs +27/−28
• CodeGen/X86/CodeGen.hs +429/−418
• CodeGen/X86/Examples.hs +0/−102
• CodeGen/X86/FFI.hs +2/−4
• CodeGen/X86/Tests.hs +456/−418
• CodeGen/X86/Utils.hs +111/−92
• Setup.hs +0/−2
• Test.hs +4/−4
• x86-64bit.cabal +89/−87

@@ -25,7 +25,7 @@     -- ** SSE registers     , xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7     -- * Addresses-    , Addr (..), BaseReg, IndexReg, Scale, Displacement, Address+    , Addr (..), BaseReg, IndexReg (..), Scale, s1, s2, s4, s8, Displacement, Address     , addr     , addr8     , addr16@@ -158,8 +158,6 @@     , printf     , hsPtr     , CString (..)-    -- * Misc-    , runTests     ) where  import Data.Monoid@@ -169,5 +167,3 @@ import CodeGen.X86.FFI import CodeGen.X86.CallConv import CodeGen.X86.Utils-import CodeGen.X86.Tests-

@@ -1,20 +1,21 @@-{-# language LambdaCase #-}-{-# language BangPatterns #-}-{-# language ViewPatterns #-}-{-# language PatternGuards #-}-{-# language PatternSynonyms #-}+{-# language GeneralizedNewtypeDeriving #-} {-# language NoMonomorphismRestriction #-} {-# language ScopedTypeVariables #-}-{-# language RankNTypes #-}+{-# language StandaloneDeriving #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language PatternSynonyms #-}+{-# language KindSignatures #-}+{-# language PatternGuards #-}+{-# language BangPatterns #-}+{-# language ViewPatterns #-} {-# language TypeFamilies #-}-{-# language GADTs #-}+{-# language LambdaCase #-}+{-# language RankNTypes #-} {-# language DataKinds #-}-{-# language KindSignatures #-} {-# language PolyKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# language StandaloneDeriving #-}+{-# language GADTs #-}+{-# language CPP #-} module CodeGen.X86.Asm where  import Numeric@@ -35,8 +36,7 @@  showNibble :: (Integral a, Bits a) => Int -> a -> Char showNibble n x = toEnum (b + if b < 10 then 48 else 87)-  where-    b = fromIntegral $ x `shiftR` (4*n) .&. 0x0f+  where b = fromIntegral $ x `shiftR` (4 * n) .&. 0x0f  showByte b = [showNibble 1 b, showNibble 0 b] @@ -50,30 +50,38 @@  class HasBytes a where toBytes :: a -> Bytes -instance HasBytes Word8  where toBytes w = [w]-instance HasBytes Word16 where toBytes w = [fromIntegral w, fromIntegral $ w `shiftR` 8]-instance HasBytes Word32 where toBytes w = [fromIntegral $ w `shiftR` n | n <- [0, 8.. 24]]-instance HasBytes Word64 where toBytes w = [fromIntegral $ w `shiftR` n | n <- [0, 8.. 56]]+instance HasBytes Word8  where+  toBytes w = [w]+instance HasBytes Word16 where+  toBytes w = [fromIntegral w, fromIntegral $ w `shiftR` 8]+instance HasBytes Word32 where+  toBytes w = [ fromIntegral $ w `shiftR` n | n <- [0, 8 .. 24] ]+instance HasBytes Word64 where+  toBytes w = [ fromIntegral $ w `shiftR` n | n <- [0, 8 .. 56] ] -instance HasBytes Int8  where toBytes w = toBytes (fromIntegral w :: Word8)-instance HasBytes Int16 where toBytes w = toBytes (fromIntegral w :: Word16)-instance HasBytes Int32 where toBytes w = toBytes (fromIntegral w :: Word32)-instance HasBytes Int64 where toBytes w = toBytes (fromIntegral w :: Word64)+instance HasBytes Int8  where+  toBytes w = toBytes (fromIntegral w :: Word8)+instance HasBytes Int16 where+  toBytes w = toBytes (fromIntegral w :: Word16)+instance HasBytes Int32 where+  toBytes w = toBytes (fromIntegral w :: Word32)+instance HasBytes Int64 where+  toBytes w = toBytes (fromIntegral w :: Word64)  ------------------------------------------------------- sizes  -- | The size of a register (in bits) data Size = S1 | S8 | S16 | S32 | S64 | S128-    deriving (Eq, Ord)+  deriving (Eq, Ord)  instance Show Size where-    show = \case-        S1   -> "bit"-        S8   -> "byte"-        S16  -> "word"-        S32  -> "dword"-        S64  -> "qword"-        S128 -> "oword"+  show = \case+    S1   -> "bit"+    S8   -> "byte"+    S16  -> "word"+    S32  -> "dword"+    S64  -> "qword"+    S128 -> "oword"  mkSize  1 = S8 mkSize  2 = S16@@ -82,11 +90,11 @@ mkSize 16 = S128  sizeLen = \case-    S8   ->  1-    S16  ->  2-    S32  ->  4-    S64  ->  8-    S128 -> 16+  S8   -> 1+  S16  -> 2+  S32  -> 4+  S64  -> 8+  S128 -> 16  class HasSize a where size :: a -> Size @@ -101,24 +109,24 @@  -- | Singleton type for size data SSize (s :: Size) where-    SSize1   :: SSize S1-    SSize8   :: SSize S8-    SSize16  :: SSize S16-    SSize32  :: SSize S32-    SSize64  :: SSize S64-    SSize128 :: SSize S128+  SSize1   :: SSize S1+  SSize8   :: SSize S8+  SSize16  :: SSize S16+  SSize32  :: SSize S32+  SSize64  :: SSize S64+  SSize128 :: SSize S128  instance HasSize (SSize s) where-    size = \case-        SSize1   -> S1-        SSize8   -> S8-        SSize16  -> S16-        SSize32  -> S32-        SSize64  -> S64-        SSize128 -> S128+  size = \case+    SSize1   -> S1+    SSize8   -> S8+    SSize16  -> S16+    SSize32  -> S32+    SSize64  -> S64+    SSize128 -> S128  class IsSize (s :: Size) where-    ssize :: SSize s+  ssize :: SSize s  instance IsSize S1   where ssize = SSize1 instance IsSize S8   where ssize = SSize8@@ -128,21 +136,21 @@ instance IsSize S128 where ssize = SSize128  data EqT s s' where-    Refl :: EqT s s+  Refl :: EqT s s  sizeEqCheck :: forall s s' f g . (IsSize s, IsSize s') => f s -> g s' -> Maybe (EqT s s') sizeEqCheck _ _ = case (ssize :: SSize s, ssize :: SSize s') of-    (SSize8 , SSize8)  -> Just Refl-    (SSize16, SSize16) -> Just Refl-    (SSize32, SSize32) -> Just Refl-    (SSize64, SSize64) -> Just Refl-    _ -> Nothing+  (SSize8 , SSize8)  -> Just Refl+  (SSize16, SSize16) -> Just Refl+  (SSize32, SSize32) -> Just Refl+  (SSize64, SSize64) -> Just Refl+  _ -> Nothing  ------------------------------------------------------- scale  -- | The scaling of an index. (replace with Size?) newtype Scale = Scale Word8-    deriving (Eq)+  deriving (Eq)  s1 = Scale 0x0 s2 = Scale 0x1@@ -150,25 +158,25 @@ s8 = Scale 0x3  toScale = \case-    1 -> s1-    2 -> s2-    4 -> s4-    8 -> s8+  1 -> s1+  2 -> s2+  4 -> s4+  8 -> s8  scaleFactor (Scale i) = case i of-    0x0 -> 1-    0x1 -> 2-    0x2 -> 4-    0x3 -> 8+  0x0 -> 1+  0x1 -> 2+  0x2 -> 4+  0x3 -> 8  ------------------------------------------------------- operand  -- | An operand can be an immediate, a register, a memory address or RIP-relative (memory address relative to the instruction pointer) data Operand :: Access -> Size -> * where-    ImmOp     :: Immediate Int64 -> Operand R s-    RegOp     :: Reg s -> Operand rw s-    MemOp     :: IsSize s' => Addr s' -> Operand rw s-    IPMemOp   :: Immediate Int32 -> Operand rw s+  ImmOp     :: Immediate Int64 -> Operand R s+  RegOp     :: Reg s -> Operand rw s+  MemOp     :: IsSize s' => Addr s' -> Operand rw s+  IPMemOp   :: Immediate Int32 -> Operand rw s  addr :: IsSize s => Address s -> Operand rw s' addr = MemOp . makeAddr@@ -190,25 +198,25 @@ addr64 = addr  data Immediate a-    = Immediate a-    | LabelRelValue Size{-size hint-} Label+  = Immediate a+  | LabelRelValue Size{-size hint-} Label  -- Type of labels newtype Label = Label {unLabel :: Int}  instance Show Label where-    show (Label i) = ".l" ++ show i+  show (Label i) = ".l" ++ show i  -- | Operand access modes data Access-    = R     -- ^ readable operand-    | RW    -- ^ readable and writeable operand+  = R     -- ^ readable operand+  | RW    -- ^ readable and writeable operand  -- | A register. data Reg :: Size -> * where-    NormalReg :: Word8 -> Reg s      -- \"normal\" registers are for example @AL@, @BX@, @ECX@ or @RSI@-    HighReg   :: Word8 -> Reg S8     -- \"high\" registers are @AH@, @BH@, @CH@ etc-    XMM       :: Word8 -> Reg S128   -- XMM registers+  NormalReg :: Word8 -> Reg s      -- \"normal\" registers are for example @AL@, @BX@, @ECX@ or @RSI@+  HighReg   :: Word8 -> Reg S8     -- \"high\" registers are @AH@, @BH@, @CH@ etc+  XMM       :: Word8 -> Reg S128   -- XMM registers  deriving instance Eq (Reg s) deriving instance Ord (Reg s)@@ -217,15 +225,17 @@ -- For example in @[eax+4*ecx+20]@ the base register is @eax@, the displacement is @20@ and the -- index is @4*ecx@. data Addr s = Addr-    { baseReg        :: BaseReg s-    , displacement   :: Displacement-    , indexReg       :: IndexReg s-    }-    deriving (Eq)+  { baseReg        :: BaseReg s+  , displacement   :: Displacement+  , indexReg       :: IndexReg s+  }+  deriving (Eq) -type BaseReg s    = Maybe (Reg s)-data IndexReg s   = NoIndex | IndexReg Scale (Reg s)-    deriving (Eq)+type BaseReg s = Maybe (Reg s)++data IndexReg s = NoIndex | IndexReg Scale (Reg s)+  deriving (Eq)+ type Displacement = Maybe Int32  pattern NoDisp = Nothing@@ -242,89 +252,106 @@ ipRel8 = ipRel  instance IsSize s => Show (Reg s) where-    show = \case-        XMM i -> "xmm" ++ show i-        HighReg i -> (["ah"," ch", "dh", "bh"] ++ repeat err) !! fromIntegral i-        r@(NormalReg i) -> (!! fromIntegral i) . (++ repeat err) $ case size r of-            S8   -> ["al", "cl", "dl", "bl", "spl", "bpl", "sil", "dil"] ++ map (++ "b") r8-            S16  -> r0 ++ map (++ "w") r8-            S32  -> map ('e':) r0 ++ map (++ "d") r8-            S64  -> map ('r':) r0 ++ r8-          where-            r0 = ["ax", "cx", "dx", "bx", "sp", "bp", "si", "di"]-            r8 = ["r8", "r9", "r10", "r11", "r12", "r13", "r14", "r15"]-      where-        err = error $ "show @ RegOp" -- ++ show (s, i)+  show (XMM i) = "xmm" ++ show i+  show (HighReg i) =+    (["ah", " ch", "dh", "bh"] ++ repeat (error ("show @Reg")))+      !! fromIntegral i +  show r@(NormalReg i) =+    (!! fromIntegral i) . (++ repeat (error ("show @Reg"))) $ case size r of+      S8 ->+        ["al", "cl", "dl", "bl", "spl", "bpl", "sil", "dil"] ++ map (++ "b") r8+      S16 -> r0 ++ map (++ "w") r8+      S32 -> map ('e' :) r0 ++ map (++ "d") r8+      S64 -> map ('r' :) r0 ++ r8+   where+    r0 = ["ax", "cx", "dx", "bx", "sp", "bp", "si", "di"]+    r8 = ["r8", "r9", "r10", "r11", "r12", "r13", "r14", "r15"]+ instance IsSize s => Show (Addr s) where-    show (Addr b d i) = showSum $ shb b ++ shd d ++ shi i-      where-        shb Nothing = []-        shb (Just x) = [(True, show x)]-        shd NoDisp = []-        shd (Disp x) = [(signum x /= (-1), show (abs x))]-        shi NoIndex = []-        shi (IndexReg sc x) = [(True, show' (scaleFactor sc) ++ show x)]-        show' 1 = ""-        show' n = show n ++ " * "-        showSum [] = "0"-        showSum ((True, x): xs) = x ++ g xs-        showSum ((False, x): xs) = "-" ++ x ++ g xs-        g = concatMap (\(a, b) -> f a ++ b)-        f True = " + "-        f False = " - "+  show (Addr b d i) = showSum $ shb b ++ shd d ++ shi i+   where+    shb Nothing  = []+    shb (Just x) = [(True, show x)]+    shd NoDisp   = []+    shd (Disp x) = [(signum x /= (-1), show (abs x))]+    shi NoIndex         = []+    shi (IndexReg sc x) = [(True, show' (scaleFactor sc) ++ show x)]+    show' 1 = ""+    show' n = show n ++ " * "+    showSum []                = "0"+    showSum ((True , x) : xs) = x ++ g xs+    showSum ((False, x) : xs) = "-" ++ x ++ g xs+    g = concatMap (\(a, b) -> f a ++ b)+    f True  = " + "+    f False = " - "  instance IsSize s => Show (Operand a s) where-    show = \case-        ImmOp w -> show w-        RegOp r -> show r-        r@(MemOp a) -> show (size r) ++ " [" ++ show a ++ "]"-        r@(IPMemOp x) -> show (size r) ++ " [" ++ "rel " ++ show x ++ "]"-      where-        showp x | x < 0 = " - " ++ show (-x)-        showp x = " + " ++ show x+  show = \case+    ImmOp w       -> show w+    RegOp r       -> show r+    r@(MemOp   a) -> show (size r) ++ " [" ++ show a ++ "]"+    r@(IPMemOp x) -> show (size r) ++ " [" ++ "rel " ++ show x ++ "]"+   where+    showp x | x < 0 = " - " ++ show (-x)+    showp x         = " + " ++ show x  instance Show a => Show (Immediate a) where-    show (Immediate x) = show x-    show (LabelRelValue s x) = show x+  show (Immediate x) = show x+  show (LabelRelValue s x) = show x  instance IsSize s => HasSize (Operand a s) where-    size _ = size (ssize :: SSize s)+  size _ = size (ssize :: SSize s)  instance IsSize s => HasSize (Addr s) where-    size _ = size (ssize :: SSize s)+  size _ = size (ssize :: SSize s)  instance IsSize s => HasSize (Address s) where-    size _ = size (ssize :: SSize s)+  size _ = size (ssize :: SSize s)  instance IsSize s => HasSize (BaseReg s) where-    size _ = size (ssize :: SSize s)+  size _ = size (ssize :: SSize s)  instance IsSize s => HasSize (Reg s) where-    size _ = size (ssize :: SSize s)+  size _ = size (ssize :: SSize s)  instance IsSize s => HasSize (IndexReg s) where-    size _ = size (ssize :: SSize s)+  size _ = size (ssize :: SSize s)  instance (rw ~ R) => Num (Operand rw s) where-    negate (ImmOp (Immediate x)) = ImmOp $ Immediate $ negate x-    fromInteger (Integral x) = ImmOp $ Immediate x-    fromInteger z = error $ show z ++ " does not fit into " -- ++ show s-    (+) = error "(+) @Operand"-    (-) = error "(-) @Operand"-    (*) = error "(*) @Operand"-    abs = error "abs @Operand"-    signum = error "signum @Operand"+  negate (ImmOp (Immediate x)) = ImmOp $ Immediate $ negate x+  fromInteger (Integral x) = ImmOp $ Immediate x+  fromInteger z = error $ show z ++ " does not fit into " -- ++ show s+  (+) = error "(+) @Operand"+  (-) = error "(-) @Operand"+  (*) = error "(*) @Operand"+  abs = error "abs @Operand"+  signum = error "signum @Operand" +#if MIN_VERSION_base(4,11,0)+instance Semigroup (Addr s) where+  Addr a b c <> Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (c <> c')++instance Semigroup (IndexReg s) where+  i <> NoIndex = i+  NoIndex <> i = i+#endif+ instance Monoid (Addr s) where-    mempty = Addr (getFirst mempty) (getFirst mempty) mempty-    Addr a b c `mappend` Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (c <> c')+  mempty = Addr (getFirst mempty) (getFirst mempty) mempty +#if !MIN_VERSION_base(4,11,0)+  Addr a b c `mappend` Addr a' b' c' = Addr (getFirst $ First a <> First a') (getFirst $ First b <> First b') (c <> c')+#endif+ instance Monoid (IndexReg s) where-    mempty = NoIndex-    i `mappend` NoIndex = i-    NoIndex `mappend` i = i+  mempty = NoIndex +#if !MIN_VERSION_base(4,11,0)+  i `mappend` NoIndex = i+  NoIndex `mappend` i = i+#endif+ base :: Reg s -> Addr s base x = Addr (Just x) NoDisp NoIndex @@ -341,31 +368,34 @@  disp :: (Bits a, Integral a) => a -> Addr s disp (Integral x)-    | x == 0 = mempty-    | otherwise = Addr Nothing (Disp x) NoIndex+  | x == 0 = mempty+  | otherwise = Addr Nothing (Disp x) NoIndex  data Address :: Size -> * where-    Address :: [(Int, Reg s)] -> Int -> Address s+  Address :: [(Int, Reg s)] -> Int -> Address s  scaleAddress :: (Int -> Int) -> Address s -> Address s scaleAddress f (Address rs d) = Address (first f <$> rs) $ f d  instance Num (Address s) where-    fromInteger d = Address [] $ fromInteger d-    negate = scaleAddress negate-    Address [] t * a = scaleAddress (t*) a-    a * Address [] t = scaleAddress (t*) a-    Address rs d + Address rs' d' = Address (f rs rs') (d + d') where-        f [] rs = rs-        f rs [] = rs-        f (p@(t, r): rs) (p'@(t', r'): rs') = case compare r r' of-            LT -> p: f rs (p': rs')-            GT -> p': f (p: rs) rs'-            EQ | t + t' == 0 -> f rs rs'-               | otherwise   -> (t + t', r): f rs rs'-    abs = error "abs @Address"-    signum = error "signum @Address"+  fromInteger d = Address [] $ fromInteger d+  negate = scaleAddress negate +  Address [] t * a            = scaleAddress (t *) a+  a            * Address [] t = scaleAddress (t *) a++  Address rs d + Address rs' d' = Address (f rs rs') (d + d')   where+    f []              rs                  = rs+    f rs              []                  = rs+    f (p@(t, r) : rs) (p'@(t', r') : rs') = case compare r r' of+      LT -> p : f rs (p' : rs')+      GT -> p' : f (p : rs) rs'+      EQ | t + t' == 0 -> f rs rs'+         | otherwise   -> (t + t', r) : f rs rs'++  abs    = error "abs @Address"+  signum = error "signum @Address"+ makeAddr :: Address s -> Addr s makeAddr (Address [(1, r)] d) = base r <> disp d makeAddr (Address [(t, r)] d) = index' t r <> disp d@@ -374,16 +404,16 @@ makeAddr (Address [(t, r'), (1, r)] d) = base r <> index' t r' <> disp d  class FromReg c where-    fromReg :: Reg s -> c s+  fromReg :: Reg s -> c s  instance FromReg Reg where-    fromReg = id+  fromReg = id  instance FromReg (Operand r) where-    fromReg = RegOp+  fromReg = RegOp  instance FromReg Address where-    fromReg r = Address [(1, r)] 0+  fromReg r = Address [(1, r)] 0  reg = fromReg . NormalReg @@ -526,23 +556,23 @@ pattern NLE = Condition 0xf  instance Show Condition where-    show (Condition x) = case x of-        0x0 -> "o"-        0x1 -> "no"-        0x2 -> "c"-        0x3 -> "nc"-        0x4 -> "z"-        0x5 -> "nz"-        0x6 -> "be"-        0x7 -> "nbe"-        0x8 -> "s"-        0x9 -> "ns"-        0xa -> "p"-        0xb -> "np"-        0xc -> "l"-        0xd -> "nl"-        0xe -> "le"-        0xf -> "nle"+  show (Condition x) = case x of+    0x0 -> "o"+    0x1 -> "no"+    0x2 -> "c"+    0x3 -> "nc"+    0x4 -> "z"+    0x5 -> "nz"+    0x6 -> "be"+    0x7 -> "nbe"+    0x8 -> "s"+    0x9 -> "ns"+    0xa -> "p"+    0xb -> "np"+    0xc -> "l"+    0xd -> "nl"+    0xe -> "le"+    0xf -> "nle"  pattern N cc <- (notCond -> cc)   where N = notCond@@ -552,42 +582,43 @@  -------------------------------------------------------------- asm code lines +{- HLINT ignore -} data CodeLine where-    Ret_, Nop_, PushF_, PopF_, Cmc_, Clc_, Stc_, Cli_, Sti_, Cld_, Std_   :: CodeLine+  Ret_, Nop_, PushF_, PopF_, Cmc_, Clc_, Stc_, Cli_, Sti_, Cld_, Std_ :: CodeLine -    Inc_, Dec_, Not_, Neg_, Bswap                               :: IsSize s => Operand RW s -> CodeLine-    Add_, Or_, Adc_, Sbb_, And_, Sub_, Xor_, Cmp_, Test_, Mov_, Bsf, Bsr :: IsSize s => Operand RW s -> Operand r s -> CodeLine-    Rol_, Ror_, Rcl_, Rcr_, Shl_, Shr_, Sar_                 :: IsSize s => Operand RW s -> Operand r S8 -> CodeLine-    Bt :: IsSize s => Operand r s -> Operand RW s -> CodeLine+  Inc_, Dec_, Not_, Neg_, Bswap                               :: IsSize s => Operand RW s -> CodeLine+  Add_, Or_, Adc_, Sbb_, And_, Sub_, Xor_, Cmp_, Test_, Mov_, Bsf, Bsr :: IsSize s => Operand RW s -> Operand r s -> CodeLine+  Rol_, Ror_, Rcl_, Rcr_, Shl_, Shr_, Sar_                 :: IsSize s => Operand RW s -> Operand r S8 -> CodeLine+  Bt :: IsSize s => Operand r s -> Operand RW s -> CodeLine -    Movdqa_, Paddb_, Paddw_, Paddd_, Paddq_, Psubb_, Psubw_, Psubd_, Psubq_, Pxor_ :: Operand RW S128 -> Operand r S128 -> CodeLine-    Psllw_, Pslld_, Psllq_, Pslldq_, Psrlw_, Psrld_, Psrlq_, Psrldq_, Psraw_, Psrad_ :: Operand RW S128 -> Operand r S8 -> CodeLine-    Movd_, Movq_ :: (IsSize s, IsSize s') => Operand RW s -> Operand r s' -> CodeLine+  Movdqa_, Paddb_, Paddw_, Paddd_, Paddq_, Psubb_, Psubw_, Psubd_, Psubq_, Pxor_ :: Operand RW S128 -> Operand r S128 -> CodeLine+  Psllw_, Pslld_, Psllq_, Pslldq_, Psrlw_, Psrld_, Psrlq_, Psrldq_, Psraw_, Psrad_ :: Operand RW S128 -> Operand r S8 -> CodeLine+  Movd_, Movq_ :: (IsSize s, IsSize s') => Operand RW s -> Operand r s' -> CodeLine -    Cmov_ :: IsSize s => Condition -> Operand RW s -> Operand RW s -> CodeLine-    Xchg_ :: IsSize s => Operand RW s -> Operand RW s -> CodeLine-    Lea_  :: (IsSize s, IsSize s') => Operand RW s -> Operand RW s' -> CodeLine+  Cmov_ :: IsSize s => Condition -> Operand RW s -> Operand RW s -> CodeLine+  Xchg_ :: IsSize s => Operand RW s -> Operand RW s -> CodeLine+  Lea_  :: (IsSize s, IsSize s') => Operand RW s -> Operand RW s' -> CodeLine -    Pop_  :: Operand RW S64 -> CodeLine-    Push_ :: Operand r  S64 -> CodeLine+  Pop_  :: Operand RW S64 -> CodeLine+  Push_ :: Operand r  S64 -> CodeLine -    Call_ :: Operand r S64 -> CodeLine-    Jmpq_ :: Operand r S64 -> CodeLine+  Call_ :: Operand r S64 -> CodeLine+  Jmpq_ :: Operand r S64 -> CodeLine -    J_    :: Condition -> Maybe Size -> Label -> CodeLine-    Jmp_  :: Maybe Size -> Label -> CodeLine+  J_    :: Condition -> Maybe Size -> Label -> CodeLine+  Jmp_  :: Maybe Size -> Label -> CodeLine -    Label_ :: CodeLine+  Label_ :: CodeLine -    Data_  :: Bytes -> CodeLine-    Align_ :: Int   -> CodeLine+  Data_  :: Bytes -> CodeLine+  Align_ :: Int   -> CodeLine  ------------------------- show code lines  newLabel = do-    i <- get-    put $ i + 1-    return $ Label i+  i <- get+  put $ i + 1+  return $ Label i  codeLine x = tell [x] @@ -598,80 +629,80 @@  showCodeLine :: CodeLine -> StateT Int (Writer [String]) () showCodeLine = \case-    Add_  op1 op2 -> showOp2 "add"  op1 op2-    Or_   op1 op2 -> showOp2 "or"   op1 op2-    Adc_  op1 op2 -> showOp2 "adc"  op1 op2-    Sbb_  op1 op2 -> showOp2 "sbb"  op1 op2-    And_  op1 op2 -> showOp2 "and"  op1 op2-    Sub_  op1 op2 -> showOp2 "sub"  op1 op2-    Xor_  op1 op2 -> showOp2 "xor"  op1 op2-    Cmp_  op1 op2 -> showOp2 "cmp"  op1 op2-    Test_ op1 op2 -> showOp2 "test" op1 op2-    Bsf   op1 op2 -> showOp2 "bsf"  op1 op2-    Bsr   op1 op2 -> showOp2 "bsr"  op1 op2-    Bt    op1 op2 -> showOp2 "bt"   op1 op2-    Rol_  op1 op2 -> showOp2 "rol"  op1 op2-    Ror_  op1 op2 -> showOp2 "ror"  op1 op2-    Rcl_  op1 op2 -> showOp2 "rcl"  op1 op2-    Rcr_  op1 op2 -> showOp2 "rcr"  op1 op2-    Shl_  op1 op2 -> showOp2 "shl"  op1 op2-    Shr_  op1 op2 -> showOp2 "shr"  op1 op2-    Sar_  op1 op2 -> showOp2 "sar"  op1 op2-    Mov_  op1 op2 -> showOp2 "mov"  op1 op2-    Cmov_ cc op1 op2 -> showOp2 ("cmov" ++ show cc) op1 op2-    Lea_  op1 op2 -> showOp2 "lea"  op1 op2-    Xchg_ op1 op2 -> showOp2 "xchg" op1 op2-    Movd_   op1 op2 -> showOp2 "movd"   op1 op2-    Movq_   op1 op2 -> showOp2 "movq"   op1 op2-    Movdqa_ op1 op2 -> showOp2 "movdqa" op1 op2-    Paddb_  op1 op2 -> showOp2 "paddb"  op1 op2-    Paddw_  op1 op2 -> showOp2 "paddw"  op1 op2-    Paddd_  op1 op2 -> showOp2 "paddd"  op1 op2-    Paddq_  op1 op2 -> showOp2 "paddq"  op1 op2-    Psubb_  op1 op2 -> showOp2 "psubb"  op1 op2-    Psubw_  op1 op2 -> showOp2 "psubw"  op1 op2-    Psubd_  op1 op2 -> showOp2 "psubd"  op1 op2-    Psubq_  op1 op2 -> showOp2 "psubq"  op1 op2-    Pxor_   op1 op2 -> showOp2 "pxor"   op1 op2-    Psllw_  op1 op2 -> showOp2 "psllw"  op1 op2-    Pslld_  op1 op2 -> showOp2 "pslld"  op1 op2-    Psllq_  op1 op2 -> showOp2 "psllq"  op1 op2-    Pslldq_ op1 op2 -> showOp2 "pslldq" op1 op2-    Psrlw_  op1 op2 -> showOp2 "psrlw"  op1 op2-    Psrld_  op1 op2 -> showOp2 "psrld"  op1 op2-    Psrlq_  op1 op2 -> showOp2 "psrlq"  op1 op2-    Psrldq_ op1 op2 -> showOp2 "psrldq" op1 op2-    Psraw_  op1 op2 -> showOp2 "psraw"  op1 op2-    Psrad_  op1 op2 -> showOp2 "psrad"  op1 op2-    Inc_  op -> showOp1 "inc"  op-    Dec_  op -> showOp1 "dec"  op-    Not_  op -> showOp1 "not"  op-    Neg_  op -> showOp1 "neg"  op-    Bswap op -> showOp1 "bswap" op-    Pop_  op -> showOp1 "pop"  op-    Push_ op -> showOp1 "push" op-    Call_ op -> showOp1 "call" op-    Jmpq_ op -> showOp1 "jmp"  op-    Ret_   -> showOp0 "ret"-    Nop_   -> showOp0 "nop"-    PushF_ -> showOp0 "pushf"-    PopF_  -> showOp0 "popf"-    Cmc_   -> showOp0 "cmc"-    Clc_   -> showOp0 "clc"-    Stc_   -> showOp0 "stc"-    Cli_   -> showOp0 "cli"-    Sti_   -> showOp0 "sti"-    Cld_   -> showOp0 "cld"-    Std_   -> showOp0 "std"+  Add_  op1 op2 -> showOp2 "add"  op1 op2+  Or_   op1 op2 -> showOp2 "or"   op1 op2+  Adc_  op1 op2 -> showOp2 "adc"  op1 op2+  Sbb_  op1 op2 -> showOp2 "sbb"  op1 op2+  And_  op1 op2 -> showOp2 "and"  op1 op2+  Sub_  op1 op2 -> showOp2 "sub"  op1 op2+  Xor_  op1 op2 -> showOp2 "xor"  op1 op2+  Cmp_  op1 op2 -> showOp2 "cmp"  op1 op2+  Test_ op1 op2 -> showOp2 "test" op1 op2+  Bsf   op1 op2 -> showOp2 "bsf"  op1 op2+  Bsr   op1 op2 -> showOp2 "bsr"  op1 op2+  Bt    op1 op2 -> showOp2 "bt"   op1 op2+  Rol_  op1 op2 -> showOp2 "rol"  op1 op2+  Ror_  op1 op2 -> showOp2 "ror"  op1 op2+  Rcl_  op1 op2 -> showOp2 "rcl"  op1 op2+  Rcr_  op1 op2 -> showOp2 "rcr"  op1 op2+  Shl_  op1 op2 -> showOp2 "shl"  op1 op2+  Shr_  op1 op2 -> showOp2 "shr"  op1 op2+  Sar_  op1 op2 -> showOp2 "sar"  op1 op2+  Mov_  op1 op2 -> showOp2 "mov"  op1 op2+  Cmov_ cc op1 op2 -> showOp2 ("cmov" ++ show cc) op1 op2+  Lea_  op1 op2 -> showOp2 "lea"  op1 op2+  Xchg_ op1 op2 -> showOp2 "xchg" op1 op2+  Movd_   op1 op2 -> showOp2 "movd"   op1 op2+  Movq_   op1 op2 -> showOp2 "movq"   op1 op2+  Movdqa_ op1 op2 -> showOp2 "movdqa" op1 op2+  Paddb_  op1 op2 -> showOp2 "paddb"  op1 op2+  Paddw_  op1 op2 -> showOp2 "paddw"  op1 op2+  Paddd_  op1 op2 -> showOp2 "paddd"  op1 op2+  Paddq_  op1 op2 -> showOp2 "paddq"  op1 op2+  Psubb_  op1 op2 -> showOp2 "psubb"  op1 op2+  Psubw_  op1 op2 -> showOp2 "psubw"  op1 op2+  Psubd_  op1 op2 -> showOp2 "psubd"  op1 op2+  Psubq_  op1 op2 -> showOp2 "psubq"  op1 op2+  Pxor_   op1 op2 -> showOp2 "pxor"   op1 op2+  Psllw_  op1 op2 -> showOp2 "psllw"  op1 op2+  Pslld_  op1 op2 -> showOp2 "pslld"  op1 op2+  Psllq_  op1 op2 -> showOp2 "psllq"  op1 op2+  Pslldq_ op1 op2 -> showOp2 "pslldq" op1 op2+  Psrlw_  op1 op2 -> showOp2 "psrlw"  op1 op2+  Psrld_  op1 op2 -> showOp2 "psrld"  op1 op2+  Psrlq_  op1 op2 -> showOp2 "psrlq"  op1 op2+  Psrldq_ op1 op2 -> showOp2 "psrldq" op1 op2+  Psraw_  op1 op2 -> showOp2 "psraw"  op1 op2+  Psrad_  op1 op2 -> showOp2 "psrad"  op1 op2+  Inc_  op -> showOp1 "inc"  op+  Dec_  op -> showOp1 "dec"  op+  Not_  op -> showOp1 "not"  op+  Neg_  op -> showOp1 "neg"  op+  Bswap op -> showOp1 "bswap" op+  Pop_  op -> showOp1 "pop"  op+  Push_ op -> showOp1 "push" op+  Call_ op -> showOp1 "call" op+  Jmpq_ op -> showOp1 "jmp"  op+  Ret_   -> showOp0 "ret"+  Nop_   -> showOp0 "nop"+  PushF_ -> showOp0 "pushf"+  PopF_  -> showOp0 "popf"+  Cmc_   -> showOp0 "cmc"+  Clc_   -> showOp0 "clc"+  Stc_   -> showOp0 "stc"+  Cli_   -> showOp0 "cli"+  Sti_   -> showOp0 "sti"+  Cld_   -> showOp0 "cld"+  Std_   -> showOp0 "std" -    Align_ s -> codeLine $ ".align " ++ show s-    Data_ x-        | 2 * length (filter isPrint x) > length x -> showOp "db" $ show (toEnum . fromIntegral <$> x :: String)-        | otherwise -> showOp "db" $ intercalate ", " (show <$> x)-      where-        isPrint c = c >= 32 && c <= 126+  Align_ s -> codeLine $ ".align " ++ show s+  Data_ x+      | 2 * length (filter isPrint x) > length x -> showOp "db" $ show (toEnum . fromIntegral <$> x :: String)+      | otherwise -> showOp "db" $ intercalate ", " (show <$> x)+    where+      isPrint c = c >= 32 && c <= 126 -    J_ cc s l -> showOp ("j" ++ show cc) $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l-    Jmp_ s  l -> showOp "jmp" $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l-    Label_    -> newLabel >>= codeLine . show+  J_ cc s l -> showOp ("j" ++ show cc) $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l+  Jmp_ s  l -> showOp "jmp" $ (case s of Just S8 -> "short "; Just S32 -> "near "; _ -> "") ++ show l+  Label_    -> newLabel >>= codeLine . show 

@@ -2,7 +2,6 @@  {-# language NoMonomorphismRestriction #-} {-# language CPP #-}-{-# language BangPatterns #-} {-# language DataKinds #-} module CodeGen.X86.CallConv where @@ -19,33 +18,33 @@ -- On Win64 the caller have to reserve 32 byte "shadow space" on the stack (and clean up after) callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p = do-    sub rsp 32-    mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p)-    call r-    add rsp 32+  sub rsp 32+  mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p)+  call r+  add rsp 32  #elif defined (darwin_HOST_OS)  -- OSX requires 16 byte alignment of the stack... callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p = do-    push r15              -- we will use r15 (non-volatile) to store old rsp-    mov r15 15            -- 0xf-    not_ r15              -- 0xffff ... fff0-    and_ r15 rsp          -- align rsp into r15-    xchg r15 rsp          -- new rsp = aligned, r15 = old rsp-    mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p)-    call r-    mov rsp r15           -- restore rsp-    pop r15               -- restore r15+  push r15              -- we will use r15 (non-volatile) to store old rsp+  mov r15 15            -- 0xf+  not_ r15              -- 0xffff ... fff0+  and_ r15 rsp          -- align rsp into r15+  xchg r15 rsp          -- new rsp = aligned, r15 = old rsp+  mov r (fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p)+  call r+  mov rsp r15           -- restore rsp+  pop r15               -- restore r15  #else  -- helper to call a function callFun :: Operand RW S64 -> FunPtr a -> Code callFun r p = do-    mov r $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p-    call r+  mov r $ fromIntegral $ ptrToIntPtr $ castFunPtrToPtr p+  call r  #endif @@ -91,16 +90,16 @@ result = rax  prologue = do-    push rbp-    push rbx-    push rdi-    push rsi+  push rbp+  push rbx+  push rdi+  push rsi  epilogue = do-    pop rsi-    pop rdi-    pop rbx-    pop rbp+  pop rsi+  pop rdi+  pop rbx+  pop rbp  #else @@ -117,12 +116,12 @@ result = rax  prologue = do-    push rbp-    push rbx+  push rbp+  push rbx  epilogue = do-    pop rbx-    pop rbp+  pop rbx+  pop rbp  #endif 

@@ -1,20 +1,18 @@-{-# language LambdaCase #-}-{-# language BangPatterns #-}-{-# language ViewPatterns #-}-{-# language PatternGuards #-}-{-# language PatternSynonyms #-}+{-# language GeneralizedNewtypeDeriving #-} {-# language NoMonomorphismRestriction #-} {-# language ScopedTypeVariables #-}-{-# language RankNTypes #-}+{-# language FlexibleInstances #-}+{-# language FlexibleContexts #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-} {-# language TypeFamilies #-}-{-# language GADTs #-}+{-# language RecursiveDo #-}+{-# language LambdaCase #-}+{-# language RankNTypes #-} {-# language DataKinds #-}-{-# language KindSignatures #-} {-# language PolyKinds #-}-{-# language FlexibleContexts #-}-{-# language FlexibleInstances #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# language RecursiveDo #-}+{-# language GADTs #-}+{-# language CPP #-} module CodeGen.X86.CodeGen where  import Numeric@@ -60,7 +58,7 @@ ------------------------------------------------------- register packed with its size  data SReg where-    SReg :: IsSize s => Reg s -> SReg+  SReg :: IsSize s => Reg s -> SReg  phisicalReg :: SReg -> Reg S64 phisicalReg (SReg (HighReg x)) = NormalReg x@@ -71,9 +69,9 @@  regs :: IsSize s => Operand r s -> [SReg] regs = \case-    MemOp (Addr r _ i) -> foldMap (pure . SReg) r ++ case i of NoIndex -> []; IndexReg _ x -> [SReg x]-    RegOp r -> [SReg r]-    _ -> mempty+  MemOp (Addr r _ i) -> foldMap (pure . SReg) r ++ case i of NoIndex -> []; IndexReg _ x -> [SReg x]+  RegOp r -> [SReg r]+  _ -> mempty  isRex (SReg x@(NormalReg r)) = r .&. 0x8 /= 0 || size x == S8 && r `shiftR` 2 == 1 isRex _ = False@@ -90,120 +88,131 @@ type CodeBuilderTardis = Tardis (Int, [Int]) (Int, [Int], LabelState)  data CodeBuilder = CodeBuilder-    { minLen, maxLen :: Int-    , getCodeBuilder :: WriterT CodeBuilderRes CodeBuilderTardis ()-    }+  { minLen, maxLen :: Int+  , getCodeBuilder :: WriterT CodeBuilderRes CodeBuilderTardis ()+  }  codeBuilderLength (CodeBuilder a b _) | a == b = a  type LabelState = [[(Size, Int, Int)]] +#if MIN_VERSION_base(4,11,0)+instance Semigroup CodeBuilder where+  CodeBuilder mi ma a <> CodeBuilder mi' ma' b = CodeBuilder (min mi mi') (max ma ma') $ a >> b+#endif+ instance Monoid CodeBuilder where-    mempty = CodeBuilder 0 0 $ return ()-    CodeBuilder mi ma a `mappend` CodeBuilder mi' ma' b = CodeBuilder (min mi mi') (max ma ma') $ a >> b+  mempty = CodeBuilder 0 0 $ return ()+#if !MIN_VERSION_base(4,11,0)+  CodeBuilder mi ma a `mappend` CodeBuilder mi' ma' b = CodeBuilder (min mi mi') (max ma ma') $ a >> b+#endif  codeBytes :: [Word8] -> CodeBuilder codeBytes bs = CodeBuilder n n $ do-    c <- lift $ mdo-        (c, ls, ps) <- getPast-        sendFuture (c + n, ls, ps)-        sendPast (ma + n, mls)-        ~(ma, mls) <- getFuture-        return c-    tell $ Right <$> zip [c..] bs+  c <- lift $ mdo+    (c, ls, ps) <- getPast+    sendFuture (c + n, ls, ps)+    sendPast (ma + n, mls)+    ~(ma, mls) <- getFuture+    return c+  tell $ Right <$> zip [c..] bs   where-    n = length bs+  n = length bs  codeByte :: Word8 -> CodeBuilder codeByte = codeBytes . (:[])  mkRef :: Size -> Int -> Label -> CodeBuilder mkRef s@(sizeLen -> sn) offset (Label l_) = CodeBuilder sn sn $ do-    bs <- lift $ mdo-        (n, ls, ps) <- getPast-        sendFuture (n + sn, ls, ps')-        sendPast (ma + sn, mls)-        ~(ma, mls) <- getFuture-        let i = ls !! (- l - 1)-            vx = i - n - offset-            z = case s of-                S8  -> case vx of-                    Integral j -> toBytes (j :: Int8)-                    _ -> error $ show vx ++ " does not fit into an Int8"-                S32  -> case vx of-                    Integral j -> toBytes (j :: Int32)-                    _ -> error $ show vx ++ " does not fit into an Int32"-            ~(bs, ps')-                | l < 0 = (z, ps)-                | otherwise = ([], ins l (s, n, - n - offset) ps)-            l = l_ - length ls-        return $ zip [n..] bs-    tell $ Right <$> bs+  bs <- lift $ mdo+    (n, ls, ps) <- getPast+    sendFuture (n + sn, ls, ps')+    sendPast (ma + sn, mls)+    ~(ma, mls) <- getFuture+    let i = ls !! (- l - 1)+        vx = i - n - offset+        z = case s of+          S8  -> case vx of+            Integral j -> toBytes (j :: Int8)+            _ -> error $ show vx ++ " does not fit into an Int8"+          S32  -> case vx of+            Integral j -> toBytes (j :: Int32)+            _ -> error $ show vx ++ " does not fit into an Int32"+        ~(bs, ps')+          | l < 0 = (z, ps)+          | otherwise = ([], ins l (s, n, - n - offset) ps)+        l = l_ - length ls+    return $ zip [n..] bs+  tell $ Right <$> bs  ins :: Int -> a -> [[a]] -> [[a]]-ins 0 a [] = [a]: []+ins 0 a [] = [[a]] ins 0 a (as:ass) = (a:as): ass ins n a [] = []: ins (n-1) a [] ins n a (as: ass) = as: ins (n-1) a ass  mkAutoRef :: [(Size, Bytes)] -> Label -> CodeBuilder mkAutoRef ss (Label l_) = CodeBuilder (minimum sizes) (maximum sizes) $ do-    bs <- lift $ mdo-        (n, ls, ps) <- getPast-        sendFuture (n + sn, ls, ps')-        sendPast (ma + maximum sizes, mls)-        ~(ma, mls) <- getFuture-        let i = ls !! (- l - 1)-            vx = i - n-            z = g ss-            g [] = error $ show vx ++ " does not fit into auto size"-            g ((s, c): ss) = case (s, vx - length c - sizeLen s) of-                (S8,  Integral j) -> c <> toBytes (j :: Int8)-                (S32, Integral j) -> c <> toBytes (j :: Int32)-                _ -> g ss-            ~(sn, bs, ps')-                | l < 0 = (length z, z, ps)-                | otherwise = (nz, z', ins l (s, n + length z', - n - nz) ps)-            nz = length z' + sizeLen s-            ma' = mls !! l-            vx' = ma - ma'-            (z', s) = g' ss-            g' [] = error $ show vx' ++ " does not fit into auto size"-            g' ((s, c): ss) = case (s, vx') of-                (S8,  Integral (j :: Int8)) -> (c, s)-                (S32, Integral (j :: Int32)) -> (c, s)-                _ -> g' ss-            l = l_ - length ls-        return $ zip [n..] bs-    tell $ Right <$> bs+  bs <- lift $ mdo+    (n, ls, ps) <- getPast+    sendFuture (n + sn, ls, ps')+    sendPast (ma + maximum sizes, mls)+    ~(ma, mls) <- getFuture+    let i = ls !! (- l - 1)+        vx = i - n+        z = g ss++        g [] = error $ show vx ++ " does not fit into auto size"+        g ((s, c): ss) = case (s, vx - length c - sizeLen s) of+          (S8,  Integral j) -> c <> toBytes (j :: Int8)+          (S32, Integral j) -> c <> toBytes (j :: Int32)+          _ -> g ss++        ~(sn, bs, ps')+          | l < 0 = (length z, z, ps)+          | otherwise = (nz, z', ins l (s, n + length z', - n - nz) ps)++        nz = length z' + sizeLen s+        ma' = mls !! l+        vx' = ma - ma'+        (z', s) = g' ss++        g' [] = error $ show vx' ++ " does not fit into auto size"+        g' ((s, c): ss) = case (s, vx') of+          (S8,  Integral (j :: Int8)) -> (c, s)+          (S32, Integral (j :: Int32)) -> (c, s)+          _ -> g' ss++        l = l_ - length ls+    return $ zip [n..] bs+  tell $ Right <$> bs   where-    sizes = map (\(s, c) -> sizeLen s + length c) ss+  sizes = map (\(s, c) -> sizeLen s + length c) ss  -- prebuild code preBuild :: Code -> Code preBuild c = CodeM $ tell $ Prebuilt (compactCode (buildCode lc)) lc   where-    lc = withLabels c+  lc = withLabels c  ------------------------------------------------------- code to code builder  instance Show Code where-    show = show . withLabels+  show = show . withLabels  instance Show LCode where-    show c = unlines $ zipWith3 showLine is (takes (zipWith (-) (tail is ++ [s]) is) bs) ss-      where-        ss = snd . runWriter . flip evalStateT 0 . showCode $ c-        (x, s) = buildCode c-        bs = V.toList $ compactCode (x, s)-        is = [i | Left i <- x]+  show c = unlines $ zipWith3 showLine is (takes (zipWith (-) (tail is ++ [s]) is) bs) ss where+    ss = snd . runWriter . flip evalStateT 0 . showCode $ c+    (x, s) = buildCode c+    bs = V.toList $ compactCode (x, s)+    is = [i | Left i <- x] -        showLine addr [] s = s-        showLine addr bs s = [showNibble i addr | i <- [5,4..0]] ++ " " ++ pad (2 * maxbytes) (concatMap showByte bs) ++ " " ++ s+    showLine addr [] s = s+    showLine addr bs s = [showNibble i addr | i <- [5,4..0]] ++ " " ++ pad (2 * maxbytes) (concatMap showByte bs) ++ " " ++ s -        pad i xs = xs ++ replicate (i - length xs) ' '+    pad i xs = xs ++ replicate (i - length xs) ' ' -        maxbytes = 12+    maxbytes = 12  compactCode :: (CodeBuilderRes, Int) -> V.Vector Word8 compactCode (x, s) = V.replicate s 0 V.// [p | Right p <- x]@@ -214,390 +223,395 @@ buildCode :: LCode -> (CodeBuilderRes, Int) buildCode x = (r, len)   where-    ((_, r), (_, (len, _, _))) = flip runTardis ((0, []), (0, [], [])) . runWriterT . getCodeBuilder . mkCodeBuilder $ x+  ((_, r), (_, (len, _, _))) = flip runTardis ((0, []), (0, [], [])) . runWriterT . getCodeBuilder . mkCodeBuilder $ x  mkCodeBuilder :: LCode -> CodeBuilder mkCodeBuilder = \case-    CodeLine x _ -> x-    Prebuilt v _ -> mkCodeBuilder' (Align_ 4) <> codeBytes (V.toList v)-    AppendCode x _ _ -> x-    EmptyCode -> mempty+  CodeLine x _ -> x+  Prebuilt v _ -> mkCodeBuilder' (Align_ 4) <> codeBytes (V.toList v)+  AppendCode x _ _ -> x+  EmptyCode -> mempty  newtype CodeM a = CodeM {unCodeM :: StateT Int (Writer LCode) a}-    deriving (Functor, Applicative, Monad, MonadFix)+  deriving (Functor, Applicative, Monad, MonadFix)  type Code = CodeM ()  withLabels :: Code -> LCode withLabels =-    snd . runWriter . flip evalStateT 0 . unCodeM+  snd . runWriter . flip evalStateT 0 . unCodeM  -- multi-byte nop operations nops :: Int -> Bytes nops = \case-    0 -> []-    1 -> [0x90]-    2 -> [0x66, 0x90]-    3 -> [0x0f, 0x1f, 0x00]-    4 -> [0x0f, 0x1f, 0x40, 0x00]-    5 -> [0x0f, 0x1f, 0x44, 0x00, 0x00]-    6 -> [0x66, 0x0f, 0x1f, 0x44, 0x00, 0x00]-    7 -> [0x0f, 0x1f, 0x80, 0x00, 0x00, 0x00, 0x00]-    8 -> [0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00]-    9 -> [0x66, 0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00]-    ((+(-2)) -> Integral x) -> [0xeb] ++ toBytes (x :: Int8) ++ replicate (fromIntegral x) 0x00-    ((+(-5)) -> Integral x) -> [0xe9] ++ toBytes (x :: Int32) ++ replicate (fromIntegral x) 0x00+  0 -> []+  1 -> [0x90]+  2 -> [0x66, 0x90]+  3 -> [0x0f, 0x1f, 0x00]+  4 -> [0x0f, 0x1f, 0x40, 0x00]+  5 -> [0x0f, 0x1f, 0x44, 0x00, 0x00]+  6 -> [0x66, 0x0f, 0x1f, 0x44, 0x00, 0x00]+  7 -> [0x0f, 0x1f, 0x80, 0x00, 0x00, 0x00, 0x00]+  8 -> [0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00]+  9 -> [0x66, 0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00]+  ((+(-2)) -> Integral x) -> [0xeb] ++ toBytes (x :: Int8) ++ replicate (fromIntegral x) 0x00+  ((+(-5)) -> Integral x) -> [0xe9] ++ toBytes (x :: Int32) ++ replicate (fromIntegral x) 0x00  mkCodeBuilder' :: CodeLine -> CodeBuilder mkCodeBuilder' = \case-    Add_  a b -> op2 0x0 a b-    Or_   a b -> op2 0x1 a b-    Adc_  a b -> op2 0x2 a b-    Sbb_  a b -> op2 0x3 a b-    And_  a b -> op2 0x4 a b-    Sub_  a b -> op2 0x5 a b-    Xor_  a b -> op2 0x6 a b-    Cmp_  a b -> op2 0x7 a b+  Add_  a b -> op2 0x0 a b+  Or_   a b -> op2 0x1 a b+  Adc_  a b -> op2 0x2 a b+  Sbb_  a b -> op2 0x3 a b+  And_  a b -> op2 0x4 a b+  Sub_  a b -> op2 0x5 a b+  Xor_  a b -> op2 0x6 a b+  Cmp_  a b -> op2 0x7 a b -    Rol_ a b -> shiftOp 0x0 a b-    Ror_ a b -> shiftOp 0x1 a b-    Rcl_ a b -> shiftOp 0x2 a b-    Rcr_ a b -> shiftOp 0x3 a b-    Shl_ a b -> shiftOp 0x4 a b -- sal-    Shr_ a b -> shiftOp 0x5 a b-    Sar_ a b -> shiftOp 0x7 a b+  Rol_ a b -> shiftOp 0x0 a b+  Ror_ a b -> shiftOp 0x1 a b+  Rcl_ a b -> shiftOp 0x2 a b+  Rcr_ a b -> shiftOp 0x3 a b+  Shl_ a b -> shiftOp 0x4 a b -- sal+  Shr_ a b -> shiftOp 0x5 a b+  Sar_ a b -> shiftOp 0x7 a b -    Xchg_ x@RegA r -> xchg_a r-    Xchg_ r x@RegA -> xchg_a r-    Xchg_ dest src -> op2' 0x43 dest' src-      where-        (dest', src') = if isMemOp src then (src, dest) else (dest, src)+  Xchg_ x@RegA r -> xchg_a r+  Xchg_ r x@RegA -> xchg_a r+  Xchg_ dest src -> op2' 0x43 dest' src where+    (dest', src') = if isMemOp src then (src, dest) else (dest, src) -    Test_ dest (mkImmNo64 (size dest) -> FJust (_, im)) -> case dest of-        RegA -> regprefix'' dest 0x54 mempty im-        _ -> regprefix'' dest 0x7b (reg8 0x0 dest) im-    Test_ dest (noImm "" -> src) -> op2' 0x42 dest' src'-      where-        (dest', src') = if isMemOp src then (src, dest) else (dest, src)+  Test_ dest (mkImmNo64 (size dest) -> FJust (_, im)) -> case dest of+    RegA -> regprefix'' dest 0x54 mempty im+    _ -> regprefix'' dest 0x7b (reg8 0x0 dest) im+  Test_ dest (noImm "" -> src) -> op2' 0x42 dest' src' where+    (dest', src') = if isMemOp src then (src, dest) else (dest, src) -    Mov_ dest@(RegOp r) ((if size dest == S64 then mkImmU S32 <> mkImm S64 else mkImm (size dest)) -> FJust ((se, si), im))-        | (se, si, size dest) /= (True, S32, S64) -> regprefix si dest (oneReg (0x16 .|. indicator (size dest /= S8)) r) im-        | otherwise -> regprefix'' dest 0x63 (reg8 0x0 dest) im-    Mov_ dest@(size -> s) (mkImmNo64 s -> FJust (_, im)) -> regprefix'' dest 0x63 (reg8 0x0 dest) im-    Mov_ dest src -> op2' 0x44 dest $ noImm (show (dest, src)) src+  Mov_ dest@(RegOp r) ((if size dest == S64 then mkImmU S32 <> mkImm S64 else mkImm (size dest)) -> FJust ((se, si), im))+    | (se, si, size dest) /= (True, S32, S64) -> regprefix si dest (oneReg (0x16 .|. indicator (size dest /= S8)) r) im+    | otherwise -> regprefix'' dest 0x63 (reg8 0x0 dest) im+  Mov_ dest@(size -> s) (mkImmNo64 s -> FJust (_, im)) -> regprefix'' dest 0x63 (reg8 0x0 dest) im+  Mov_ dest src -> op2' 0x44 dest $ noImm (show (dest, src)) src -    Cmov_ (Condition c) dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte (0x40 .|. c) <> reg2x8 dest src-    Bsf dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbc <> reg2x8 dest src-    Bsr dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbd <> reg2x8 dest src-    Bt  src dest | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xa3 <> reg2x8 dest src+  Cmov_ (Condition c) dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte (0x40 .|. c) <> reg2x8 dest src+  Bsf dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbc <> reg2x8 dest src+  Bsr dest src | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xbd <> reg2x8 dest src+  Bt  src dest | size dest /= S8 -> regprefix2 src dest $ codeByte 0x0f <> codeByte 0xa3 <> reg2x8 dest src -    Lea_ dest src | size dest /= S8 -> regprefix2' (resizeOperand' dest src) dest 0x46 $ reg2x8 dest src-      where-        resizeOperand' :: IsSize s1 => Operand x s1 -> Operand RW s2 -> Operand RW s1-        resizeOperand' _ = resizeOperand+  Lea_ dest src | size dest /= S8 -> regprefix2' (resizeOperand' dest src) dest 0x46 $ reg2x8 dest src where+    resizeOperand' :: IsSize s1 => Operand x s1 -> Operand RW s2 -> Operand RW s1+    resizeOperand' _ = resizeOperand -    Not_  a -> op1 0x7b 0x2 a-    Neg_  a -> op1 0x7b 0x3 a-    Inc_  a -> op1 0x7f 0x0 a-    Dec_  a -> op1 0x7f 0x1 a-    Bswap a@RegOp{} | size a >= S32 -> op1 0x07 0x1 a-    Bswap a  -> error $ "wrong bswap operand: " ++ show a+  Not_  a -> op1 0x7b 0x2 a+  Neg_  a -> op1 0x7b 0x3 a+  Inc_  a -> op1 0x7f 0x0 a+  Dec_  a -> op1 0x7f 0x1 a+  Bswap a@RegOp{} | size a >= S32 -> op1 0x07 0x1 a+  Bswap a  -> error $ "wrong bswap operand: " ++ show a -    Call_ (ImmOp (LabelRelValue S32 l)) -> codeByte 0xe8 <> mkRef S32 4 l-    Call_ a -> op1' 0xff 0x2 a+  Call_ (ImmOp (LabelRelValue S32 l)) -> codeByte 0xe8 <> mkRef S32 4 l+  Call_ a -> op1' 0xff 0x2 a -    Movd_ a@OpXMM b -> sse 0x6e a b-    Movd_ b a@OpXMM -> sse 0x7e a b-    Movq_ b a@OpXMM -> sse 0xd6 a b-    Movdqa_ a@OpXMM b -> sse 0x6f a b-    Movdqa_ b a@OpXMM -> sse 0x7f a b-    Paddb_  a b -> sse 0xfc a b-    Paddw_  a b -> sse 0xfd a b-    Paddd_  a b -> sse 0xfe a b-    Paddq_  a b -> sse 0xd4 a b-    Psubb_  a b -> sse 0xf8 a b-    Psubw_  a b -> sse 0xf9 a b-    Psubd_  a b -> sse 0xfa a b-    Psubq_  a b -> sse 0xfb a b-    Pxor_   a b -> sse 0xef a b-    Psllw_  a b -> sseShift 0x71 0x2 0xd1 a b-    Pslld_  a b -> sseShift 0x72 0x2 0xd2 a b-    Psllq_  a b -> sseShift 0x73 0x2 0xd3 a b-    Pslldq_ a b -> sseShift 0x73 0x7 undefined a b-    Psrlw_  a b -> sseShift 0x71 0x6 0xf1 a b-    Psrld_  a b -> sseShift 0x72 0x6 0xf2 a b-    Psrlq_  a b -> sseShift 0x73 0x6 0xf3 a b-    Psrldq_ a b -> sseShift 0x73 0x3 undefined a b-    Psraw_  a b -> sseShift 0x71 0x4 0xe1 a b-    Psrad_  a b -> sseShift 0x72 0x4 0xe2 a b+  Movd_ a@OpXMM b -> sse 0x6e a b+  Movd_ b a@OpXMM -> sse 0x7e a b+  Movq_ b a@OpXMM -> sse 0xd6 a b+  Movdqa_ a@OpXMM b -> sse 0x6f a b+  Movdqa_ b a@OpXMM -> sse 0x7f a b+  Paddb_  a b -> sse 0xfc a b+  Paddw_  a b -> sse 0xfd a b+  Paddd_  a b -> sse 0xfe a b+  Paddq_  a b -> sse 0xd4 a b+  Psubb_  a b -> sse 0xf8 a b+  Psubw_  a b -> sse 0xf9 a b+  Psubd_  a b -> sse 0xfa a b+  Psubq_  a b -> sse 0xfb a b+  Pxor_   a b -> sse 0xef a b+  Psllw_  a b -> sseShift 0x71 0x2 0xd1 a b+  Pslld_  a b -> sseShift 0x72 0x2 0xd2 a b+  Psllq_  a b -> sseShift 0x73 0x2 0xd3 a b+  Pslldq_ a b -> sseShift 0x73 0x7 undefined a b+  Psrlw_  a b -> sseShift 0x71 0x6 0xf1 a b+  Psrld_  a b -> sseShift 0x72 0x6 0xf2 a b+  Psrlq_  a b -> sseShift 0x73 0x6 0xf3 a b+  Psrldq_ a b -> sseShift 0x73 0x3 undefined a b+  Psraw_  a b -> sseShift 0x71 0x4 0xe1 a b+  Psrad_  a b -> sseShift 0x72 0x4 0xe2 a b -    Pop_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty-    Pop_ dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty+  Pop_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0b r) mempty+  Pop_ dest -> regprefix S32 dest (codeByte 0x8f <> reg8 0x0 dest) mempty -    Push_ (mkImmS S8 -> FJust (_, im)) -> codeByte 0x6a <> im-    Push_ (mkImm S32 -> FJust (_, im)) -> codeByte 0x68 <> im-    Push_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty-    Push_ dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty+  Push_ (mkImmS S8 -> FJust (_, im)) -> codeByte 0x6a <> im+  Push_ (mkImm S32 -> FJust (_, im)) -> codeByte 0x68 <> im+  Push_ dest@(RegOp r) -> regprefix S32 dest (oneReg 0x0a r) mempty+  Push_ dest -> regprefix S32 dest (codeByte 0xff <> reg8 0x6 dest) mempty -    Ret_   -> codeByte 0xc3-    Nop_   -> codeByte 0x90-    PushF_ -> codeByte 0x9c-    PopF_  -> codeByte 0x9d-    Cmc_   -> codeByte 0xf5-    Clc_   -> codeByte 0xf8-    Stc_   -> codeByte 0xf9-    Cli_   -> codeByte 0xfa-    Sti_   -> codeByte 0xfb-    Cld_   -> codeByte 0xfc-    Std_   -> codeByte 0xfd+  Ret_   -> codeByte 0xc3+  Nop_   -> codeByte 0x90+  PushF_ -> codeByte 0x9c+  PopF_  -> codeByte 0x9d+  Cmc_   -> codeByte 0xf5+  Clc_   -> codeByte 0xf8+  Stc_   -> codeByte 0xf9+  Cli_   -> codeByte 0xfa+  Sti_   -> codeByte 0xfb+  Cld_   -> codeByte 0xfc+  Std_   -> codeByte 0xfd -    J_ (Condition c) (Just S8)  l -> codeByte (0x70 .|. c) <> mkRef S8 1 l-    J_ (Condition c) (Just S32) l -> codeByte 0x0f <> codeByte (0x80 .|. c) <> mkRef S32 4 l-    J_ (Condition c) Nothing    l -> mkAutoRef [(S8, [0x70 .|. c]), (S32, [0x0f, 0x80 .|. c])] l+  J_ (Condition c) (Just S8)  l -> codeByte (0x70 .|. c) <> mkRef S8 1 l+  J_ (Condition c) (Just S32) l -> codeByte 0x0f <> codeByte (0x80 .|. c) <> mkRef S32 4 l+  J_ (Condition c) Nothing  l -> mkAutoRef [(S8, [0x70 .|. c]), (S32, [0x0f, 0x80 .|. c])] l -    Jmp_ (Just S8)  l -> codeByte 0xeb <> mkRef S8 1 l-    Jmp_ (Just S32) l -> codeByte 0xe9 <> mkRef S32 4 l-    Jmp_ Nothing    l -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l+  Jmp_ (Just S8)  l -> codeByte 0xeb <> mkRef S8 1 l+  Jmp_ (Just S32) l -> codeByte 0xe9 <> mkRef S32 4 l+  Jmp_ Nothing  l -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l -    Jmpq_ (ImmOp (LabelRelValue S32 l)) -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l-    Jmpq_ a -> op1' 0xff 0x4 a+  Jmpq_ (ImmOp (LabelRelValue S32 l)) -> mkAutoRef [(S8, [0xeb]), (S32, [0xe9])] l+  Jmpq_ a -> op1' 0xff 0x4 a -    Label_ -> CodeBuilder 0 0 $ do-        bs <- lift $ mdo-            (n, ls, ps) <- getPast-            sendFuture (n, n: ls, ps')-            sendPast (ma, ma: mls)-            ~(ma, mls) <- getFuture-            let (bs, ps') = case ps of-                    [] -> ([], [])-                    corr: ps -> (concatMap g corr, ps)-                g (size, p, v) = zip [p..] $ case (size, v + n) of-                    (S8, Integral v) -> toBytes (v :: Int8)-                    (S32, Integral v) -> toBytes (v :: Int32)-                    (s, i) -> error $ show i ++ " doesn't fit into " ++ show s-            return bs-        tell $ Right <$> bs+  Label_ -> CodeBuilder 0 0 $ do+    bs <- lift $ mdo+      (n, ls, ps) <- getPast+      sendFuture (n, n: ls, ps')+      sendPast (ma, ma: mls)+      ~(ma, mls) <- getFuture+      let (bs, ps') = case ps of+            [] -> ([], [])+            corr: ps -> (concatMap g corr, ps)+          g (size, p, v) = zip [p..] $ case (size, v + n) of+            (S8, Integral v) -> toBytes (v :: Int8)+            (S32, Integral v) -> toBytes (v :: Int32)+            (s, i) -> error $ show i ++ " doesn't fit into " ++ show s+      return bs+    tell $ Right <$> bs  -    Data_ x -> codeBytes x+  Data_ x -> codeBytes x -    Align_ s -> CodeBuilder 0 (s-1) $ do-        bs <- lift $ mdo-            (n, ls, ps) <- getPast-            sendFuture (n', ls, ps)-            sendPast (ma + s-1, mls)-            ~(ma, mls) <- getFuture-            let n' = fromIntegral $ ((fromIntegral n - 1 :: Int64) .|. (fromIntegral s - 1)) + 1-            return $ zip [n..] $ nops $ n' - n-        tell $ Right <$> bs+  Align_ s -> CodeBuilder 0 (s-1) $ do+    bs <- lift $ mdo+      (n, ls, ps) <- getPast+      sendFuture (n', ls, ps)+      sendPast (ma + s-1, mls)+      ~(ma, mls) <- getFuture+      let n' = fromIntegral $ ((fromIntegral n - 1 :: Int64) .|. (fromIntegral s - 1)) + 1+      return $ zip [n..] $ nops $ n' - n+    tell $ Right <$> bs    where-    convertImm :: Bool{-signed-} -> Size -> Operand r s -> First ((Bool, Size), CodeBuilder)-    convertImm a b (ImmOp (Immediate c)) = First $ (,) (a, b) . codeBytes <$> integralToBytes a b c-    convertImm True b (ImmOp (LabelRelValue s d)) | b == s = FJust $ (,) (True, b) $ mkRef s (sizeLen s) d-    convertImm _ _ _ = FNothing+  convertImm :: Bool{-signed-} -> Size -> Operand r s -> First ((Bool, Size), CodeBuilder)+  convertImm a b (ImmOp (Immediate c)) = First $ (,) (a, b) . codeBytes <$> integralToBytes a b c+  convertImm True b (ImmOp (LabelRelValue s d)) | b == s = FJust $ (,) (True, b) $ mkRef s (sizeLen s) d+  convertImm _ _ _ = FNothing -    mkImmS, mkImmU, mkImm, mkImmNo64 :: Size -> Operand r s -> First ((Bool, Size), CodeBuilder)-    mkImmS = convertImm True-    mkImmU = convertImm False-    mkImm s = mkImmS s <> mkImmU s-    mkImmNo64 s = mkImm (no64 s)+  mkImmS, mkImmU, mkImm, mkImmNo64 :: Size -> Operand r s -> First ((Bool, Size), CodeBuilder)+  mkImmS = convertImm True+  mkImmU = convertImm False+  mkImm s = mkImmS s <> mkImmU s+  mkImmNo64 s = mkImm (no64 s) -    xchg_a :: IsSize s => Operand r s -> CodeBuilder-    xchg_a dest@(RegOp r) | size dest /= S8 = regprefix (size dest) dest (oneReg 0x12 r) mempty-    xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty+  xchg_a :: IsSize s => Operand r s -> CodeBuilder+  xchg_a dest@(RegOp r) | size dest /= S8 = regprefix (size dest) dest (oneReg 0x12 r) mempty+  xchg_a dest = regprefix'' dest 0x43 (reg8 0x0 dest) mempty -    toCode :: HasBytes a => a -> CodeBuilder-    toCode = codeBytes . toBytes+  toCode :: HasBytes a => a -> CodeBuilder+  toCode = codeBytes . toBytes -    sizePrefix_ :: [SReg] -> Size -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder-    sizePrefix_ rs s r x c im-        | noHighRex rs = pre <> c <> displacement r <> im-        | otherwise = error "cannot use high register in rex instruction"-      where-        pre = case s of-            S8  -> mem32pre r <> maybePrefix40-            S16 -> codeByte 0x66 <> mem32pre r <> prefix40 x-            S32 -> mem32pre r <> prefix40 x-            S64 -> mem32pre r <> prefix40 (0x8 .|. x)-            S128 -> mem32pre r <> codeByte 0x66 <> maybePrefix40+  sizePrefix_ :: [SReg] -> Size -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder+  sizePrefix_ rs s r x c im+    | noHighRex rs = pre <> c <> displacement r <> im+    | otherwise = error "cannot use high register in rex instruction"+    where+      pre = case s of+        S8  -> mem32pre r <> maybePrefix40+        S16 -> codeByte 0x66 <> mem32pre r <> prefix40 x+        S32 -> mem32pre r <> prefix40 x+        S64 -> mem32pre r <> prefix40 (0x8 .|. x)+        S128 -> mem32pre r <> codeByte 0x66 <> maybePrefix40 -        mem32pre :: Operand r s -> CodeBuilder-        mem32pre (MemOp r@Addr{}) | size r == S32 = codeByte 0x67-        mem32pre _ = mempty+      mem32pre :: Operand r s -> CodeBuilder+      mem32pre (MemOp r@Addr{}) | size r == S32 = codeByte 0x67+      mem32pre _ = mempty -        prefix40 x = iff (x /= 0) $ prefix40_ x-        prefix40_ x = codeByte $ 0x40 .|. x+      prefix40 x = iff (x /= 0) $ prefix40_ x+      prefix40_ x = codeByte $ 0x40 .|. x -        maybePrefix40 = iff (any isRex rs || x /= 0) (prefix40_ x)+      maybePrefix40 = iff (any isRex rs || x /= 0) (prefix40_ x) -        displacement :: Operand r s -> CodeBuilder-        displacement (IPMemOp (Immediate d)) = toCode d-        displacement (IPMemOp (LabelRelValue s@S32 d)) = mkRef s (sizeLen s + fromIntegral (codeBuilderLength im)) d-        displacement (MemOp (Addr b d i)) = mkSIB b i <> dispVal b d-          where-            mkSIB _ (IndexReg s (NormalReg 0x4)) = error "sp cannot be used as index"-            mkSIB _ (IndexReg s i) = f s $ reg8_ i-            mkSIB Nothing _ = f s1 0x4-            mkSIB (Just (reg8_ -> 0x4)) _ = f s1 0x4-            mkSIB _ _ = mempty+      displacement :: Operand r s -> CodeBuilder+      displacement (IPMemOp (Immediate d)) = toCode d+      displacement (IPMemOp (LabelRelValue s@S32 d)) = mkRef s (sizeLen s + fromIntegral (codeBuilderLength im)) d+      displacement (MemOp (Addr b d i)) = mkSIB b i <> dispVal b d+        where+          mkSIB _ (IndexReg s (NormalReg 0x4)) = error "sp cannot be used as index"+          mkSIB _ (IndexReg s i) = f s $ reg8_ i+          mkSIB Nothing _ = f s1 0x4+          mkSIB (Just (reg8_ -> 0x4)) _ = f s1 0x4+          mkSIB _ _ = mempty -            f (Scale s) i = codeByte $ s `shiftL` 6 .|. i `shiftL` 3 .|. maybe 0x5 reg8_ b+          f (Scale s) i = codeByte $ s `shiftL` 6 .|. i `shiftL` 3 .|. maybe 0x5 reg8_ b -            dispVal Just{} (Disp (Integral (d :: Int8))) = toCode d-            dispVal _ (Disp d) = toCode d-            dispVal Nothing _ = toCode (0 :: Int32)      -- [rbp] --> [rbp + 0]-            dispVal (Just (reg8_ -> 0x5)) _ = codeByte 0      -- [rbp] --> [rbp + 0]-            dispVal _ _ = mempty-        displacement _ = mempty+          dispVal Just{} (Disp (Integral (d :: Int8))) = toCode d+          dispVal _ (Disp d) = toCode d+          dispVal Nothing _ = toCode (0 :: Int32)    -- [rbp] --> [rbp + 0]+          dispVal (Just (reg8_ -> 0x5)) _ = codeByte 0    -- [rbp] --> [rbp + 0]+          dispVal _ _ = mempty+      displacement _ = mempty -    reg8_ :: Reg t -> Word8-    reg8_ (NormalReg r) = r .&. 0x7-    reg8_ (HighReg r) = r .|. 0x4-    reg8_ (XMM r) = r .&. 0x7+  reg8_ :: Reg t -> Word8+  reg8_ (NormalReg r) = r .&. 0x7+  reg8_ (HighReg r) = r .|. 0x4+  reg8_ (XMM r) = r .&. 0x7 -    regprefix :: IsSize s => Size -> Operand r s -> CodeBuilder -> CodeBuilder -> CodeBuilder-    regprefix s r c im = sizePrefix_ (regs r) s r (extbits r) c im+  regprefix :: IsSize s => Size -> Operand r s -> CodeBuilder -> CodeBuilder -> CodeBuilder+  regprefix s r = sizePrefix_ (regs r) s r (extbits r) -    regprefix2 :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> CodeBuilder -> CodeBuilder-    regprefix2 r r' c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) c mempty+  regprefix2 :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> CodeBuilder -> CodeBuilder+  regprefix2 r r' c = sizePrefix_ (regs r <> regs r') (size r) r (extbits r' `shiftL` 2 .|. extbits r) c mempty -    regprefix'' :: IsSize s => Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder-    regprefix'' r p c = regprefix (size r) r $ extension r p <> c+  regprefix'' :: IsSize s => Operand r s -> Word8 -> CodeBuilder -> CodeBuilder -> CodeBuilder+  regprefix'' r p c = regprefix (size r) r $ extension r p <> c -    regprefix2' :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder-    regprefix2' r r' p c = regprefix2 r r' $ extension r p <> c+  regprefix2' :: (IsSize s1, IsSize s) => Operand r1 s1 -> Operand r s -> Word8 -> CodeBuilder -> CodeBuilder+  regprefix2' r r' p c = regprefix2 r r' $ extension r p <> c -    sse :: IsSize s => Word8 -> Operand r S128 -> Operand r' s -> CodeBuilder-    sse op a@OpXMM b = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg2x8 a b) mempty+  sse :: IsSize s => Word8 -> Operand r S128 -> Operand r' s -> CodeBuilder+  sse op a@OpXMM b = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg2x8 a b) mempty -    sseShift :: Word8 -> Word8 -> Word8 -> Operand RW S128 -> Operand r S8 -> CodeBuilder-    sseShift op x op' a@OpXMM b@(mkImmU S8 -> FJust (_, i)) = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg8 x a) i-    -- TODO: xmm argument+  sseShift :: Word8 -> Word8 -> Word8 -> Operand RW S128 -> Operand r S8 -> CodeBuilder+  sseShift op x op' a@OpXMM b@(mkImmU S8 -> FJust (_, i)) = regprefix S128 b (codeByte 0x0f <> codeByte op <> reg8 x a) i+  -- TODO: xmm argument -    extension :: HasSize a => a -> Word8 -> CodeBuilder-    extension x p = codeByte $ p `shiftL` 1 .|. indicator (size x /= S8)+  extension :: HasSize a => a -> Word8 -> CodeBuilder+  extension x p = codeByte $ p `shiftL` 1 .|. indicator (size x /= S8) -    extbits :: Operand r s -> Word8-    extbits = \case-        MemOp (Addr b _ i) -> maybe 0 indexReg b .|. case i of NoIndex -> 0; IndexReg _ x -> indexReg x `shiftL` 1-        RegOp r -> indexReg r-        _ -> 0-      where-        indexReg (NormalReg r) = r `shiftR` 3 .&. 1-        indexReg _ = 0+  extbits :: Operand r s -> Word8+  extbits = \case+    MemOp (Addr b _ i) -> maybe 0 indexReg b .|. case i of NoIndex -> 0; IndexReg _ x -> indexReg x `shiftL` 1+    RegOp r -> indexReg r+    _ -> 0+    where+      indexReg (NormalReg r) = r `shiftR` 3 .&. 1+      indexReg _ = 0 -    reg8 :: Word8 -> Operand r s -> CodeBuilder-    reg8 w x = codeByte $ operMode x `shiftL` 6 .|. w `shiftL` 3 .|. rc x-      where-        operMode :: Operand r s -> Word8-        operMode (MemOp (Addr (Just (reg8_ -> 0x5)) NoDisp _)) = 0x1   -- [rbp] --> [rbp + 0]-        operMode (MemOp (Addr Nothing _ _)) = 0x0-        operMode (MemOp (Addr _ NoDisp _))  = 0x0-        operMode (MemOp (Addr _ (Disp (Integral (_ :: Int8))) _))  = 0x1-        operMode (MemOp (Addr _ Disp{} _))  = 0x2-        operMode IPMemOp{}                  = 0x0-        operMode _                          = 0x3+  reg8 :: Word8 -> Operand r s -> CodeBuilder+  reg8 w x = codeByte $ operMode x `shiftL` 6 .|. w `shiftL` 3 .|. rc x+    where+      operMode :: Operand r s -> Word8+      operMode (MemOp (Addr (Just (reg8_ -> 0x5)) NoDisp _)) = 0x1   -- [rbp] --> [rbp + 0]+      operMode (MemOp (Addr Nothing _ _)) = 0x0+      operMode (MemOp (Addr _ NoDisp _))  = 0x0+      operMode (MemOp (Addr _ (Disp (Integral (_ :: Int8))) _))  = 0x1+      operMode (MemOp (Addr _ Disp{} _))  = 0x2+      operMode IPMemOp{}          = 0x0+      operMode _              = 0x3 -        rc :: Operand r s -> Word8-        rc (MemOp (Addr (Just r) _ NoIndex)) = reg8_ r-        rc MemOp{}   = 0x04      -- SIB byte-        rc IPMemOp{} = 0x05-        rc (RegOp r) = reg8_ r+      rc :: Operand r s -> Word8+      rc (MemOp (Addr (Just r) _ NoIndex)) = reg8_ r+      rc MemOp{}   = 0x04    -- SIB byte+      rc IPMemOp{} = 0x05+      rc (RegOp r) = reg8_ r -    op2 :: IsSize s => Word8 -> Operand RW s -> Operand r s -> CodeBuilder-    op2 op dest@RegA src@(mkImmNo64 (size dest) -> FJust (_, im)) | size dest == S8 || isNothing (getFirst $ mkImmS S8 src)-        = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im-    op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im))-        = regprefix'' dest (0x40 .|. indicator (size dest /= S8 && k == S8)) (reg8 op dest) im-    op2 op dest src = op2' (op `shiftL` 2) dest $ noImm "1" src+  op2 :: IsSize s => Word8 -> Operand RW s -> Operand r s -> CodeBuilder+  op2 op dest@RegA src@(mkImmNo64 (size dest) -> FJust (_, im)) | size dest == S8 || isNothing (getFirst $ mkImmS S8 src)+    = regprefix'' dest (op `shiftL` 2 .|. 0x2) mempty im+  op2 op dest (mkImmS S8 <> mkImmNo64 (size dest) -> FJust ((_, k), im))+    = regprefix'' dest (0x40 .|. indicator (size dest /= S8 && k == S8)) (reg8 op dest) im+  op2 op dest src = op2' (op `shiftL` 2) dest $ noImm "1" src -    noImm :: String -> Operand r s -> Operand RW s-    noImm _ (RegOp r) = RegOp r-    noImm _ (MemOp a) = MemOp a-    noImm _ (IPMemOp a) = IPMemOp a-    noImm er _ = error $ "immediate value of this size is not supported: " ++ er+  noImm :: String -> Operand r s -> Operand RW s+  noImm _ (RegOp r) = RegOp r+  noImm _ (MemOp a) = MemOp a+  noImm _ (IPMemOp a) = IPMemOp a+  noImm er _ = error $ "immediate value of this size is not supported: " ++ er -    op2' :: IsSize s => Word8 -> Operand RW s -> Operand RW s -> CodeBuilder-    op2' op dest src@RegOp{} = op2g op dest src-    op2' op dest@RegOp{} src = op2g (op .|. 0x1) src dest+  op2' :: IsSize s => Word8 -> Operand RW s -> Operand RW s -> CodeBuilder+  op2' op dest src@RegOp{} = op2g op dest src+  op2' op dest@RegOp{} src = op2g (op .|. 0x1) src dest -    op2g :: (IsSize t, IsSize s) => Word8 -> Operand r s -> Operand r' t -> CodeBuilder-    op2g op dest src = regprefix2' dest src op $ reg2x8 src dest+  op2g :: (IsSize t, IsSize s) => Word8 -> Operand r s -> Operand r' t -> CodeBuilder+  op2g op dest src = regprefix2' dest src op $ reg2x8 src dest -    reg2x8 :: (IsSize s, IsSize s') => Operand r s -> Operand r' s' -> CodeBuilder-    reg2x8 (RegOp r) x = reg8 (reg8_ r) x+  reg2x8 :: (IsSize s, IsSize s') => Operand r s -> Operand r' s' -> CodeBuilder+  reg2x8 (RegOp r) = reg8 (reg8_ r) -    op1_ :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder -> CodeBuilder-    op1_ r1 r2 dest im = regprefix'' dest r1 (reg8 r2 dest) im+  op1_ :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder -> CodeBuilder+  op1_ r1 r2 dest = regprefix'' dest r1 (reg8 r2 dest) -    op1 :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder-    op1 a b c = op1_ a b c mempty+  op1 :: IsSize s => Word8 -> Word8 -> Operand r s -> CodeBuilder+  op1 a b c = op1_ a b c mempty -    op1' :: Word8 -> Word8 -> Operand r S64 -> CodeBuilder-    op1' r1 r2 dest = regprefix S32 dest (codeByte r1 <> reg8 r2 dest) mempty+  op1' :: Word8 -> Word8 -> Operand r S64 -> CodeBuilder+  op1' r1 r2 dest = regprefix S32 dest (codeByte r1 <> reg8 r2 dest) mempty -    shiftOp :: IsSize s => Word8 -> Operand RW s -> Operand r S8 -> CodeBuilder-    shiftOp c dest (ImmOp (Immediate 1)) = op1 0x68 c dest-    shiftOp c dest (mkImmU S8 -> FJust (_, i)) = op1_ 0x60 c dest i-    shiftOp c dest RegCl = op1 0x69 c dest-    shiftOp _ _ _ = error "invalid shift operands"+  shiftOp :: IsSize s => Word8 -> Operand RW s -> Operand r S8 -> CodeBuilder+  shiftOp c dest (ImmOp (Immediate 1)) = op1 0x68 c dest+  shiftOp c dest (mkImmU S8 -> FJust (_, i)) = op1_ 0x60 c dest i+  shiftOp c dest RegCl = op1 0x69 c dest+  shiftOp _ _ _ = error "invalid shift operands" -    oneReg :: Word8 -> Reg t -> CodeBuilder-    oneReg x r = codeByte $ x `shiftL` 3 .|. reg8_ r+  oneReg :: Word8 -> Reg t -> CodeBuilder+  oneReg x r = codeByte $ x `shiftL` 3 .|. reg8_ r  pattern OpXMM <- RegOp XMM{}  -------------------------------------------------------------- asm codes  data LCode where-    Prebuilt    :: V.Vector Word8 -> LCode -> LCode-    EmptyCode   :: LCode-    AppendCode  :: CodeBuilder -> LCode -> LCode -> LCode-    CodeLine    :: CodeBuilder -> CodeLine -> LCode+  Prebuilt   :: V.Vector Word8 -> LCode -> LCode+  EmptyCode  :: LCode+  AppendCode :: CodeBuilder -> LCode -> LCode -> LCode+  CodeLine   :: CodeBuilder -> CodeLine -> LCode +#if MIN_VERSION_base(4,11,0)+instance Semigroup LCode where+  a <> b = AppendCode (mkCodeBuilder a <> mkCodeBuilder b) a b+#endif+ instance Monoid LCode where-    mempty  = EmptyCode-    mappend a b = AppendCode (mkCodeBuilder a <> mkCodeBuilder b) a b+  mempty  = EmptyCode -ret     = mkCodeLine Ret_-nop     = mkCodeLine Nop_-pushf   = mkCodeLine PushF_-popf    = mkCodeLine PopF_-cmc     = mkCodeLine Cmc_-clc     = mkCodeLine Clc_-stc     = mkCodeLine Stc_-cli     = mkCodeLine Cli_-sti     = mkCodeLine Sti_-cld     = mkCodeLine Cld_-std     = mkCodeLine Std_-inc a   = mkCodeLine (Inc_ a)-dec a   = mkCodeLine (Dec_ a)-not_ a  = mkCodeLine (Not_ a)-neg a   = mkCodeLine (Neg_ a)-bswap a = mkCodeLine (Bswap a)-bsf a b = mkCodeLine (Bsf a b)-bsr a b = mkCodeLine (Bsr a b)-bt a b  = mkCodeLine (Bt  a b)-add a b = mkCodeLine (Add_ a b)-or_  a b = mkCodeLine (Or_  a b)-adc a b = mkCodeLine (Adc_ a b)-sbb a b = mkCodeLine (Sbb_ a b)-and_ a b = mkCodeLine (And_ a b)-sub a b = mkCodeLine (Sub_ a b)-xor_ a b = mkCodeLine (Xor_ a b)-cmp a b = mkCodeLine (Cmp_ a b)-test a b = mkCodeLine (Test_ a b)-mov a b = mkCodeLine (Mov_ a b)+#if !MIN_VERSION_base(4,11,0)+  mappend a b = AppendCode (mkCodeBuilder a <> mkCodeBuilder b) a b+#endif++ret        = mkCodeLine Ret_+nop        = mkCodeLine Nop_+pushf      = mkCodeLine PushF_+popf       = mkCodeLine PopF_+cmc        = mkCodeLine Cmc_+clc        = mkCodeLine Clc_+stc        = mkCodeLine Stc_+cli        = mkCodeLine Cli_+sti        = mkCodeLine Sti_+cld        = mkCodeLine Cld_+std        = mkCodeLine Std_+inc a      = mkCodeLine (Inc_ a)+dec a      = mkCodeLine (Dec_ a)+not_ a     = mkCodeLine (Not_ a)+neg a      = mkCodeLine (Neg_ a)+bswap a    = mkCodeLine (Bswap a)+bsf a b    = mkCodeLine (Bsf a b)+bsr a b    = mkCodeLine (Bsr a b)+bt a b     = mkCodeLine (Bt  a b)+add a b    = mkCodeLine (Add_ a b)+or_  a b   = mkCodeLine (Or_  a b)+adc a b    = mkCodeLine (Adc_ a b)+sbb a b    = mkCodeLine (Sbb_ a b)+and_ a b   = mkCodeLine (And_ a b)+sub a b    = mkCodeLine (Sub_ a b)+xor_ a b   = mkCodeLine (Xor_ a b)+cmp a b    = mkCodeLine (Cmp_ a b)+test a b   = mkCodeLine (Test_ a b)+mov a b    = mkCodeLine (Mov_ a b) cmov c a b = mkCodeLine (Cmov_ c a b)-rol a b = mkCodeLine (Rol_ a b)-ror a b = mkCodeLine (Ror_ a b)-rcl a b = mkCodeLine (Rcl_ a b)-rcr a b = mkCodeLine (Rcr_ a b)-shl a b = mkCodeLine (Shl_ a b)-shr a b = mkCodeLine (Shr_ a b)-sar a b = mkCodeLine (Sar_ a b)-xchg a b = mkCodeLine (Xchg_ a b)+rol a b    = mkCodeLine (Rol_ a b)+ror a b    = mkCodeLine (Ror_ a b)+rcl a b    = mkCodeLine (Rcl_ a b)+rcr a b    = mkCodeLine (Rcr_ a b)+shl a b    = mkCodeLine (Shl_ a b)+shr a b    = mkCodeLine (Shr_ a b)+sar a b    = mkCodeLine (Sar_ a b)+xchg a b   = mkCodeLine (Xchg_ a b) movd   a b = mkCodeLine (Movd_   a b) movq   a b = mkCodeLine (Movq_   a b) movdqa a b = mkCodeLine (Movdqa_ a b)@@ -620,36 +634,33 @@ psrldq a b = mkCodeLine (Psrldq_ a b) psraw  a b = mkCodeLine (Psraw_  a b) psrad  a b = mkCodeLine (Psrad_  a b)-lea a b = mkCodeLine (Lea_ a b)-j a c   = mkCodeLine (J_ a Nothing c)-pop a   = mkCodeLine (Pop_ a)-push a  = mkCodeLine (Push_ a)-call a  = mkCodeLine (Call_ a)-jmpq a  = mkCodeLine (Jmpq_ a)-jmp b   = mkCodeLine (Jmp_ Nothing b)-db a    = mkCodeLine (Data_ a)-align a = mkCodeLine (Align_ a)+lea a b    = mkCodeLine (Lea_ a b)+j a c      = mkCodeLine (J_ a Nothing c)+pop a      = mkCodeLine (Pop_ a)+push a     = mkCodeLine (Push_ a)+call a     = mkCodeLine (Call_ a)+jmpq a     = mkCodeLine (Jmpq_ a)+jmp b      = mkCodeLine (Jmp_ Nothing b)+db a       = mkCodeLine (Data_ a)+align a    = mkCodeLine (Align_ a)  label :: CodeM Label label = do-    i <- CodeM get-    CodeM $ put $ i+1-    mkCodeLine Label_-    return $ Label i+  i <- CodeM get+  CodeM $ put $ i+1+  mkCodeLine Label_+  return $ Label i  mkCodeLine :: CodeLine -> Code mkCodeLine x = CodeM $ tell $ CodeLine (tellAddr <> mkCodeBuilder' x) x  tellAddr = CodeBuilder 0 0 $ do-    (c, _, _) <- lift getPast-    tell [Left c]----------------+  (c, _, _) <- lift getPast+  tell [Left c]  showCode = \case-    EmptyCode  -> return ()-    AppendCode _ a b -> showCode a >> showCode b-    Prebuilt _ c -> showCodeLine (Align_ 4) >> codeLine "{" >> showCode c >> codeLine "}"-    CodeLine _ x -> showCodeLine x+  EmptyCode  -> return ()+  AppendCode _ a b -> showCode a >> showCode b+  Prebuilt _ c -> showCodeLine (Align_ 4) >> codeLine "{" >> showCode c >> codeLine "}"+  CodeLine _ x -> showCodeLine x 

@@ -1,102 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}
-module CodeGen.X86.Examples where
-
-import Foreign
-
-import CodeGen.X86
-
-foreign import ccall "dynamic" callWW :: FunPtr (Word64 -> Word64) -> Word64 -> Word64
-instance Callable (Word64 -> Word64) where dynCCall = callWW
-
-foreign import ccall "dynamic" callPW :: FunPtr (Ptr a -> Word64) -> Ptr a -> Word64
-instance Callable (Ptr a -> Word64) where dynCCall = callPW
-
-foreign import ccall "dynamic" callIO :: FunPtr (IO ()) -> IO ()
-instance Callable (IO ()) where dynCCall = callIO
-
-foreign import ccall "wrapper" createPtrWord64_Word64 :: (Word64 -> Word64) -> IO (FunPtr (Word64 -> Word64))
-instance CallableHs (Word64 -> Word64) where createHsPtr = createPtrWord64_Word64
-
------------------------------------------------------------------------------- 
--- * examples
-
--- | Example: identity function in Assembly (look at the source code)
---
--- Input: @rdi@ on Linux \/ System V, @rcx@ on Win64
---
--- Output: @rax@
-idCode = do
-    mov result arg1
-    ret
-
-idFun :: Word64 -> Word64
-idFun = compile idCode 
-
--- | Example: Fibonacci function in Assembly
-fibCode = saveNonVolatile $ do
-    mov rdi arg1
-    inc rdi
-    xor_ rdx rdx
-    mov rax 1
-    doWhile NZ $ do
-        mov rcx rax
-        mov rax rdx
-        add rdx rcx
-        dec rdi
-
-fibFun :: Word64 -> Word64
-fibFun = compile fibCode 
-
--- | Example: trace a register in Assembly
-tracedFibCode = saveNonVolatile $ do
-    mov rdi arg1
-    inc rdi
-    xor_ rdx rdx
-    mov rax 1
-    doWhile NZ $ do
-        mov rcx rax
-        mov rax rdx
-        add rdx rcx
-        dec rdi
-        traceReg "d" rax
-
-tracedFibFun :: Word64 -> Word64
-tracedFibFun = compile tracedFibCode 
-
--- | Example: call Haskell @fib@ function from Assembly
-callHsCode = do
-    callFun r11 (hsPtr fib)
-    ret
-
-fib :: Word64 -> Word64
-fib n = go n 0 1
-  where
-    go 0 a b = b `seq` a
-    go n a b = go (n-1) b (a+b)
-
-callHsFun :: Word64 -> Word64
-callHsFun = compile callHsCode 
-
--- | Example: call C @printf@ function from Assembly
---
-callCCode name = saveNonVolatile $ do
-    leaData arg1 $ CString "Hello %s!\n"
-    leaData arg2 $ CString name
-    xor_ rax rax                     -- zero XMM arguments ?????
-    callFun r11 printf
-
-callCFun :: String -> IO ()
-callCFun name = compile $ callCCode name
-
--------------------------------------------------------
-
-memTestFun :: Word64 -> IO Bool
-memTestFun v = do
-    r <- mallocBytes 8                -- this is not required to be aligned (and in any case malloc aligns to machine words)
-    pokeByteOff r 0 (v :: Word64)
-    let code = saveNonVolatile $ do
-            mov rdi arg1
-            mov rax (addr rdi)
-    return $ compile code (r :: Ptr Word8) == v
-
-

@@ -1,10 +1,8 @@-{-# language CPP #-}-{-# language ForeignFunctionInterface #-}-{-# language BangPatterns #-}-{-# language ViewPatterns #-} {-# language FlexibleInstances #-} {-# language FlexibleContexts #-}+{-# language ViewPatterns #-} {-# language TypeFamilies #-}+{-# language CPP #-} module CodeGen.X86.FFI where  -------------------------------------------------------

@@ -1,418 +1,456 @@-{-# language LambdaCase #-}
-{-# language BangPatterns #-}
-{-# language ViewPatterns #-}
-{-# language PatternGuards #-}
-{-# language PatternSynonyms #-}
-{-# language NoMonomorphismRestriction #-}
-{-# language ScopedTypeVariables #-}
-{-# language RankNTypes #-}
-{-# language TypeFamilies #-}
-{-# language GADTs #-}
-{-# language DataKinds #-}
-{-# language KindSignatures #-}
-{-# language PolyKinds #-}
-{-# language FlexibleContexts #-}
-{-# language FlexibleInstances #-}
-{-# language GeneralizedNewtypeDeriving #-}
-{-# language RecursiveDo #-}
-{-# LANGUAGE TemplateHaskell #-}
-module CodeGen.X86.Tests (runTests) where
-
-import Data.Monoid
-import Data.Maybe
-import Data.List
-import Data.Bits
-import Data.Int
-import Data.Word
-
-import Test.QuickCheck hiding ((.&.), label)
-import Debug.Trace
-
-import CodeGen.X86.Asm
-import CodeGen.X86.CodeGen
-import CodeGen.X86.FFI
-import CodeGen.X86.Utils
-
-import Foreign
-
-foreign import ccall "dynamic" dcb :: FunPtr Bool -> Bool
-instance Callable Bool where dynCCall = dcb
-
-------------------------------------------------------------------------------
-
-class HasSigned a where
-    type Signed a
-    toSigned   :: a -> Signed a
-    fromSigned :: Signed a -> a
-    shiftMask  :: a
-
-instance HasSigned Word8  where
-    type Signed Word8  = Int8
-    toSigned   = fromIntegral
-    fromSigned = fromIntegral
-    shiftMask  = 0x1f
-
-instance HasSigned Word16 where
-    type Signed Word16 = Int16
-    toSigned   = fromIntegral
-    fromSigned = fromIntegral
-    shiftMask  = 0x1f
-
-instance HasSigned Word32 where
-    type Signed Word32 = Int32
-    toSigned   = fromIntegral
-    fromSigned = fromIntegral
-    shiftMask  = 0x1f
-
-instance HasSigned Word64 where
-    type Signed Word64 = Int64
-    toSigned   = fromIntegral
-    fromSigned = fromIntegral
-    shiftMask  = 0x3f
-
-------------------------------------------------------------------------------
-
-prop_integral x@(Integral y) = x == y
-
-------------------------------------------------------------------------------
-
-instance Arbitrary Size  where arbitrary = elements [S8, S16, S32, S64]
-
-instance Arbitrary Scale where arbitrary = elements [s1, s2, s4, s8]
-
-arbVal :: Size -> Gen Int64
-arbVal S8  = fromIntegral <$> (arbitrary :: Gen Int8)
-arbVal S16 = fromIntegral <$> (arbitrary :: Gen Int16)
-arbVal S32 = fromIntegral <$> (arbitrary :: Gen Int32)
-arbVal S64 = fromIntegral <$> (arbitrary :: Gen Int64)
-
-genReg8 :: Gen (Reg S8)
-genReg8 = elements ((NormalReg <$> [0..15]) ++ (HighReg <$> [0..3]))
-genReg16 :: Gen (Reg S16)
-genReg16 = NormalReg <$> elements [0..15]
-genReg32 :: Gen (Reg S32)
-genReg32 = NormalReg <$> elements [0..15]
-genReg64 :: Gen (Reg S64)
-genReg64 = NormalReg <$> elements [0..15]
-
-instance IsSize s => Arbitrary (Reg s) where
-    arbitrary = f (ssize :: SSize s) where
-        f :: SSize s -> Gen (Reg s)
-        f SSize8  = genReg8
-        f SSize16 = genReg16
-        f SSize32 = genReg32
-        f SSize64 = genReg64
-
-genRegs = RegOp <$> arbitrary
-
-genIPBase = pure $ ipRel $ Label 0
-
-instance Arbitrary (Addr S64) where
-    arbitrary = suchThat (Addr <$> base <*> disp <*> index) ok
-      where
-        ok (Addr Nothing _ NoIndex) = False
-        ok (Addr Nothing _ (IndexReg sc _)) = sc == s1
-        ok _ = True
-        base = oneof
-            [ return Nothing
-            , Just <$> arbitrary
-            ]
-        disp = oneof
-            [ return NoDisp
-            , Disp <$> arbitrary
-            ]
-        index = oneof
-            [ return NoIndex
-            , IndexReg <$> arbitrary <*> iregs
-            ]
-        iregs = NormalReg <$> elements ([0..15] \\ [4])      -- sp cannot be index
-
-genMems = MemOp <$> (arbitrary :: Gen (Addr S64))
-
-instance IsSize s => Arbitrary (Operand RW s) where
-    arbitrary = oneof
-        [ genRegs
-        , genMems
-        , genIPBase
-        ]
-
-instance IsSize s => Arbitrary (Operand R s) where
-    arbitrary = oneof
-        [ fromIntegral <$> oneof (arbVal <$> [S8, S16, S32, S64])
-        , genRegs
-        , genMems
-        , genIPBase
-        ]
-
-instance Arbitrary CodeLine where
-    arbitrary = oneof
-        [ op2 Add_
-        , op2 Or_
-        , op2 Adc_
-        , op2 Sbb_
-        , op2 And_
-        , op2 Sub_
-        , op2 Xor_
-        , op2 Cmp_
-        , op2 Test_
-        , op2' Rol_
-        , op2' Ror_
-        , op2' Rcl_
-        , op2' Rcr_
-        , op2' Shl_
-        , op2' Shr_
-        , op2' Sar_
-        , op2'' Mov_
-        ]
-      where
-        op2 :: (forall s . IsSize s => Operand RW s -> Operand R s -> CodeLine) -> Gen CodeLine
-        op2 op = oneof
-            [ f op (arbitrary :: Gen (Operand RW S8))  arbitrary
-            , f op (arbitrary :: Gen (Operand RW S16)) arbitrary
-            , f op (arbitrary :: Gen (Operand RW S32)) arbitrary
-            , f op (arbitrary :: Gen (Operand RW S64)) arbitrary
-            ]
-          where
-            f :: forall s . IsSize s => (Operand RW s -> Operand R s -> CodeLine) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen CodeLine
-            f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b)
-
-        op2'' :: (forall s . IsSize s => Operand RW s -> Operand R s -> CodeLine) -> Gen CodeLine
-        op2'' op = oneof
-            [ f op (arbitrary :: Gen (Operand RW S8))  arbitrary
-            , f op (arbitrary :: Gen (Operand RW S16)) arbitrary
-            , f op (arbitrary :: Gen (Operand RW S32)) arbitrary
-            , f op (arbitrary :: Gen (Operand RW S64)) arbitrary
-            ]
-          where
-            f :: forall s . IsSize s => (Operand RW s -> Operand R s -> CodeLine) -> Gen (Operand RW s) -> Gen (Operand R s) -> Gen CodeLine
-            f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && oki a b)
-
-        op2' :: (forall s . IsSize s => Operand RW s -> Operand R S8 -> CodeLine) -> Gen CodeLine
-        op2' op = oneof
-            [ f op (arbitrary :: Gen (Operand RW S8))  arb
-            , f op (arbitrary :: Gen (Operand RW S16)) arb
-            , f op (arbitrary :: Gen (Operand RW S32)) arb
-            , f op (arbitrary :: Gen (Operand RW S64)) arb
-            ]
-          where
-            arb = oneof
-                [ fromIntegral <$> (arbitrary :: Gen Word8)
-                , return cl
-                ]
-
-            f :: forall s . IsSize s => (Operand RW s -> Operand R S8 -> CodeLine) -> Gen (Operand RW s) -> Gen (Operand R S8) -> Gen CodeLine
-            f op a b = uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b && noteqreg a b)
-
-        noteqreg a b = x == nub x where x = map phisicalReg $ regs a ++ regs b
-
-        okk (size -> s) (ImmOp (Immediate i)) = isJust (integralToBytes True (no64 s) i)
-        okk _ _ = True
-
-        -- TODO: remove
-        ok' RegOp{} RegOp{} = True
-        ok' a b | isMemOp a && isMemOp b = False
-        ok' a b = noteqreg a b
-
-        oki x@RegOp{} (ImmOp (Immediate i)) = isJust (integralToBytes True (size x) i)
-        oki a b = okk a b
-
----------------------------------------------------
-
-evalOp :: forall a . (HasSigned a, Integral a, Integral (Signed a), FiniteBits (Signed a), Num a, FiniteBits a) => CodeLine -> Bool -> a -> a -> ((Bool, Bool), a)
-evalOp op c = case op of
-    Add_{}  -> mk (+)
-    Or_{}   -> mk (.|.)
-    Adc_{}  -> mk $ if c then \a b -> a + b + 1 else (+)
-    Sbb_{}  -> mk $ if c then \a b -> a - b - 1 else (-)
-    And_{}  -> mk (.&.)
-    Sub_{}  -> mk (-)
-    Xor_{}  -> mk xor
-    Cmp_{}  -> mk_ (-) (\a b -> a)
-    Test_{} -> mk_ (.&.) (\a b -> a)
-    Mov_{}  -> \a b -> ((c, False), b)
-    Shl_{}  -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), a `shiftL` i)
-    Shr_{}  -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` (i-1), False), a `shiftR` i)
-    Sar_{}  -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else toSigned a `testBit'` (i-1), False), fromSigned (toSigned a `shiftR` i))
-    Rol_{}  -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` ((finiteBitSize a - i) `mod` finiteBitSize a), False), a `roL` i)
-    Ror_{}  -> \a b -> let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` ((i-1) `mod` finiteBitSize a), False), a `roR` i)
-    Rcl_{}  -> \a b -> let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1) in ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), rcL c a i)
-    Rcr_{}  -> \a b -> let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1) in ((if i == 0 then c else a `testBit` (i-1), False), rcR c a i)
-
-  where
-    mk :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> a -> a -> ((Bool, Bool), a)
-    mk f = mk_ f f
-
-    mk_ :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> (a -> a -> a) -> a -> a -> ((Bool, Bool), a)
-    mk_ f g a b = ((extend (f a b) /= f (extend a) (extend b), sextend (f a b) /= f (sextend a) (sextend b)), g a b)
-
-    extend :: a -> Integer
-    extend = fromIntegral
-    sextend :: a -> Integer
-    sextend = fromIntegral . toSigned
-
-    rcL c a 0 = a
-    rcL c a i = (if c then setBit else clearBit) (a `shiftL` i .|. a `shiftR` (finiteBitSize a - i + 1)) (i - 1)
-
-    rcR c a 0 = a
-    rcR c a i = (if c then setBit else clearBit) (a `shiftR` i .|. a `shiftL` (finiteBitSize a - i + 1)) (finiteBitSize a - i)
-
-    roL a i = a `shiftL` j .|. a `shiftR` (finiteBitSize a - j)
-      where
-        j = i `mod` finiteBitSize a
-
-    roR a i = a `shiftR` j .|. a `shiftL` (finiteBitSize a - j)
-      where
-        j = i `mod` finiteBitSize a
-
-    testBit' a i
-        | isSigned a && i >= finiteBitSize a = testBit a (finiteBitSize a - 1)
-        | otherwise = testBit a i
-
-
-data InstrTest = IT String Code
-
-instance Show InstrTest where show (IT s _) = s
-
-instance Arbitrary InstrTest where
-    arbitrary = do
-        i <- arbitrary
-        cF <- arbitrary
-        let   fff :: forall s s' r . (IsSize s, IsSize s') => CodeLine -> (Operand RW s -> Operand r s' -> CodeLine) -> Operand RW s -> Operand r s' -> Gen InstrTest
-              fff op op' a b = do
-                let
-                    (f1: f2: _) = map RegOp $ filter (`notElem` (regi a ++ regi b)) $ NormalReg <$> [8..15]
-                    regi = map phisicalReg . regs
-
-                    ff :: Operand RW s -> Operand k s' -> Gen (Int64, Int64, Code -> Code)
-                    ff a@(RegOp x) (RegOp x') | Just Refl <- sizeEqCheck x x', x == x' = do
-                        (av, inita) <- mkVal f2 a
-                        return (av, av, inita)
-                    ff (MemOp (Addr (Just x) _ _)) (RegOp x') | phisicalReg (SReg x) == phisicalReg (SReg x') = error "TODO" {-do
-                        (av, inita) <- mkVal a
-                        return (av, av, inita) -}
-                    ff a_ b_ = do
-                        (av, inita) <- mkVal f2 a_
-                        (bv, initb) <- mkVal f2 b_
-                        return (av, bv, inita . initb)
-
-                (av, bv, initab) <- ff a b
-                let
-                    code = mdo
-                        mapM_ push sr
-                        mov f1 rsp
-                        pushf
-                        pop rax
-                        push rax
-                        popf
-                        initab (initcf >> cc >> mova)
-                        mkRes
-                        mov rsp f1 {- <> traceReg "X" rdx' -}
-                        mapM_ pop $ reverse sr
-                        ret
-
-                    sr = [rsi, rdi, rbx, rbp, r12, r13, r14, r15]
-
-                    cc = mkCodeLine i
-                    initcf = if cF then stc else clc
-                    mova = case a of
-                        RegOp (NormalReg 0x2) -> return ()
-                        _ -> mov rdx' a
-                    mkRes = otest i $ if_ (if cF' then C else NC) (xor_ rax rax) $ do
-                        xor_ rax rax
-                        mov rcx res
-                        cmp rcx' rdx'
-                        unless NZ $ inc rax
-                    isShift = \case
-                        Rol_{} -> True
-                        Ror_{} -> True
-                        Rcl_{} -> True
-                        Rcr_{} -> True
-                        Shl_{} -> True
-                        Shr_{} -> True
-                        Sar_{} -> True
-                        _ -> False
-                    otest i x | isShift i = x
-                    otest _ x = if_ (if oF' then O else NO) (xor_ rax rax) x
-
-                    rcx' = resizeOperand rcx :: Operand RW s
-                    rdx' = resizeOperand rdx :: Operand RW s
-                    sa = size a
-
-                    ((cF', oF'), res) = case sa of
-                        S8  -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word8)
-                        S16 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word16)
-                        S32 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word32)
-                        S64 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word64)
-
-                    msg = unlines [show cc, "input a: " ++ show av, "input b: " ++ show bv, "input flags: " ++ show cF, "output: " ++ show res, "output flags: " ++ show cF' ++ " " ++ show oF']
-
-                return $ traceShow cc $ IT msg code
-
-        case i of
-            Add_ a_ b_ -> fff i Add_ a_ b_
-            Or_  a_ b_ -> fff i Or_  a_ b_
-            Adc_ a_ b_ -> fff i Adc_ a_ b_
-            Sbb_ a_ b_ -> fff i Sbb_ a_ b_
-            And_ a_ b_ -> fff i And_ a_ b_
-            Sub_ a_ b_ -> fff i Sub_ a_ b_
-            Xor_ a_ b_ -> fff i Xor_ a_ b_
-            Cmp_ a_ b_ -> fff i Cmp_ a_ b_
-            Test_ a_ b_ -> fff i Test_ a_ b_
-            Rol_ a_ b_ -> fff i Rol_ a_ b_
-            Ror_ a_ b_ -> fff i Ror_ a_ b_
-            Rcl_ a_ b_ -> fff i Rcl_ a_ b_
-            Rcr_ a_ b_ -> fff i Rcr_ a_ b_
-            Shl_ a_ b_ -> fff i Shl_ a_ b_
-            Shr_ a_ b_ -> fff i Shr_ a_ b_
-            Sar_ a_ b_ -> fff i Sar_ a_ b_
-            Mov_ a_ b_ -> fff i Mov_ a_ b_
-
-      where
-        mkVal :: IsSize s => Operand RW S64 -> Operand k s -> Gen (Int64, Code -> Code)
-        mkVal _ o@(ImmOp (Immediate w)) = return (w, id)
-        mkVal _ o@(RegOp x) = do
-            v <- arbVal $ size o
-            return (v, (mov (RegOp x) (fromIntegral v) >>))
-        mkVal helper x@(IPMemOp LabelRelValue{}) = do
-            v <- arbVal $ size x
-            return (v, \c -> mdo
-                        jmp l
-                        db $ toBytes v
-                        l <- label
-                        c)
-        mkVal helper o@(MemOp (Addr (Just x) d i)) = do
-            v <- arbVal $ size o
-            (vi, setvi) <- case i of
-                NoIndex -> return (0, return ())
-                IndexReg sc i -> do
-                    x <- arbVal $ size i
-                    return (scaleFactor sc * x, mov (RegOp i) (fromIntegral x))
-            let
-                d' = (vi :: Int64) + case d of
-                    NoDisp -> 0
-                    Disp v -> fromIntegral v
-                rx = resizeOperand $ RegOp x :: Operand RW S64
-            return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper >> setvi) >>))
-        mkVal helper o@(MemOp (Addr Nothing d (IndexReg sc x))) = do
-            v <- arbVal $ size o
-            let
-                d' = case d of
-                    NoDisp -> 0 :: Int64
-                    Disp v -> fromIntegral v
-                rx = resizeOperand $ RegOp x :: Operand RW S64
-            return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper) >>))
-
-
-propInstr (IT _ c) = compile c :: Bool
-
-tests num = quickCheckWith stdArgs { maxSuccess = num } propInstr
-
------------------------------------------
-
-return []
-
--- | Run all tests
-runTests = do
-    $quickCheckAll
-    tests 2000
-
+{-# language LambdaCase #-}+{-# language BangPatterns #-}+{-# language ViewPatterns #-}+{-# language PatternGuards #-}+{-# language PatternSynonyms #-}+{-# language NoMonomorphismRestriction #-}+{-# language ScopedTypeVariables #-}+{-# language RankNTypes #-}+{-# language TypeFamilies #-}+{-# language GADTs #-}+{-# language DataKinds #-}+{-# language PolyKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}+module CodeGen.X86.Tests+  ( runTests+  )+where++import           Data.Monoid+import           Data.Maybe+import           Data.List+import           Data.Bits+import           Data.Int+import           Data.Word++import           Test.QuickCheck         hiding ( (.&.)+                                                , label+                                                )+import           Debug.Trace++import           CodeGen.X86.Asm+import           CodeGen.X86.CodeGen+import           CodeGen.X86.FFI+import           CodeGen.X86.Utils++import           Foreign++foreign import ccall "dynamic" dcb :: FunPtr Bool -> Bool+instance Callable Bool where+  dynCCall = dcb++------------------------------------------------------------------------------++class HasSigned a where+    type Signed a+    toSigned   :: a -> Signed a+    fromSigned :: Signed a -> a+    shiftMask  :: a++instance HasSigned Word8  where+  type Signed Word8 = Int8+  toSigned   = fromIntegral+  fromSigned = fromIntegral+  shiftMask  = 0x1f++instance HasSigned Word16 where+  type Signed Word16 = Int16+  toSigned   = fromIntegral+  fromSigned = fromIntegral+  shiftMask  = 0x1f++instance HasSigned Word32 where+  type Signed Word32 = Int32+  toSigned   = fromIntegral+  fromSigned = fromIntegral+  shiftMask  = 0x1f++instance HasSigned Word64 where+  type Signed Word64 = Int64+  toSigned   = fromIntegral+  fromSigned = fromIntegral+  shiftMask  = 0x3f++------------------------------------------------------------------------------++prop_integral x@(Integral y) = x == y++------------------------------------------------------------------------------++instance Arbitrary Size  where+  arbitrary = elements [S8, S16, S32, S64]++instance Arbitrary Scale where+  arbitrary = elements [s1, s2, s4, s8]++arbVal :: Size -> Gen Int64+arbVal S8  = fromIntegral <$> (arbitrary :: Gen Int8)+arbVal S16 = fromIntegral <$> (arbitrary :: Gen Int16)+arbVal S32 = fromIntegral <$> (arbitrary :: Gen Int32)+arbVal S64 = fromIntegral <$> (arbitrary :: Gen Int64)++genReg8 :: Gen (Reg S8)+genReg8 = elements ((NormalReg <$> [0 .. 15]) ++ (HighReg <$> [0 .. 3]))+genReg16 :: Gen (Reg S16)+genReg16 = NormalReg <$> elements [0 .. 15]+genReg32 :: Gen (Reg S32)+genReg32 = NormalReg <$> elements [0 .. 15]+genReg64 :: Gen (Reg S64)+genReg64 = NormalReg <$> elements [0 .. 15]++instance IsSize s => Arbitrary (Reg s) where+  arbitrary = f (ssize :: SSize s)   where+    f :: SSize s -> Gen (Reg s)+    f SSize8  = genReg8+    f SSize16 = genReg16+    f SSize32 = genReg32+    f SSize64 = genReg64++genRegs = RegOp <$> arbitrary++genIPBase = pure $ ipRel $ Label 0++instance Arbitrary (Addr S64) where+  arbitrary = suchThat (Addr <$> base <*> disp <*> index) ok+   where+    ok (Addr Nothing _ NoIndex) = False+    ok (Addr Nothing _ (IndexReg sc _)) = sc == s1+    ok _ = True+    base  = oneof [return Nothing, Just <$> arbitrary]+    disp  = oneof [return NoDisp, Disp <$> arbitrary]+    index = oneof [return NoIndex, IndexReg <$> arbitrary <*> iregs]+    iregs = NormalReg <$> elements ([0 .. 15] \\ [4])      -- sp cannot be index++genMems = MemOp <$> (arbitrary :: Gen (Addr S64))++instance IsSize s => Arbitrary (Operand RW s) where+  arbitrary = oneof [genRegs, genMems, genIPBase]++instance IsSize s => Arbitrary (Operand R s) where+  arbitrary = oneof [fromIntegral <$> oneof (arbVal <$> [S8, S16, S32, S64]), genRegs, genMems, genIPBase]++instance Arbitrary CodeLine where+  arbitrary = oneof+    [ op2 Add_+    , op2 Or_+    , op2 Adc_+    , op2 Sbb_+    , op2 And_+    , op2 Sub_+    , op2 Xor_+    , op2 Cmp_+    , op2 Test_+    , op2' Rol_+    , op2' Ror_+    , op2' Rcl_+    , op2' Rcr_+    , op2' Shl_+    , op2' Shr_+    , op2' Sar_+    , op2'' Mov_+    ]+   where+    op2 :: (forall s . IsSize s => Operand RW s -> Operand R s -> CodeLine) -> Gen CodeLine+    op2 op = oneof+      [ f op (arbitrary :: Gen (Operand RW S8))  arbitrary+      , f op (arbitrary :: Gen (Operand RW S16)) arbitrary+      , f op (arbitrary :: Gen (Operand RW S32)) arbitrary+      , f op (arbitrary :: Gen (Operand RW S64)) arbitrary+      ]+     where+      f+        :: forall s+         . IsSize s+        => (Operand RW s -> Operand R s -> CodeLine)+        -> Gen (Operand RW s)+        -> Gen (Operand R s)+        -> Gen CodeLine+      f op a b =+        uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b)++    op2'' :: (forall s . IsSize s => Operand RW s -> Operand R s -> CodeLine) -> Gen CodeLine+    op2'' op = oneof+      [ f op (arbitrary :: Gen (Operand RW S8))  arbitrary+      , f op (arbitrary :: Gen (Operand RW S16)) arbitrary+      , f op (arbitrary :: Gen (Operand RW S32)) arbitrary+      , f op (arbitrary :: Gen (Operand RW S64)) arbitrary+      ]+     where+      f+        :: forall s+         . IsSize s+        => (Operand RW s -> Operand R s -> CodeLine)+        -> Gen (Operand RW s)+        -> Gen (Operand R s)+        -> Gen CodeLine+      f op a b =+        uncurry op <$> suchThat ((,) <$> a <*> b) (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && oki a b)++    op2' :: (forall s . IsSize s => Operand RW s -> Operand R S8 -> CodeLine) -> Gen CodeLine+    op2' op = oneof+      [ f op (arbitrary :: Gen (Operand RW S8))  arb+      , f op (arbitrary :: Gen (Operand RW S16)) arb+      , f op (arbitrary :: Gen (Operand RW S32)) arb+      , f op (arbitrary :: Gen (Operand RW S64)) arb+      ]+     where+      arb = oneof [fromIntegral <$> (arbitrary :: Gen Word8), return cl]++      f+        :: forall s+         . IsSize s+        => (Operand RW s -> Operand R S8 -> CodeLine)+        -> Gen (Operand RW s)+        -> Gen (Operand R S8)+        -> Gen CodeLine+      f op a b = uncurry op <$> suchThat+        ((,) <$> a <*> b)+        (\(a, b) -> noHighRex (regs a <> regs b) && ok' a b && okk a b && noteqreg a b)++    noteqreg a b = x == nub x where x = map phisicalReg $ regs a ++ regs b++    okk (size -> s) (ImmOp (Immediate i)) = isJust (integralToBytes True (no64 s) i)+    okk _           _                     = True++    -- TODO: remove+    ok' RegOp{} RegOp{}              = True+    ok' a b | isMemOp a && isMemOp b = False+    ok' a b                          = noteqreg a b++    oki x@RegOp{} (ImmOp (Immediate i)) = isJust (integralToBytes True (size x) i)+    oki a         b                     = okk a b++---------------------------------------------------++evalOp+  :: forall a+   . (HasSigned a, Integral a, Integral (Signed a), FiniteBits (Signed a), Num a, FiniteBits a)+  => CodeLine+  -> Bool+  -> a+  -> a+  -> ((Bool, Bool), a)+evalOp op c = case op of+  Add_{}  -> mk (+)+  Or_{}   -> mk (.|.)+  Adc_{}  -> mk $ if c then \a b -> a + b + 1 else (+)+  Sbb_{}  -> mk $ if c then \a b -> a - b - 1 else (-)+  And_{}  -> mk (.&.)+  Sub_{}  -> mk (-)+  Xor_{}  -> mk xor+  Cmp_{}  -> mk_ (-) (const a)+  Test_{} -> mk_ (.&.) (const a)+  Mov_{}  -> \a b -> ((c, False), b)+  Shl_{}  -> \a b ->+    let i = fromIntegral (b .&. shiftMask)+    in  ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), a `shiftL` i)+  Shr_{} -> \a b ->+    let i = fromIntegral (b .&. shiftMask) in ((if i == 0 then c else a `testBit` (i - 1), False), a `shiftR` i)+  Sar_{} -> \a b ->+    let i = fromIntegral (b .&. shiftMask)+    in  ((if i == 0 then c else toSigned a `testBit'` (i - 1), False), fromSigned (toSigned a `shiftR` i))+  Rol_{} -> \a b ->+    let i = fromIntegral (b .&. shiftMask)+    in  ((if i == 0 then c else a `testBit` ((finiteBitSize a - i) `mod` finiteBitSize a), False), a `roL` i)+  Ror_{} -> \a b ->+    let i = fromIntegral (b .&. shiftMask)+    in  ((if i == 0 then c else a `testBit` ((i - 1) `mod` finiteBitSize a), False), a `roR` i)+  Rcl_{} -> \a b ->+    let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1)+    in  ((if i == 0 then c else a `testBit` (finiteBitSize a - i), False), rcL c a i)+  Rcr_{} -> \a b ->+    let i = fromIntegral (b .&. shiftMask) `mod` (finiteBitSize a + 1)+    in  ((if i == 0 then c else a `testBit` (i - 1), False), rcR c a i)++ where+  mk :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> a -> a -> ((Bool, Bool), a)+  mk f = mk_ f f++  mk_ :: (forall b . (Num b, Bits b, Integral b) => b -> b -> b) -> (a -> a -> a) -> a -> a -> ((Bool, Bool), a)+  mk_ f g a b = ((extend (f a b) /= f (extend a) (extend b), sextend (f a b) /= f (sextend a) (sextend b)), g a b)++  extend :: a -> Integer+  extend = fromIntegral+  sextend :: a -> Integer+  sextend = fromIntegral . toSigned++  rcL c a 0 = a+  rcL c a i = (if c then setBit else clearBit) (a `shiftL` i .|. a `shiftR` (finiteBitSize a - i + 1)) (i - 1)++  rcR c a 0 = a+  rcR c a i =+    (if c then setBit else clearBit) (a `shiftR` i .|. a `shiftL` (finiteBitSize a - i + 1)) (finiteBitSize a - i)++  roL a i = a `shiftL` j .|. a `shiftR` (finiteBitSize a - j) where j = i `mod` finiteBitSize a++  roR a i = a `shiftR` j .|. a `shiftL` (finiteBitSize a - j) where j = i `mod` finiteBitSize a++  testBit' a i | isSigned a && i >= finiteBitSize a = testBit a (finiteBitSize a - 1)+               | otherwise                          = testBit a i+++data InstrTest = IT String Code++instance Show InstrTest where+  show (IT s _) = s++instance Arbitrary InstrTest where+  arbitrary = do+    i  <- arbitrary+    cF <- arbitrary+    let fff+          :: forall s s' r+           . (IsSize s, IsSize s')+          => CodeLine+          -> (Operand RW s -> Operand r s' -> CodeLine)+          -> Operand RW s+          -> Operand r s'+          -> Gen InstrTest+        fff op op' a b = do+          let (f1 : f2 : _) = map RegOp $ filter (`notElem` (regi a ++ regi b)) $ NormalReg <$> [8 .. 15]+              regi          = map phisicalReg . regs++              ff :: Operand RW s -> Operand k s' -> Gen (Int64, Int64, Code -> Code)+              ff a@(RegOp x) (RegOp x') | Just Refl <- sizeEqCheck x x', x == x' = do+                (av, inita) <- mkVal f2 a+                return (av, av, inita)+              ff (MemOp (Addr (Just x) _ _)) (RegOp x') | phisicalReg (SReg x) == phisicalReg (SReg x') = error "TODO" {-do+                        (av, inita) <- mkVal a+                        return (av, av, inita) -}+              ff a_ b_ = do+                (av, inita) <- mkVal f2 a_+                (bv, initb) <- mkVal f2 b_+                return (av, bv, inita . initb)++          (av, bv, initab) <- ff a b+          let code = mdo+                mapM_ push sr+                mov f1 rsp+                pushf+                pop rax+                push rax+                popf+                initab (initcf >> cc >> mova)+                mkRes+                mov rsp f1 {- <> traceReg "X" rdx' -}+                mapM_ pop $ reverse sr+                ret++              sr     = [rsi, rdi, rbx, rbp, r12, r13, r14, r15]++              cc     = mkCodeLine i+              initcf = if cF then stc else clc+              mova   = case a of+                RegOp (NormalReg 0x2) -> return ()+                _                     -> mov rdx' a+              mkRes = otest i $ if_ (if cF' then C else NC) (xor_ rax rax) $ do+                xor_ rax rax+                mov rcx res+                cmp rcx' rdx'+                unless NZ $ inc rax+              isShift = \case+                Rol_{} -> True+                Ror_{} -> True+                Rcl_{} -> True+                Rcr_{} -> True+                Shl_{} -> True+                Shr_{} -> True+                Sar_{} -> True+                _      -> False+              otest i x | isShift i = x+              otest _ x             = if_ (if oF' then O else NO) (xor_ rax rax) x++              rcx'              = resizeOperand rcx :: Operand RW s+              rdx'              = resizeOperand rdx :: Operand RW s+              sa                = size a++              ((cF', oF'), res) = case sa of+                S8  -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word8)+                S16 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word16)+                S32 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word32)+                S64 -> fromIntegral <$> evalOp op cF (fromIntegral av) (fromIntegral bv :: Word64)++              msg = unlines+                [ show cc+                , "input a: " ++ show av+                , "input b: " ++ show bv+                , "input flags: " ++ show cF+                , "output: " ++ show res+                , "output flags: " ++ show cF' ++ " " ++ show oF'+                ]++          return $ traceShow cc $ IT msg code++    case i of+      Add_  a_ b_ -> fff i Add_ a_ b_+      Or_   a_ b_ -> fff i Or_ a_ b_+      Adc_  a_ b_ -> fff i Adc_ a_ b_+      Sbb_  a_ b_ -> fff i Sbb_ a_ b_+      And_  a_ b_ -> fff i And_ a_ b_+      Sub_  a_ b_ -> fff i Sub_ a_ b_+      Xor_  a_ b_ -> fff i Xor_ a_ b_+      Cmp_  a_ b_ -> fff i Cmp_ a_ b_+      Test_ a_ b_ -> fff i Test_ a_ b_+      Rol_  a_ b_ -> fff i Rol_ a_ b_+      Ror_  a_ b_ -> fff i Ror_ a_ b_+      Rcl_  a_ b_ -> fff i Rcl_ a_ b_+      Rcr_  a_ b_ -> fff i Rcr_ a_ b_+      Shl_  a_ b_ -> fff i Shl_ a_ b_+      Shr_  a_ b_ -> fff i Shr_ a_ b_+      Sar_  a_ b_ -> fff i Sar_ a_ b_+      Mov_  a_ b_ -> fff i Mov_ a_ b_++   where+    mkVal :: IsSize s => Operand RW S64 -> Operand k s -> Gen (Int64, Code -> Code)+    mkVal _ o@(ImmOp (Immediate w)) = return (w, id)+    mkVal _ o@(RegOp x            ) = do+      v <- arbVal $ size o+      return (v, (mov (RegOp x) (fromIntegral v) >>))+    mkVal helper x@(IPMemOp LabelRelValue{}) = do+      v <- arbVal $ size x+      return+        ( v+        , \c -> mdo+          jmp l+          db $ toBytes v+          l <- label+          c+        )+    mkVal helper o@(MemOp (Addr (Just x) d i)) = do+      v           <- arbVal $ size o+      (vi, setvi) <- case i of+        NoIndex       -> return (0, return ())+        IndexReg sc i -> do+          x <- arbVal $ size i+          return (scaleFactor sc * x, mov (RegOp i) (fromIntegral x))+      let d' = (vi :: Int64) + case d of+            NoDisp -> 0+            Disp v -> fromIntegral v+          rx = resizeOperand $ RegOp x :: Operand RW S64+      return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper >> setvi) >>))+    mkVal helper o@(MemOp (Addr Nothing d (IndexReg sc x))) = do+      v <- arbVal $ size o+      let d' = case d of+            NoDisp -> 0 :: Int64+            Disp v -> fromIntegral v+          rx = resizeOperand $ RegOp x :: Operand RW S64+      return (v, ((leaData rx v >> mov helper (fromIntegral d') >> sub rx helper) >>))+++propInstr (IT _ c) = compile c :: Bool++tests num = quickCheckWith stdArgs { maxSuccess = num } propInstr++-----------------------------------------++return []++-- | Run all tests+runTests = do+  $quickCheckAll+  tests 2000+

@@ -1,92 +1,111 @@-{-# language CPP #-}
-{-# language BangPatterns #-}
-{-# language NoMonomorphismRestriction #-}
-{-# language ScopedTypeVariables #-}
-{-# language DataKinds #-}
-{-# language ForeignFunctionInterface #-}
-{-# language RecursiveDo #-}
-module CodeGen.X86.Utils where
-
-import Data.Char
-import Data.Monoid
-import Control.Monad
-import Foreign
-import System.Environment
-import Debug.Trace
-
-import CodeGen.X86.Asm
-import CodeGen.X86.CodeGen
-import CodeGen.X86.CallConv
-
--------------------------------------------------------------- derived constructs
-
--- | execute code unless condition is true
-unless cc x = mdo
-    j cc l
-    x
-    l <- label
-    return ()
-
--- | do while loop construction
-doWhile cc x = do
-    l <- label
-    x
-    j cc l
-
--- | if-then-else
-if_ cc a b = mdo
-    j (N cc) l1
-    a
-    jmp l2
-    l1 <- label
-    b
-    l2 <- label
-    return ()
-
-leaData r d = mdo
-    lea r $ ipRel8 l1
-    jmp l2
-    l1 <- label
-    db $ toBytes d
-    l2 <- label
-    return ()
-
------------------------------------------------------------------------------- 
-
-foreign import ccall "static stdio.h &printf" printf :: FunPtr a
-
------------------------------------------------------------------------------- 
--- * utils
-
-mov' :: forall s s' r . IsSize s' => Operand RW s -> Operand r s' -> Code
-mov' a b = mov (resizeOperand a :: Operand RW s') b
-
-newtype CString = CString String
-
-instance HasBytes CString where
-    toBytes (CString cs) = mconcat $ toBytes . (fromIntegral :: Int -> Word8) . fromEnum <$> (cs ++ "\0")
-
--- | we should implement PUSHA and POPA later
-all_regs_except_rsp :: [Operand rw S64]
-all_regs_except_rsp = [ rax, rcx, rdx, rbx, {- rsp, -} rbp, rsi, rdi, r8, r9, r10, r11, r12, r13, r14, r15 ]
-
-push_all = sequence_ [ push r | r <-         all_regs_except_rsp ]
-pop_all  = sequence_ [ pop  r | r <- reverse all_regs_except_rsp ]
-
-traceReg :: IsSize s => String -> Operand RW s -> Code
-traceReg d r = do
-    pushf
-    push_all
-    mov' arg2 r
-    leaData arg1 (CString $ show r ++ " = %" ++ s ++ d ++ "\n")
-    xor_ rax rax
-    callFun r11 printf
-    pop_all
-    popf
-  where
-    s = case size r of
-        S8  -> "hh"
-        S16 -> "h"
-        S32 -> ""
-        S64 -> "l"
-
+{-# language NoMonomorphismRestriction #-}+{-# language ScopedTypeVariables #-}+{-# language DataKinds #-}+{-# language ForeignFunctionInterface #-}+{-# language RecursiveDo #-}+module CodeGen.X86.Utils where++import           Data.Char+import           Data.Monoid+import           Control.Monad+import           Foreign+import           System.Environment+import           Debug.Trace++import           CodeGen.X86.Asm+import           CodeGen.X86.CodeGen+import           CodeGen.X86.CallConv++-------------------------------------------------------------- derived constructs++-- | execute code unless condition is true+unless cc x = mdo+  j cc l+  x+  l <- label+  return ()++-- | do while loop construction+doWhile cc x = do+  l <- label+  x+  j cc l++-- | if-then-else+if_ cc a b = mdo+  j (N cc) l1+  a+  jmp l2+  l1 <- label+  b+  l2 <- label+  return ()++leaData r d = mdo+  lea r $ ipRel8 l1+  jmp l2+  l1 <- label+  db $ toBytes d+  l2 <- label+  return ()++------------------------------------------------------------------------------ ++foreign import ccall "static stdio.h &printf" printf :: FunPtr a++------------------------------------------------------------------------------ +-- * utils++mov' :: forall s s' r . IsSize s' => Operand RW s -> Operand r s' -> Code+mov' a = mov (resizeOperand a :: Operand RW s')++newtype CString = CString String++instance HasBytes CString where+  toBytes (CString cs) = mconcat $ toBytes . (fromIntegral :: Int -> Word8) . fromEnum <$> (cs ++ "\0")++-- | we should implement PUSHA and POPA later+{- HLINT ignore all_regs_except_rsp -}+all_regs_except_rsp :: [Operand rw S64]+all_regs_except_rsp =+  [ rax+  , rcx+  , rdx+  , rbx+  , {- rsp, -}+    rbp+  , rsi+  , rdi+  , r8+  , r9+  , r10+  , r11+  , r12+  , r13+  , r14+  , r15+  ]++{- HLINT ignore push_all -}+push_all = sequence_ [ push r | r <- all_regs_except_rsp ]++{- HLINT ignore pop_all -}+pop_all = sequence_ [ pop r | r <- reverse all_regs_except_rsp ]++traceReg :: IsSize s => String -> Operand RW s -> Code+traceReg d r = do+  pushf+  push_all+  mov' arg2 r+  leaData arg1 (CString $ show r ++ " = %" ++ s ++ d ++ "\n")+  xor_ rax rax+  callFun r11 printf+  pop_all+  popf+ where+  s = case size r of+    S8  -> "hh"+    S16 -> "h"+    S32 -> ""+    S64 -> "l"+

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,4 +1,4 @@-import CodeGen.X86
-
-main = runTests
-
+import CodeGen.X86.Tests++main = runTests+

@@ -1,87 +1,89 @@-name:                x86-64bit
-version:             0.4.5
-homepage:            https://github.com/divipp/x86-64
-synopsis:            Runtime code generation for x86 64 bit machine code
-description:         The primary goal of x86-64bit is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. See README.md for further details.
-license:             BSD3
-license-file:        LICENSE
-author:              Péter Diviánszky
-maintainer:          divipp@gmail.com
-category:            Code Generation
-build-type:          Simple
-cabal-version:       >=1.10
-stability:           Experimental
-tested-with:         GHC == 8.0.1
-extra-source-files:  README.md
-                     CHANGELOG.md
-                     TODO.md
-
-source-repository head
-  type:     git
-  location: https://github.com/divipp/x86-64
-
-library
-  exposed-modules:
-    CodeGen.X86
-    CodeGen.X86.Examples
-  other-modules:
-    Control.DeeperSeq
-    CodeGen.X86.Asm
-    CodeGen.X86.CodeGen
-    CodeGen.X86.CallConv
-    CodeGen.X86.FFI
-    CodeGen.X86.Utils
-    CodeGen.X86.Tests
-
-  default-language:    Haskell2010
-  other-extensions:
-    NoMonomorphismRestriction
-    LambdaCase
-    PatternSynonyms
-    ViewPatterns
-    TypeSynonymInstances
-    FlexibleInstances
-    TypeFamilies
-    GADTs
-    RankNTypes
-    RecordWildCards
-    DeriveFunctor
-    DeriveFoldable
-    DeriveTraversable
-    DataKinds
-    GeneralizedNewtypeDeriving
-    OverloadedStrings
-    TupleSections
-    ExistentialQuantification
-    ScopedTypeVariables
-
-  build-depends:
-    base >=4.8 && <4.10,
-    monads-tf >=0.1 && <0.2,
-    tardis >= 0.4 && <0.5,
-    vector >=0.11 && <0.12,
-    QuickCheck >=2.8 && <2.10,
-    deepseq
-
-  if os(windows)
-    build-depends: Win32
-
-  default-language:    Haskell2010
-
-test-suite test-x86-64bit
-  type:       exitcode-stdio-1.0
-  main-is:    Test.hs
-
-  build-depends:
-    base >=4.8 && <4.10,
-    monads-tf >=0.1 && <0.2,
-    tardis >= 0.4 && <0.5,
-    vector >=0.11 && <0.12,
-    QuickCheck >=2.8 && <2.10,
-    deepseq
-
-  if os(windows)
-    build-depends: Win32
-
-  default-language:    Haskell2010
-
+name:                x86-64bit+version:             0.4.6+homepage:            https://github.com/divipp/x86-64+synopsis:            Runtime code generation for x86 64 bit machine code+description:         The primary goal of x86-64bit is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. See README.md for further details.+license:             BSD3+license-file:        LICENSE+author:              Péter Diviánszky+maintainer:          divipp@gmail.com+category:            Code Generation+build-type:          Simple+cabal-version:       >=1.10+stability:           Experimental+tested-with:         GHC == 8.0.1+extra-source-files:  README.md+                     CHANGELOG.md+                     TODO.md++source-repository head+  type:     git+  location: https://github.com/divipp/x86-64++library+  exposed-modules: CodeGen.X86+  other-modules:+    Control.DeeperSeq+    CodeGen.X86.Asm+    CodeGen.X86.CodeGen+    CodeGen.X86.CallConv+    CodeGen.X86.FFI+    CodeGen.X86.Utils++  default-language:    Haskell2010+  other-extensions:+    NoMonomorphismRestriction+    LambdaCase+    PatternSynonyms+    ViewPatterns+    TypeSynonymInstances+    FlexibleInstances+    TypeFamilies+    GADTs+    RankNTypes+    RecordWildCards+    DeriveFunctor+    DeriveFoldable+    DeriveTraversable+    DataKinds+    GeneralizedNewtypeDeriving+    OverloadedStrings+    TupleSections+    ExistentialQuantification+    ScopedTypeVariables++  build-depends:+    base       >= 4.8  && <4.14,+    monads-tf  >= 0.1  && <0.2,+    tardis     >= 0.4  && <0.5,+    vector     >= 0.11 && <0.13,+    deepseq++  if os(windows)+    build-depends: Win32++test-suite test-x86-64bit+  type:       exitcode-stdio-1.0+  main-is:    Test.hs+  other-modules:+    Control.DeeperSeq+    CodeGen.X86.Asm+    CodeGen.X86.CodeGen+    CodeGen.X86.CallConv+    CodeGen.X86.FFI+    CodeGen.X86.Utils+    CodeGen.X86.Tests++  build-depends:+    base       >= 4.8  && <4.14,+    monads-tf  >= 0.1  && <0.2,+    tardis     >= 0.4  && <0.5,+    vector     >= 0.11 && <0.13,+    QuickCheck >= 2.8  && <2.14,+    deepseq++  if os(windows)+    build-depends: Win32++  default-language:    Haskell2010+