diff options
Diffstat (limited to 'X64.hs')
| -rw-r--r-- | X64.hs | 275 |
1 files changed, 275 insertions, 0 deletions
@@ -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 |