From 3a0a7b0a89fd841edd5f25f79cdb877051d0e948 Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Tue, 9 Apr 2024 22:35:42 -0400 Subject: End-of-stream emulator WIP --- fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs | 621 +++++++++++++++++++++++++++++ 1 file changed, 621 insertions(+) create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs (limited to 'fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs') 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 -- cgit v1.2.3