1 files changed, 621 insertions, 0 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
new file mode 100644
index 0000000..33c4ac3
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -0,0 +1,621 @@
+{-# Language TemplateHaskell, ImplicitParams #-}
+module Fig.Emulator.GB.CPU where
+
+import Control.Lens.TH (makeLenses)
+
+import Fig.Prelude
+import Prelude (fromIntegral)
+
+import System.IO (withFile, IOMode (WriteMode))
+
+import qualified Text.Printf as Pr
+
+import Control.Lens ((.=), use, (^.))
+import Control.Monad (when, unless)
+import Control.Monad.State (StateT(..))
+
+import Data.Word (Word8, Word16)
+import Data.Bits
+
+import qualified SDL
+
+import Fig.Emulator.GB.Utils
+import Fig.Emulator.GB.Bus (Bus(..), Addr(..))
+import qualified Fig.Emulator.GB.Bus as Bus
+import Fig.Emulator.GB.Component.RAM
+import Fig.Emulator.GB.Component.ROM
+import Fig.Emulator.GB.Component.Video
+import Fig.Emulator.GB.CPU.Instruction
+
+newtype CPUError = CPUError Text
+  deriving Show
+instance Exception CPUError
+instance Pretty CPUError where
+  pretty (CPUError b) = mconcat
+    [ "CPU error: "
+    , b
+    ]
+
+data Registers = Registers
+  { _regA :: !Word8
+  , _regB :: !Word8, _regC :: !Word8
+  , _regD :: !Word8, _regE :: !Word8
+  , _regH :: !Word8, _regL :: !Word8
+  , _regSP :: !Word16
+  , _regPC :: !Word16
+  , _regFlagZ :: !Bool, _regFlagC :: !Bool
+  , _regFlagN :: !Bool, _regFlagH :: !Bool
+  , _regFlagIME :: !Bool
+  }
+makeLenses 'Registers
+
+initialRegs :: Registers
+initialRegs = Registers
+  { _regA = 0x01
+  , _regB = 0x00, _regC = 0x13
+  , _regD = 0x00, _regE = 0xd8
+  , _regH = 0x01, _regL = 0x4d
+  , _regSP = 0xfffe
+  , _regPC = 0x0100
+  , _regFlagZ = True, _regFlagC = True
+  , _regFlagN = False, _regFlagH = True
+  , _regFlagIME = False
+  }
+
+data CPU m = CPU
+  { _lastPC :: !Word16
+  , _lastIns :: !Instruction
+  , _regs :: !Registers
+  , _bus :: !(Bus m)
+  }
+makeLenses 'CPU
+
+type EmulatingT f m = (MonadIO m, MonadThrow m, MonadState (CPU f) m, ?log :: Handle)
+type Emulating m = EmulatingT IO m
+
+cpuDMG :: (MonadIO m, MonadThrow m) => ByteString -> CPU m
+cpuDMG rom = CPU
+  { _lastPC = 0x0
+  , _lastIns = Nop
+  , _regs = initialRegs
+  , _bus = Bus
+    [ compROM rom
+    , compWRAM 0x8000 $ 8 * 1024 -- vram placeholder
+    , compWRAM 0xc000 $ 8 * 1024
+    , compLCD
+    ]
+  }
+
+logCPUState :: Emulating m => m ()
+logCPUState = do
+  rs <- use regs
+  let pc = rs ^. regPC
+  m0 <- read8 $ Addr pc
+  m1 <- read8 $ Addr pc + 1
+  m2 <- read8 $ Addr pc + 2
+  m3 <- read8 $ Addr pc + 3
+  liftIO . hPutStrLn ?log $ mconcat 
+    [ "A:", rreg8 $ rs ^. regA
+    , " F:", rreg8 $ flagsw8 (rs ^. regFlagZ) (rs ^. regFlagN) (rs ^. regFlagH) (rs ^. regFlagC)
+    , " B:", rreg8 $ rs ^. regB
+    , " C:", rreg8 $ rs ^. regC
+    , " D:", rreg8 $ rs ^. regD
+    , " E:", rreg8 $ rs ^. regE
+    , " H:", rreg8 $ rs ^. regH
+    , " L:", rreg8 $ rs ^. regL
+    , " SP:", rreg16 $ rs ^. regSP
+    , " PC:", rreg16 pc
+    , " PCMEM:", rreg8 m0, ",", rreg8 m1, ",", rreg8 m2, ",", rreg8 m3
+    ]
+  where
+    rreg8 = pack . Pr.printf "%02X"
+    rreg16 = pack . Pr.printf "%04X"
+
+decode :: Emulating m => m Instruction
+decode = do
+  b <- use bus
+  pc <- use $ regs . regPC
+  lastPC .= pc
+  (ins, Addr a) <- liftIO $ readInstruction b $ Addr pc
+  lastIns .= ins
+  regs . regPC .= a
+  pure ins
+
+cond :: Emulating m => Cond -> m Bool
+cond CondNz = not <$> use (regs . regFlagZ)
+cond CondZ = use (regs . regFlagZ)
+cond CondNc = not <$> use (regs . regFlagC)
+cond CondC = use (regs . regFlagC)
+
+read8 :: Emulating m => Addr -> m Word8
+read8 a = do
+  b <- use bus
+  pc <- use lastPC
+  ins <- use lastIns
+  liftIO (Bus.read b a) >>= \case
+    Just v -> pure v
+    Nothing -> throwM . CPUError $ mconcat
+      [ "read from unmapped address "
+      , pretty a
+      , " while executing instruction "
+      , tshow ins
+      , " (at "
+      , pretty $ Addr pc
+      , ")"
+      ]
+
+read16 :: Emulating m => Addr -> m Word16
+read16 a = do
+  lo <- read8 a
+  hi <- read8 $ a + 1
+  pure $ w8w8 hi lo
+
+write8 :: Emulating m => Addr -> Word8 -> m ()
+write8 a v = do
+  b <- use bus
+  b' <- liftIO $ Bus.write b a v
+  bus .= b'
+
+write16 :: Emulating m => Addr -> Word16 -> m ()
+write16 a v = do
+  write8 a $ w16lo v
+  write8 (a + 1) $ w16hi v
+
+r8 :: Emulating m => R8 -> m Word8
+r8 R8B = use $ regs . regB
+r8 R8C = use $ regs . regC
+r8 R8D = use $ regs . regD
+r8 R8E = use $ regs . regE
+r8 R8H = use $ regs . regH
+r8 R8L = use $ regs . regL
+r8 R8MemHL = do
+  hl <- r16 R16HL
+  read8 $ Addr hl
+r8 R8A = use $ regs . regA
+
+setR8 :: Emulating m => R8 -> Word8 -> m ()
+setR8 R8B v = regs . regB .= v
+setR8 R8C v = regs . regC .= v
+setR8 R8D v = regs . regD .= v
+setR8 R8E v = regs . regE .= v
+setR8 R8H v = regs . regH .= v
+setR8 R8L v = regs . regL .= v
+setR8 R8MemHL v = do
+  hl <- r16 R16HL
+  write8 (Addr hl) v
+setR8 R8A v = regs . regA .= v
+
+r16 :: Emulating m => R16 -> m Word16
+r16 R16BC = w8w8 <$> r8 R8B <*> r8 R8C
+r16 R16DE = w8w8 <$> r8 R8D <*> r8 R8E
+r16 R16HL = w8w8 <$> r8 R8H <*> r8 R8L
+r16 R16SP = use $ regs . regSP
+
+setR16 :: Emulating m => R16 -> Word16 -> m ()
+setR16 R16BC v = do
+  regs . regB .= w16hi v
+  regs . regC .= w16lo v
+setR16 R16DE v = do
+  regs . regD .= w16hi v
+  regs . regE .= w16lo v
+setR16 R16HL v = do
+  regs . regH .= w16hi v
+  regs . regL .= w16lo v
+setR16 R16SP v = regs . regSP .= v
+
+r16Stk :: Emulating m => R16Stk -> m Word16
+r16Stk R16StkBC = r16 R16BC
+r16Stk R16StkDE = r16 R16DE
+r16Stk R16StkHL = r16 R16HL
+r16Stk R16StkAF = do
+  hi <- r8 R8A
+  z <- use $ regs . regFlagZ
+  n <- use $ regs . regFlagN
+  h <- use $ regs . regFlagH
+  c <- use $ regs . regFlagC
+  pure . w8w8 hi $ flagsw8 z n h c
+
+setR16Stk :: Emulating m => R16Stk -> Word16 -> m ()
+setR16Stk R16StkBC v = setR16 R16BC v
+setR16Stk R16StkDE v = setR16 R16DE v
+setR16Stk R16StkHL v = setR16 R16HL v
+setR16Stk R16StkAF v = do
+  setR8 R8A $ w16hi v
+  let lo = w16lo v
+  regs . regFlagZ .= w8bit 7 lo
+  regs . regFlagN .= w8bit 6 lo
+  regs . regFlagH .= w8bit 5 lo
+  regs . regFlagC .= w8bit 4 lo
+
+r16Mem :: Emulating m => R16Mem -> m Word16
+r16Mem R16MemBC = r16 R16BC
+r16Mem R16MemDE = r16 R16DE
+r16Mem R16MemHLPlus = do
+  hl <- r16 R16HL
+  setR16 R16HL $ hl + 1
+  pure hl
+r16Mem R16MemHLMinus = do
+  hl <- r16 R16HL
+  setR16 R16HL $ hl - 1
+  pure hl
+
+renderTile :: Emulating m => SDL.Renderer -> Addr -> Int -> Int -> m ()
+renderTile renderer a bx by = do
+  (ps :: [(Int, Int, Word8)]) <- mconcat <$> forM [0..8] \y -> do
+    mconcat <$> forM [0 .. 1] \x -> do
+      b <- read8 $ a + Addr (y * 2 + x)
+      pure
+        [ (bx + fromIntegral x, by + fromIntegral y, w8bits2 7 b)
+        , (bx + fromIntegral x, by + fromIntegral y, w8bits2 5 b)
+        , (bx + fromIntegral x, by + fromIntegral y, w8bits2 3 b)
+        , (bx + fromIntegral x, by + fromIntegral y, w8bits2 1 b)
+        ]
+  SDL.rendererDrawColor renderer SDL.$= SDL.V4 0 0 0 255
+  forM_ ps \(x, y, p) -> do
+    unless (p == 0) do
+      SDL.drawPoint renderer . SDL.P $ SDL.V2 (fromIntegral x) (fromIntegral y)
+
+step :: forall m. Emulating m => Instruction -> m ()
+step ins = do
+  let
+    sub8 :: (Word16 -> Word16 -> Word16) -> Word8 -> Word8 -> m Word8
+    sub8 op x y = do
+      let res = op (sext x) (sext y)
+      regs . regFlagH .= (w8bits4 3 y > w8bits4 3 x)
+      regs . regFlagC .= (y > x)
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= True
+      pure $ trunc res
+    bitwise8 :: (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> m Word8
+    bitwise8 op x y = do
+      let res = op x y
+      regs . regFlagH .= False
+      regs . regFlagC .= False
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      pure res
+  case ins of
+    Nop -> pure ()
+    LdR16Imm16 r (Imm16 i) -> setR16 r i
+    LdR16MemA r -> do
+      addr <- r16Mem r
+      a <- r8 R8A
+      write8 (Addr addr) a
+    LdAR16Mem r -> do
+      addr <- r16Mem r
+      v <- read8 $ Addr addr
+      setR8 R8A v
+    LdImm16Sp (Imm16 addr) -> do
+      sp <- r16 R16SP
+      write8 (Addr addr) $ w16lo sp
+      write8 (Addr addr + 1) $ w16hi sp
+    IncR16 r -> do
+      v <- r16 r
+      setR16 r $ v + 1
+    DecR16 r -> do
+      v <- r16 r
+      setR16 r $ v - 1
+    AddHlR16 r -> do
+      x <- r16 R16HL
+      y <- r16 r
+      let
+        res :: Word16
+        res = x + y
+      regs . regFlagH .= (shiftR res 11 .&. 0b1 == 0b1)
+      regs . regFlagC .= (shiftR res 15 .&. 0b1 == 0b1)
+      regs . regFlagZ .= (res .&. 0xffff == 0)
+      regs . regFlagN .= False
+      setR16 R16HL res
+    IncR8 r -> do
+      v <- r8 r
+      let (res, _) = addC False v 1
+      regs . regFlagH .= addH False v 1
+      regs . regFlagZ .= (res == 0)
+      regs . regFlagN .= False
+      setR8 r res
+    DecR8 r -> do
+      v <- r8 r
+      let
+        res :: Word8
+        res = v - 1
+      regs . regFlagH .= subH v 1
+      regs . regFlagZ .= (res == 0)
+      regs . regFlagN .= True
+      setR8 r res
+    LdR8Imm8 r (Imm8 i) -> setR8 r i
+    Rlca -> do
+      v <- r8 R8A
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 7 v
+      setR8 R8A $ rotateL v 1
+    Rrca -> do
+      v <- r8 R8A
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 0 v
+      setR8 R8A $ rotateR v 1
+    Rla -> do
+      v <- r8 R8A
+      c <- use $ regs . regFlagC
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 7 v
+      setR8 R8A $ rotateL v 1 .|. if c then 1 else 0
+    Rra -> do
+      v <- r8 R8A
+      c <- use $ regs . regFlagC
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 0 v
+      setR8 R8A $ rotateR v 1 .|. if c then 0b10000000 else 0
+    Daa -> unimplemented
+    Cpl -> do
+      v <- r8 R8A
+      regs . regFlagH .= True
+      regs . regFlagN .= True
+      setR8 R8A $ complement v
+    Scf -> do
+      regs . regFlagH .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= True
+    Ccf -> do
+      c <- use $ regs . regFlagC
+      regs . regFlagH .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= not c
+    JrImm8 (Imm8 i) -> do
+      pc <- use $ regs . regPC
+      regs . regPC .= pc + sext i
+    JrCondImm8 c (Imm8 i) -> do
+      b <- cond c
+      when b do
+        pc <- use $ regs . regPC
+        regs . regPC .= pc + sext i
+    Stop -> unimplemented
+    LdR8R8 dst src -> do
+      v <- r8 src
+      setR8 dst v
+    Halt -> unimplemented
+    AddAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      let (res, carry) = addC False x y
+      regs . regFlagH .= addH False x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    AdcAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      c <- use $ regs . regFlagC
+      let (res, carry) = addC c x y
+      regs . regFlagH .= addH c x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    SubAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- sub8 (-) x y
+      regs . regA .= res
+    SbcAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      c <- use $ regs . regFlagC
+      res <- sub8 (\a b -> a - (b + if c then 1 else 0)) x y
+      regs . regA .= res
+    AndAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- bitwise8 (.&.) x y
+      regs . regA .= res
+    XorAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- bitwise8 xor x y
+      regs . regA .= res
+    OrAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- bitwise8 (.|.) x y
+      regs . regA .= res
+    CpAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      void $ sub8 (-) x y
+    AddAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      let (res, carry) = addC False x y
+      regs . regFlagH .= addH False x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    AdcAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      c <- use $ regs . regFlagC
+      let (res, carry) = addC c x y
+      regs . regFlagH .= addH c x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    SubAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- sub8 (-) x y
+      regs . regA .= res
+    SbcAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      c <- use $ regs . regFlagC
+      res <- sub8 (\a b -> a - (b + if c then 1 else 0)) x y
+      regs . regA .= res
+    AndAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- bitwise8 (.&.) x y
+      regs . regA .= res
+    XorAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- bitwise8 xor x y
+      regs . regA .= res
+    OrAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- bitwise8 (.|.) x y
+      regs . regA .= res
+    CpAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      void $ sub8 (-) x y
+    RetCond c -> do
+      b <- cond c
+      when b do
+        sp <- r16 R16SP
+        v <- read16 $ Addr sp
+        setR16 R16SP $ sp + 2
+        regs . regPC .= v
+    Ret -> do
+      sp <- r16 R16SP
+      v <- read16 $ Addr sp
+      setR16 R16SP $ sp + 2
+      regs . regPC .= v
+    Reti -> unimplemented
+    JpCondImm16 c (Imm16 i) -> do
+      b <- cond c
+      when b do
+        regs . regPC .= i
+    JpImm16 (Imm16 i) -> do
+      regs . regPC .= i
+    JpHl -> do
+      hl <- r16 R16HL
+      regs . regPC .= hl
+    CallCondImm16 c (Imm16 i) -> do
+      b <- cond c
+      when b do
+        next <- use $ regs . regPC
+        sp <- (\x -> x - 2) <$> r16 R16SP
+        setR16 R16SP sp
+        write16 (Addr sp) next
+        regs . regPC .= i
+    CallImm16 (Imm16 i) -> do
+      next <- use $ regs . regPC
+      sp <- (\x -> x - 2) <$> r16 R16SP
+      setR16 R16SP sp
+      write16 (Addr sp) next
+      regs . regPC .= i
+    RstTgt3 (Tgt3 v) -> do
+      next <- use $ regs . regPC
+      sp <- (\x -> x - 2) <$> r16 R16SP
+      setR16 R16SP sp
+      write16 (Addr sp) next
+      regs . regPC .= shiftL (fromIntegral v) 3
+    PopR16Stk r -> do
+      sp <- r16 R16SP
+      v <- read16 $ Addr sp
+      setR16 R16SP $ sp + 2
+      setR16Stk r v
+    PushR16Stk r -> do
+      sp <- (\x -> x - 2) <$> r16 R16SP
+      v <- r16Stk r
+      setR16 R16SP sp
+      write16 (Addr sp) v
+    LdhCA -> do
+      c <- r8 R8C
+      a <- r8 R8A
+      write8 (Addr $ 0xff00 + zext c) a
+    LdhImm8A (Imm8 i) -> do
+      a <- r8 R8A
+      write8 (Addr $ 0xff00 + zext i) a
+    LdImm16A (Imm16 i) -> do
+      a <- r8 R8A
+      write8 (Addr i) a
+    LdhAC -> do
+      c <- r8 R8C
+      v <- read8 (Addr $ 0xff00 + zext c)
+      setR8 R8A v
+    LdhAImm8 (Imm8 i) -> do
+      v <- read8 (Addr $ 0xff00 + zext i)
+      setR8 R8A v
+    LdAImm16 (Imm16 i) -> do
+      v <- read8 (Addr i)
+      setR8 R8A v
+    AddSpImm8 (Imm8 y) -> do
+      x <- r16 R16SP
+      let
+        res :: Word16
+        res = x + sext y
+      regs . regFlagH .= (shiftR res 3 .&. 0b1 == 0b1)
+      regs . regFlagC .= (shiftR res 7 .&. 0b1 == 0b1)
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      setR16 R16SP res
+    LdHlSpPlusImm8 (Imm8 y) -> do
+      x <- r16 R16SP
+      let
+        res :: Word16
+        res = x + sext y
+      regs . regFlagH .= (shiftR res 3 .&. 0b1 == 0b1)
+      regs . regFlagC .= (shiftR res 7 .&. 0b1 == 0b1)
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      setR16 R16HL res
+    LdSpHl -> do
+      v <- r16 R16HL
+      setR16 R16SP v
+    Di -> regs . regFlagIME .= False
+    Ei -> regs . regFlagIME .= True
+    CbRlcR8 _ -> unimplemented
+    CbRrcR8 _ -> unimplemented
+    CbRlR8 _ -> unimplemented
+    CbRrR8 _ -> unimplemented
+    CbSlaR8 _ -> unimplemented
+    CbSraR8 _ -> unimplemented
+    CbSwapR8 _ -> unimplemented
+    CbSrlR8 _ -> unimplemented
+    CbBitB3R8 _ _ -> unimplemented
+    CbResB3R8 _ _ -> unimplemented
+    CbSetB3R8 _ _ -> unimplemented
+  where
+    unimplemented :: m ()
+    unimplemented = do
+      a <- use lastPC
+      throwM . CPUError $ mconcat
+        [ "unimplemented instruction (at "
+        , pretty $ Addr a
+        , "): "
+        , tshow ins
+        ]
+
+testRun :: forall m. (MonadIO m, MonadThrow m) => ByteString -> m ()
+testRun rom = do
+  SDL.initializeAll
+  window <- SDL.createWindow "taking" SDL.defaultWindow
+  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
+  let cpu = cpuDMG rom
+  let
+    loop :: forall m'. Emulating m' => Int -> m' ()
+    loop cycle = do
+      -- pc <- use $ regs . regPC
+      ins <- decode
+      -- log $ mconcat
+      --   [ pretty $ Addr pc
+      --   , ": ", tshow ins
+      --   ]
+      step ins
+      -- logCPUState
+      when (rem cycle 70224 == 0) do
+        SDL.rendererDrawColor renderer SDL.$= SDL.V4 255 255 255 255
+        SDL.clear renderer
+        forM_ ([0..255] :: [Int]) \i -> do
+          renderTile renderer (Addr . fromIntegral $ 0x8000 + i * 16) 0 0
+        SDL.present renderer
+      loop $ cycle + 1
+  liftIO $ withFile "log.txt" WriteMode \h -> do
+    let ?log = h
+    void $ flip runStateT cpu do
+      -- logCPUState
+      loop 0