Initial

1 files changed, 275 insertions, 0 deletions

diff --git a/X64.hs b/X64.hs
new file mode 100644
index 0000000..a2d63aa
--- /dev/null
+++ b/X64.hs
@@ -0,0 +1,275 @@
+module X64 where
+
+import Control.Monad
+import Data.Char
+import Data.Int
+import Data.List
+import Data.Maybe
+
+
+type Offset = Int64
+
+class Stringifiable a where
+    stringify :: a -> String
+
+data Register = RAX | RBX | RCX | RDX | RSI | RDI | RSP | RBP | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+data XRef = XReg Int Register | XMem Int (Maybe Register) (Int, Register) (Maybe String) Offset | XImm Offset
+  deriving (Show, Eq)
+
+newtype Reg = Reg XRef deriving (Show, Eq)
+newtype Mem = Mem XRef deriving (Show, Eq)
+newtype Imm = Imm XRef deriving (Show, Eq)
+newtype RegMem = RegMem XRef deriving (Show, Eq)
+newtype RegMemImm = RegMemImm XRef deriving (Show, Eq)
+
+data CondCode = CCA | CCAE | CCB | CCBE | CCC | CCE | CCG | CCGE | CCL | CCLE | CCNA | CCNAE | CCNB | CCNBE | CCNC | CCNE | CCNG | CCNGE | CCNL | CCNLE
+  deriving (Show, Eq)
+
+data Ins
+    = MOV RegMem RegMem | MOVi RegMem Imm | MOVi64 Reg Imm
+    | MOVSX Reg RegMem
+    | ADD RegMem RegMemImm
+    | SUB RegMem RegMemImm
+    | AND RegMem RegMemImm
+    | OR RegMem RegMemImm
+    | XOR RegMem RegMemImm
+    | IMULDA RegMem | IMUL Reg RegMem | IMUL3 Reg RegMem Imm
+    | MULDA RegMem
+    | IDIVDA RegMem
+    | DIVDA RegMem
+    | CMP RegMem RegMem | CMPi RegMem Imm
+    | SETCC CondCode RegMem
+    | CALL String
+    | PUSH RegMemImm
+    | POP RegMem
+    | JMP String
+    | JCC CondCode String
+    | RET
+  deriving (Show, Eq)
+
+data Asm = Asm [(String, [Ins])]
+  deriving (Show, Eq)
+
+
+class XRefSub a where
+    xref :: XRef -> a
+
+instance XRefSub Reg where
+    xref x@(XReg _ _) = Reg x
+    xref _ = undefined
+instance XRefSub Mem where
+    xref x@(XMem _ _ _ _ _) = Mem x
+    xref _ = undefined
+instance XRefSub Imm where
+    xref x@(XImm _) = Imm x
+    xref _ = undefined
+instance XRefSub RegMem where
+    xref x@(XReg _ _) = RegMem x
+    xref x@(XMem _ _ _ _ _) = RegMem x
+    xref _ = undefined
+instance XRefSub RegMemImm where
+    xref x = RegMemImm x
+
+
+verify :: Asm -> Either String ()
+verify (Asm funcs) = mapM_ (\(_, inss) -> mapM_ goI inss) funcs
+  where
+    goI :: Ins -> Either String ()
+    goI (MOV (RegMem a) (RegMem b)) = ckRegMem a >> ckRegMem b >> ck2mem a b >> ckSizes a b
+    goI (MOVi (RegMem a) (Imm b)) = ckRegMem a >> ckImm b >> ckSizes a b
+    goI (MOVi64 (Reg a) (Imm b)) = ckReg a >> ckImm b >> ckSizes64 a b
+    goI (MOVSX (Reg a) (RegMem b)) = ckReg a >> ckRegMem b >> ckMovsx a b
+    goI (ADD (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
+    goI (SUB (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
+    goI (AND (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
+    goI (OR (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
+    goI (XOR (RegMem a) (RegMemImm b)) = ckRegMem a >> ckRegMemImm b >> ck2mem a b >> ckSizes a b
+    goI (IMULDA (RegMem a)) = ckRegMem a
+    goI (IMUL (Reg a) (RegMem b)) = ckReg a >> ckRegMem b >> ck2mem a b >> ckSizes a b
+    goI (IMUL3 (Reg a) (RegMem b) (Imm c)) = ckReg a >> ckRegMem b >> ckImm c >> ckSizes a b >> ckSizes a c
+    goI (MULDA (RegMem a)) = ckRegMem a
+    goI (IDIVDA (RegMem a)) = ckRegMem a
+    goI (DIVDA (RegMem a)) = ckRegMem a
+    goI (CMP (RegMem a) (RegMem b)) = ckRegMem a >> ckRegMem b >> ck2mem a b >> ckSizes a b
+    goI (CMPi (RegMem a) (Imm b)) = ckRegMem a >> ckImm b >> ckSizes a b
+    goI (SETCC _ (RegMem a)) = ckRegMem a >> ckSizeEq 1 a
+    goI (CALL s) = when (null s) $ Left "Empty call target"
+    goI (PUSH (RegMemImm a)) = ckRegMemImm a
+    goI (POP (RegMem a)) = ckRegMem a
+    goI (JMP s) = when (null s) $ Left "Empty jump target"
+    goI (JCC _ s) = when (null s) $ Left "Empty jcc target"
+    goI RET = return ()
+
+    ckReg (XReg _ _) = return ()
+    ckReg _ = Left "Argument is not a Reg"
+
+    ckImm (XImm _) = return ()
+    ckImm _ = Left "Argument is not an Imm"
+
+    ckRegMem (XReg _ _) = return ()
+    ckRegMem (XMem _ _ _ _ _) = return ()
+    ckRegMem _ = Left "Argument is not a Reg or a Mem"
+
+    ckRegMemImm _ = return ()
+
+    ck2mem x@(XMem _ _ _ _ _) y@(XMem _ _ _ _ _) =
+        Left $ "Invalid double-memory operands: " ++ show x ++ "; " ++ show y
+    ck2mem _ _ = return ()
+
+    ckSizes64 x@(XReg a _) y@(XReg b _) =
+        when (a /= b) $ Left $ "Inconsistent operand sizes: " ++ show x ++ "; " ++ show y
+    ckSizes64 x@(XReg a _) y@(XMem b _ _ _ _) =
+        when (a /= b) $ Left $ "Inconsistent operand sizes: " ++ show x ++ "; " ++ show y
+    ckSizes64 x@(XMem a _ _ _ _) y@(XReg b _) =
+        when (a /= b) $ Left $ "Inconsistent operand sizes: " ++ show x ++ "; " ++ show y
+    ckSizes64 x@(XMem a _ _ _ _) y@(XMem b _ _ _ _) =
+        when (a /= b) $ Left $ "Inconsistent operand sizes: " ++ show x ++ "; " ++ show y
+    ckSizes64 x@(XReg a _) y@(XImm v) =
+        when (not $ fitsIn v a) $ Left $ "Immediate too large: " ++ show x ++ "; " ++ show y
+    ckSizes64 x@(XMem a _ _ _ _) y@(XImm v) =
+        when (not $ fitsIn v a) $ Left $ "Immediate too large: " ++ show x ++ "; " ++ show y
+    ckSizes64 _ _ = undefined
+
+    ckSizes a b@(XImm v) = when (v >= 2 ^ (32::Int)) (Left "Immediate too large") >> ckSizes64 a b
+    ckSizes a b = ckSizes64 a b
+
+    ckMovsx (XReg a _) (XReg b _) = when (a <= b) $ Left "MOVSX with shrinking operands"
+    ckMovsx (XReg a _) (XMem b _ _ _ _) = when (a <= b) $ Left "MOVSX with shrinking operands"
+    ckMovsx (XMem a _ _ _ _) (XReg b _) = when (a <= b) $ Left "MOVSX with shrinking operands"
+    ckMovsx (XMem a _ _ _ _) (XMem b _ _ _ _) = when (a <= b) $ Left "MOVSX with shrinking operands"
+    ckMovsx _ _ = undefined
+
+    ckSizeEq sz (XReg a _) = when (a /= sz) $ Left "Invalid operand size"
+    ckSizeEq sz (XMem a _ _ _ _) = when (a /= sz) $ Left "Invalid operand size"
+    ckSizeEq sz (XImm v) = when (v >= 2 ^ (8 * sz)) $ Left "Invalid operand size (immediate)"
+
+    fitsIn v sz = (fromIntegral v :: Integer) < ((2 :: Integer) ^ (8 * sz))
+
+
+instance Stringifiable XRef where
+    stringify (XReg sz reg) =
+        let n = fromEnum reg
+        in case n of
+               _ | n < 4 -> erPrefix $ lxSuffix $ [chr (n + ord 'a')]
+                 | n < 8 -> erPrefix $ lSuffix $ ["si", "di", "sp", "bp"] !! (n - 4)
+                 | otherwise -> bwdSuffix $ 'r' : show n
+      where
+        erPrefix s = case sz of
+            4 -> 'e' : s
+            8 -> 'r' : s
+            _ -> s
+        lxSuffix s = case sz of
+            1 -> s ++ "l"
+            _ -> s ++ "x"
+        lSuffix s = case sz of
+            1 -> s ++ "l"
+            _ -> s
+        bwdSuffix s = case sz of
+            1 -> s ++ "b"
+            2 -> s ++ "w"
+            4 -> s ++ "d"
+            _ -> s
+
+    stringify (XMem _ _ (mult, _) _ _) | not (mult `elem` [0,1,2,4,8]) =
+        error $ "Register multiplier has invalid value " ++ show mult ++ " in XMem"
+    stringify (XMem sz mr pair lab off) =
+        let res = intercalate "+" $ catMaybes [goR1 mr, goPair pair, goLab lab, goOff off]
+        in szword sz ++ " " ++ if null res then "[0]" else "[" ++ res ++ "]"
+      where
+        szword 1 = "byte"
+        szword 2 = "word"
+        szword 4 = "dword"
+        szword 8 = "qword"
+        szword _ = undefined
+        goR1 Nothing = Nothing
+        goR1 (Just r) = Just $ stringify (XReg 8 r)
+        goPair (0, _) = Nothing
+        goPair (mult, r) = Just $ show mult ++ "*" ++ stringify (XReg 8 r)
+        goLab = id
+        goOff 0 = Nothing
+        goOff o = Just $ show o
+
+    stringify (XImm imm) = show imm
+
+instance Stringifiable Reg where stringify (Reg x) = stringify x
+instance Stringifiable Mem where stringify (Mem x) = stringify x
+instance Stringifiable Imm where stringify (Imm x) = stringify x
+instance Stringifiable RegMem where stringify (RegMem x) = stringify x
+instance Stringifiable RegMemImm where stringify (RegMemImm x) = stringify x
+
+instance Stringifiable CondCode where
+    stringify CCA = "a"
+    stringify CCAE = "ae"
+    stringify CCB = "b"
+    stringify CCBE = "be"
+    stringify CCC = "c"
+    stringify CCE = "e"
+    stringify CCG = "g"
+    stringify CCGE = "ge"
+    stringify CCL = "l"
+    stringify CCLE = "le"
+    stringify CCNA = "na"
+    stringify CCNAE = "nae"
+    stringify CCNB = "nb"
+    stringify CCNBE = "nbe"
+    stringify CCNC = "nc"
+    stringify CCNE = "ne"
+    stringify CCNG = "ng"
+    stringify CCNGE = "nge"
+    stringify CCNL = "nl"
+    stringify CCNLE = "nle"
+
+instance Stringifiable Ins where
+    stringify (MOV a b) = "mov " ++ stringify a ++ ", " ++ stringify b
+    stringify (MOVi a b) = "mov " ++ stringify a ++ ", " ++ stringify b
+    stringify (MOVi64 a b) = "mov " ++ stringify a ++ ", " ++ stringify b
+    stringify (MOVSX a b@(RegMem bx)) = case compare (xrefGetSize bx) 4 of
+        EQ -> "movsxd " ++ stringify a ++ ", " ++ stringify b
+        LT -> "movsx " ++ stringify a ++ ", " ++ stringify b
+        GT -> undefined
+    stringify (ADD a b) = "add " ++ stringify a ++ ", " ++ stringify b
+    stringify (SUB a b) = "sub " ++ stringify a ++ ", " ++ stringify b
+    stringify (AND a b) = "and " ++ stringify a ++ ", " ++ stringify b
+    stringify (OR a b) = "or " ++ stringify a ++ ", " ++ stringify b
+    stringify (XOR a b) = "xor " ++ stringify a ++ ", " ++ stringify b
+    stringify (IMULDA a) = "imul " ++ stringify a
+    stringify (IMUL a b) = "imul " ++ stringify a ++ ", " ++ stringify b
+    stringify (IMUL3 a b c) = "imul " ++ stringify a ++ ", " ++ stringify b ++ ", " ++ stringify c
+    stringify (MULDA a) = "mul " ++ stringify a
+    stringify (IDIVDA a) = "idiv " ++ stringify a
+    stringify (DIVDA a) = "div " ++ stringify a
+    stringify (CMP a b) = "cmp " ++ stringify a ++ ", " ++ stringify b
+    stringify (CMPi a b) = "cmp " ++ stringify a ++ ", " ++ stringify b
+    stringify (SETCC cc a) = "set" ++ stringify cc ++ " " ++ stringify a
+    stringify (CALL a) = "call " ++ a
+    stringify (PUSH a) = "push " ++ stringify a
+    stringify (POP a) = "pop " ++ stringify a
+    stringify (JMP s) = "jmp " ++ s
+    stringify (JCC cc s) = "j" ++ stringify cc ++ " " ++ s
+    stringify RET = "ret"
+
+instance Stringifiable Asm where
+    stringify (Asm funcs) = intercalate "\n" $ map goF funcs
+      where
+        goF :: (String, [Ins]) -> String
+        goF (name, inss) = name ++ ":\n" ++ unlines (map (('\t' :) . stringify) inss)
+
+xrefGetSize :: XRef -> Int
+xrefGetSize (XReg s _) = s
+xrefGetSize (XMem s _ _ _ _) = s
+xrefGetSize (XImm _) = undefined
+
+xrefSetSize :: Int -> XRef -> XRef
+xrefSetSize sz (XReg _ r) = XReg sz r
+xrefSetSize sz (XMem _ a b c d) = XMem sz a b c d
+xrefSetSize _ x@(XImm _) = x
+
+isXMem :: XRef -> Bool
+isXMem (XMem _ _ _ _ _) = True
+isXMem _ = False
+
+isXImm :: XRef -> Bool
+isXImm (XImm _) = True
+isXImm _ = False