summaryrefslogtreecommitdiff
path: root/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
diff options
context:
space:
mode:
Diffstat (limited to 'fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs')
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs343
1 files changed, 343 insertions, 0 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
new file mode 100644
index 0000000..b74a8ee
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
@@ -0,0 +1,343 @@
+module Fig.Emulator.GB.CPU.Instruction where
+
+import Fig.Prelude
+import Prelude (Integral, fromIntegral, error)
+
+import Data.Word (Word8, Word16)
+
+import Fig.Emulator.GB.Utils
+import Fig.Emulator.GB.Bus as Bus
+
+newtype DecodeError = DecodeError Text
+ deriving Show
+instance Exception DecodeError
+instance Pretty DecodeError where
+ pretty (DecodeError b) = mconcat
+ [ "instruction decoding error: "
+ , b
+ ]
+
+class ExtractFromOpcode t where
+ ext :: Integral i => i -> t
+
+data R8 = R8B | R8C | R8D | R8E | R8H | R8L | R8MemHL | R8A
+ deriving (Show)
+instance ExtractFromOpcode R8 where
+ ext i = case (fromIntegral i :: Int) of
+ 0 -> R8B
+ 1 -> R8C
+ 2 -> R8D
+ 3 -> R8E
+ 4 -> R8H
+ 5 -> R8L
+ 6 -> R8MemHL
+ 7 -> R8A
+ _ -> error "unreachable"
+
+data R16 = R16BC | R16DE | R16HL | R16SP
+ deriving (Show)
+instance ExtractFromOpcode R16 where
+ ext i = case (fromIntegral i :: Int) of
+ 0 -> R16BC
+ 1 -> R16DE
+ 2 -> R16HL
+ 3 -> R16SP
+ _ -> error "unreachable"
+
+data R16Stk = R16StkBC | R16StkDE | R16StkHL | R16StkAF
+ deriving (Show)
+instance ExtractFromOpcode R16Stk where
+ ext i = case (fromIntegral i :: Int) of
+ 0 -> R16StkBC
+ 1 -> R16StkDE
+ 2 -> R16StkHL
+ 3 -> R16StkAF
+ _ -> error "unreachable"
+
+data R16Mem = R16MemBC | R16MemDE | R16MemHLPlus | R16MemHLMinus
+ deriving (Show)
+instance ExtractFromOpcode R16Mem where
+ ext i = case (fromIntegral i :: Int) of
+ 0 -> R16MemBC
+ 1 -> R16MemDE
+ 2 -> R16MemHLPlus
+ 3 -> R16MemHLMinus
+ _ -> error "unreachable"
+
+data Cond = CondNz | CondZ | CondNc | CondC
+ deriving (Show)
+instance ExtractFromOpcode Cond where
+ ext i = case (fromIntegral i :: Int) of
+ 0 -> CondNz
+ 1 -> CondZ
+ 2 -> CondNc
+ 3 -> CondC
+ _ -> error "unreachable"
+
+newtype B3 = B3 Int
+ deriving (Show)
+instance ExtractFromOpcode B3 where
+ ext i = B3 $ fromIntegral i
+
+newtype Tgt3 = Tgt3 Int
+ deriving (Show)
+instance ExtractFromOpcode Tgt3 where
+ ext i = Tgt3 $ fromIntegral i
+
+newtype Imm8 = Imm8 Word8
+ deriving (Show)
+readImm8 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm8
+readImm8 b a = Bus.read b a >>= \case
+ Just i -> pure $ Imm8 i
+ Nothing -> throwM . DecodeError $ mconcat
+ [ "failed to read immediate at unmapped address"
+ , pretty a
+ ]
+
+newtype Imm16 = Imm16 Word16
+ deriving (Show)
+readImm16 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm16
+readImm16 b a = do
+ mlo <- Bus.read b a
+ mhi <- Bus.read b $ a + 1
+ case (mlo, mhi) of
+ (Just lo, Just hi) -> pure . Imm16 $ w8w8 hi lo
+ _otherwise -> throwM . DecodeError $ mconcat
+ [ "failed to read 16-bit immediate at unmapped address"
+ , pretty a
+ ]
+
+data Instruction
+ -- Block 0
+ = Nop
+
+ | LdR16Imm16 !R16 !Imm16
+ | LdR16MemA !R16Mem
+ | LdAR16Mem !R16Mem
+ | LdImm16Sp !Imm16
+
+ | IncR16 !R16
+ | DecR16 !R16
+ | AddHlR16 !R16
+
+ | IncR8 !R8
+ | DecR8 !R8
+
+ | LdR8Imm8 !R8 !Imm8
+
+ | Rlca
+ | Rrca
+ | Rla
+ | Rra
+ | Daa
+ | Cpl
+ | Scf
+ | Ccf
+
+ | JrImm8 !Imm8
+ | JrCondImm8 !Cond !Imm8
+
+ | Stop
+
+ -- Block 1
+ | LdR8R8 !R8 !R8
+
+ | Halt
+
+ -- Block 2
+ | AddAR8 !R8
+ | AdcAR8 !R8
+ | SubAR8 !R8
+ | SbcAR8 !R8
+ | AndAR8 !R8
+ | XorAR8 !R8
+ | OrAR8 !R8
+ | CpAR8 !R8
+
+ -- Block 3
+ | AddAImm8 !Imm8
+ | AdcAImm8 !Imm8
+ | SubAImm8 !Imm8
+ | SbcAImm8 !Imm8
+ | AndAImm8 !Imm8
+ | XorAImm8 !Imm8
+ | OrAImm8 !Imm8
+ | CpAImm8 !Imm8
+
+ | RetCond !Cond
+ | Ret
+ | Reti
+ | JpCondImm16 !Cond !Imm16
+ | JpImm16 !Imm16
+ | JpHl
+ | CallCondImm16 !Cond !Imm16
+ | CallImm16 !Imm16
+ | RstTgt3 !Tgt3
+
+ | PopR16Stk !R16Stk
+ | PushR16Stk !R16Stk
+
+ | LdhCA
+ | LdhImm8A !Imm8
+ | LdImm16A !Imm16
+ | LdhAC
+ | LdhAImm8 !Imm8
+ | LdAImm16 !Imm16
+
+ | AddSpImm8 !Imm8
+ | LdHlSpPlusImm8 !Imm8
+ | LdSpHl
+
+ | Di
+ | Ei
+
+ -- 0xcb prefixed 16-bit instructions
+ | CbRlcR8 !R8
+ | CbRrcR8 !R8
+ | CbRlR8 !R8
+ | CbRrR8 !R8
+ | CbSlaR8 !R8
+ | CbSraR8 !R8
+ | CbSwapR8 !R8
+ | CbSrlR8 !R8
+
+ | CbBitB3R8 !B3 !R8
+ | CbResB3R8 !B3 !R8
+ | CbSetB3R8 !B3 !R8
+ deriving (Show)
+
+readInstruction ::
+ (MonadIO m, MonadThrow m) =>
+ Bus.Bus m -> Addr ->
+ m (Instruction, Addr)
+readInstruction b a = do
+ op <- Bus.read b a >>= \case
+ Just o -> pure o
+ Nothing -> throwM . DecodeError $ mconcat
+ [ "failed to read opcode at unmapped address "
+ , pretty a
+ ]
+ let blk = w8bits2 7 op
+ let bot3 = w8bits3 2 op
+ let bot4 = w8bits4 3 op
+ let no i = pure (i, a + 1)
+ let imm8 f = do
+ x <- readImm8 b $ a + 1
+ pure (f x, a + 2)
+ let imm16 f = do
+ x <- readImm16 b $ a + 1
+ pure (f x, a + 3)
+ case (op, blk, bot4, bot3) of
+ -- Block 0
+ (0b00000000, _, _, _) -> no Nop
+
+ (_, 0b00, 0b0001, _) -> imm16 $ LdR16Imm16 (ext $ w8bits2 5 op)
+ (_, 0b00, 0b0010, _) -> no $ LdR16MemA (ext $ w8bits2 5 op)
+ (_, 0b00, 0b1010, _) -> no $ LdAR16Mem (ext $ w8bits2 5 op)
+ (0b00001000, _, _, _) -> imm16 LdImm16Sp
+
+ (_, 0b00, 0b0011, _) -> no $ IncR16 (ext $ w8bits2 5 op)
+ (_, 0b00, 0b1011, _) -> no $ DecR16 (ext $ w8bits2 5 op)
+ (_, 0b00, 0b1001, _) -> no $ AddHlR16 (ext $ w8bits2 5 op)
+
+ (_, 0b00, _, 0b100) -> no $ IncR8 (ext $ w8bits3 5 op)
+ (_, 0b00, _, 0b101) -> no $ DecR8 (ext $ w8bits3 5 op)
+
+ (_, 0b00, _, 0b110) -> imm8 $ LdR8Imm8 (ext $ w8bits3 5 op)
+
+ (0b00000111, _, _, _) -> no Rlca
+ (0b00001111, _, _, _) -> no Rrca
+ (0b00010111, _, _, _) -> no Rla
+ (0b00011111, _, _, _) -> no Rra
+ (0b00100111, _, _, _) -> no Daa
+ (0b00101111, _, _, _) -> no Cpl
+ (0b00110111, _, _, _) -> no Scf
+ (0b00111111, _, _, _) -> no Ccf
+
+ (0b00011000, _, _, _) -> imm8 JrImm8
+ (0b00010000, _, _, _) -> no Stop
+ (_, 0b00, _, 0b000) -> imm8 $ JrCondImm8 (ext $ w8bits2 4 op)
+
+ -- Block 1
+ (0b01110110, _, _, _) -> no Halt
+ (_, 0b01, _, _) -> no $ LdR8R8 (ext $ w8bits3 5 op) (ext $ w8bits3 2 op)
+
+ -- Block 2
+ (_, 0b10, _, _) -> do
+ let ins = case w8bits3 5 op of
+ 0b000 -> AddAR8
+ 0b001 -> AdcAR8
+ 0b010 -> SubAR8
+ 0b011 -> SbcAR8
+ 0b100 -> AndAR8
+ 0b101 -> XorAR8
+ 0b110 -> OrAR8
+ 0b111 -> CpAR8
+ _ -> error "unreachable"
+ no $ ins (ext $ w8bits3 2 op)
+
+ -- Block 3
+ (0b11000110, _, _, _) -> imm8 AddAImm8
+ (0b11001110, _, _, _) -> imm8 AdcAImm8
+ (0b11010110, _, _, _) -> imm8 SubAImm8
+ (0b11011110, _, _, _) -> imm8 SbcAImm8
+ (0b11100110, _, _, _) -> imm8 AndAImm8
+ (0b11101110, _, _, _) -> imm8 XorAImm8
+ (0b11110110, _, _, _) -> imm8 OrAImm8
+ (0b11111110, _, _, _) -> imm8 CpAImm8
+
+ (0b11001001, _, _, _) -> no Ret
+ (0b11011001, _, _, _) -> no Reti
+ (0b11000011, _, _, _) -> imm16 JpImm16
+ (0b11101001, _, _, _) -> no JpHl
+ (0b11001101, _, _, _) -> imm16 CallImm16
+
+ (0b11100010, _, _, _) -> no LdhCA
+ (0b11100000, _, _, _) -> imm8 LdhImm8A
+ (0b11101010, _, _, _) -> imm16 LdImm16A
+ (0b11110010, _, _, _) -> no LdhAC
+ (0b11110000, _, _, _) -> imm8 LdhAImm8
+ (0b11111010, _, _, _) -> imm16 LdAImm16
+
+ (0b11101000, _, _, _) -> imm8 AddSpImm8
+ (0b11111000, _, _, _) -> imm8 LdHlSpPlusImm8
+ (0b11111001, _, _, _) -> no LdSpHl
+
+ (0b11110011, _, _, _) -> no Di
+ (0b11111011, _, _, _) -> no Ei
+
+ (0b11001011, _, _, _) -> do
+ -- 0xcb prefix
+ op2 <- Bus.read b (a + 1) >>= \case
+ Just o -> pure o
+ Nothing -> throwM . DecodeError $ mconcat
+ [ "failed to read (0xCB-prefixed) opcode at unmapped address "
+ , pretty $ a + 1
+ ]
+ case w8bits2 7 op2 of
+
+ 0b00 -> case w8bits3 5 op2 of
+ 0b000 -> pure (CbRlcR8 $ ext $ w8bits3 2 op2, a + 2)
+ 0b001 -> pure (CbRrcR8 $ ext $ w8bits3 2 op2, a + 2)
+ 0b010 -> pure (CbRlR8 $ ext $ w8bits3 2 op2, a + 2)
+ 0b011 -> pure (CbRrR8 $ ext $ w8bits3 2 op2, a + 2)
+ 0b100 -> pure (CbSlaR8 $ ext $ w8bits3 2 op2, a + 2)
+ 0b101 -> pure (CbSraR8 $ ext $ w8bits3 2 op2, a + 2)
+ 0b110 -> pure (CbSwapR8 $ ext $ w8bits3 2 op2, a + 2)
+ 0b111 -> pure (CbSrlR8 $ ext $ w8bits3 2 op2, a + 2)
+ _ -> error "unreachable"
+ 0b01 -> pure (CbBitB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+ 0b10 -> pure (CbResB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+ 0b11 -> pure (CbSetB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+ _ -> error "unreachable"
+
+ (_, 0b11, _, 0b000) -> no $ RetCond (ext $ w8bits2 4 op)
+ (_, 0b11, _, 0b010) -> imm16 $ JpCondImm16 (ext $ w8bits2 4 op)
+ (_, 0b11, _, 0b100) -> imm16 $ CallCondImm16 (ext $ w8bits2 4 op)
+ (_, 0b11, _, 0b111) -> no $ RstTgt3 (ext $ w8bits3 5 op)
+ (_, 0b11, 0b0001, _) -> no $ PopR16Stk (ext $ w8bits2 5 op)
+ (_, 0b11, 0b0101, _) -> no $ PushR16Stk (ext $ w8bits2 5 op)
+
+ _unknown -> do
+ log $ "unknown opcode: " <> tshow op
+ no Nop
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 11:17:49 +0000