From: Lucian Mogosanu <lucian.mogosanu@gmail.com>
Date: Sat, 13 Dec 2014 23:40:00 +0000 (+0200)
Subject: ZXS: Add basic decoder module
X-Git-Url: https://git.mogosanu.ro/?a=commitdiff_plain;h=db3cf6632146d6bbc803735d070985397ea85c7a;p=z80.git

ZXS: Add basic decoder module

This contains most of the functionality, it parses all the opcodes
except the prefixed ones.
---

diff --git a/src/ZXS/Decode.hs b/src/ZXS/Decode.hs
new file mode 100644
index 0000000..820cec3
--- /dev/null
+++ b/src/ZXS/Decode.hs
@@ -0,0 +1,193 @@
+module ZXS.Decode where
+
+-- This implements one of the functions that do most of the heavy lifting
+-- In addition to the Z80 CPU manual, a lot of useful documentation can
+-- be found at [1] and [2].
+-- [1]: http://www.z80.info/z80oplist.txt
+-- [2]: http://www.z80.info/decoding.htm
+
+import Data.Bits
+import Data.Word
+
+import Z80.ISA
+import ZXS.Machine
+import ZXS.Fetch
+
+decode :: ZXS Instruction
+decode = do
+  b <- fetch
+  let x = (b `shiftR` 6) .&. 0x03
+      y = (b `shiftR` 3) .&. 0x07
+      z = (b `shiftR` 0) .&. 0x07
+      p = (y `shiftR` 1) .&. 0x03
+      q = (y `shiftR` 0) .&. 0x01
+  case x of
+    -- x = 0
+    0 -> case z of
+      -- z = 0
+      0 -> case y of
+        0 -> return NOP
+        1 -> return EX_AF_AF'
+        2 -> fetch >>= return . DJNZ_E . (+ 2) . fromIntegral
+        3 -> fetch >>= return . JR_E . (+ 2) . fromIntegral
+        _ -> fetch >>= return . JR_CC_E (decodeCond $ y - 4) . (+ 2) . fromIntegral
+      -- z = 1
+      1 -> case q of
+        0 -> do
+          lb <- fetch
+          hb <- fetch
+          return . LD_DD_NN (decodeRegPair_dd p) $ bbToWord hb lb
+        1 -> return . ADD_HL_SS $ decodeRegPair_ss p
+      -- z = 2
+      2 -> case (q, p) of
+        (0, 0) -> return LD_PBC_A
+        (0, 1) -> return LD_PDE_A
+        (1, 0) -> return LD_A_PBC
+        (1, 1) -> return LD_A_PDE
+        (0, 2) -> do
+          lb <- fetch
+          hb <- fetch
+          return . LD_PNN_HL $ bbToWord hb lb
+        (0, 3) -> do
+          lb <- fetch
+          hb <- fetch
+          return . LD_PNN_A $ bbToWord hb lb
+        (1, 2) -> do
+          lb <- fetch
+          hb <- fetch
+          return . LD_HL_PNN $ bbToWord hb lb
+        (1, 3) -> do
+          lb <- fetch
+          hb <- fetch
+          return . LD_A_PNN $ bbToWord hb lb
+      -- z = 3
+      3 -> let op = if q == 0 then INC_SS else DEC_SS
+               ss = decodeRegPair_ss p
+        in return $ op ss
+      -- z = 4, 5, 6
+      4 -> return . INC . AOp_R $ decodeReg y
+      5 -> return . DEC . AOp_R $ decodeReg y
+      6 -> fetch >>= return . LD_R_N (decodeReg y)
+      -- z = 7
+      7 -> if y > 7
+        then return . IllegalInstruction $ "decode: opcode = " ++ show b
+        else return . snd . head $ filter (\ (y', _) -> y' == y)
+          [ (0, RLCA), (1, RRCA), (2, RLA), (3, RRA)
+          , (4, DAA), (5, CPL), (6, SCF), (7, CCF) ]
+    -- x = 1
+    1 -> if z /= 6 && y /= 6
+      then return $ LD_R_R' (decodeReg y) (decodeReg z)
+      else return HALT
+    -- x = 2
+    2 -> return . decodeALU y . AOp_R $ decodeReg z
+    -- x = 3
+    3 -> case z of
+      -- z = 0, 1
+      0 -> return . RET_CC $ decodeCond y
+      1 -> case q of
+        0 -> return . POP_QQ $ decodeRegPair_qq p
+        1 -> if p > 3
+          then return . IllegalInstruction $ "decode: opcode = " ++ show b
+          else return . snd . head $ filter (\ (y', _) -> y' == y)
+            [ (0, RET), (1, EXX), (2, JP_HL), (3, LD_SP_HL) ]
+      -- z = 2
+      2 -> do
+        lb <- fetch
+        hb <- fetch
+        return . JP_CC_NN (decodeCond y) $ bbToWord hb lb
+      -- z = 3
+      3 -> case y of
+        -- y = 0..7
+        0 -> do
+          lb <- fetch
+          hb <- fetch
+          return . JP_NN $ bbToWord hb lb
+        1 -> decodeCB
+        2 -> fetch >>= return . OUT_PN_A
+        3 -> fetch >>= return . IN_A_PN
+        4 -> return EX_PSP_HL
+        5 -> return EX_DE_HL
+        6 -> return DI
+        7 -> return EI
+      -- z = 4
+      4 -> do
+        lb <- fetch
+        hb <- fetch
+        return . CALL_CC_NN (decodeCond y) $ bbToWord hb lb
+      -- z = 5
+      5 -> case q of
+        -- q = 0, 1
+        0 -> return . PUSH_QQ $ decodeRegPair_qq p
+        1 -> case p of
+          0 -> do
+            lb <- fetch
+            hb <- fetch
+            return . CALL_NN $ bbToWord hb lb
+          1 -> decodeDD
+          2 -> decodeED
+          3 -> decodeFD
+      -- z = 6
+      6 -> fetch >>= return . decodeALU y . AOp_N
+      7 -> return . RST_P $ y * 8
+    -- x > 3
+    _ -> return . IllegalInstruction $ "decode: opcode = " ++ show b
+
+decodeCB, decodeDD, decodeED, decodeFD :: ZXS Instruction
+decodeCB = undefined
+decodeDD = undefined
+decodeED = undefined
+decodeFD = undefined
+
+bbToWord :: Word8 -> Word8 -> Word16
+bbToWord hb lb = (fromIntegral hb `shiftL` 8) .|. fromIntegral lb
+
+decodeReg :: Word8 -> Reg
+decodeReg b = case b of
+  0 -> B
+  1 -> C
+  2 -> D
+  3 -> E
+  4 -> H
+  5 -> L
+  6 -> PHL
+  7 -> A
+
+decodeCond :: Word8 -> Cond
+decodeCond b = case b of
+  0 -> CNonZero
+  1 -> CZero
+  2 -> CNoCarry
+  3 -> CCarry
+  4 -> CParityOdd
+  5 -> CParityEven
+  6 -> CSignPositive
+  7 -> CSignNegative
+
+decodeRegPair_dd :: Word8 -> RegPair_dd
+decodeRegPair_dd b = case b of
+  0 -> R1 BC
+  1 -> R2 DE
+  2 -> R3 HL
+  3 -> R4 SP
+  _ -> error $ "decodeRegPair_dd: b = " ++ show b
+
+decodeRegPair_ss :: Word8 -> RegPair_ss
+decodeRegPair_ss = decodeRegPair_dd
+
+decodeRegPair_qq :: Word8 -> RegPair_qq
+decodeRegPair_qq b = case b of
+  0 -> R1 BC
+  1 -> R2 DE
+  2 -> R3 HL
+  3 -> R4 AF
+
+decodeALU :: Word8 -> ArithSpec -> Instruction
+decodeALU b = case b of
+  0 -> ADD_A_S
+  1 -> ADC_A_S
+  2 -> SUB_A_S
+  3 -> SBC_A_S
+  4 -> AND_A_S
+  5 -> XOR_A_S
+  6 -> OR_A_S
+  7 -> CP_A_S