From 2fec6e70b2b583299bcbbda0b596a5a9c275e93e Mon Sep 17 00:00:00 2001 From: LLLL Colonq Date: Mon, 13 May 2024 03:39:51 -0400 Subject: fig-emulator-gb: Debugging the PPU --- fig-emulator-gb/src/Fig/Emulator/GB.hs | 42 +++-- fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs | 10 +- fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs | 4 +- .../src/Fig/Emulator/GB/Component/Misc.hs | 24 +++ .../src/Fig/Emulator/GB/Component/Serial.hs | 8 +- .../src/Fig/Emulator/GB/Component/Video.hs | 209 ++++++++++----------- 6 files changed, 154 insertions(+), 143 deletions(-) create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs (limited to 'fig-emulator-gb/src/Fig/Emulator') diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs index cc68afe..a2cfa1d 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs @@ -22,7 +22,8 @@ import Fig.Emulator.GB.Component.ROM import Fig.Emulator.GB.Component.Video import Fig.Emulator.GB.Component.Joystick import Fig.Emulator.GB.Component.Serial -import Fig.Emulator.GB.Component.Interrupt (compInterrupt) +import Fig.Emulator.GB.Component.Misc +import Fig.Emulator.GB.Component.Interrupt cpuDMG :: Maybe Handle -> ByteString -> Framebuffer -> CPU cpuDMG serial rom fb = CPU @@ -37,6 +38,7 @@ cpuDMG serial rom fb = CPU , compJoystick , compSerial serial , compInterrupt + , compMisc , compWRAM 0xff80 0x7e -- HRAM ] } @@ -54,11 +56,11 @@ testRun serialOut rom = do let loop :: Int -> Emulating () loop cycle = do - -- events <- SDL.pollEvents - -- forM_ events \ev -> - -- case SDL.eventPayload ev of - -- SDL.QuitEvent -> running .= False - -- _else -> pure () + events <- SDL.pollEvents + forM_ events \ev -> + case SDL.eventPayload ev of + SDL.QuitEvent -> running .= False + _else -> pure () pc <- use $ regs . regPC ins <- decode when (pc == 0x2817) do @@ -69,20 +71,20 @@ testRun serialOut rom = do step ins when (rem cycle 1000000 == 0) do log "1 million" - -- when (rem cycle 70224 == 0) do - -- ws <- SDL.getWindowSurface window - -- SDL.surfaceFillRect ws Nothing $ SDL.V4 0x00 0x00 0x00 0xff - -- void $ - -- SDL.surfaceBlitScaled - -- (fbSurface fb) - -- Nothing - -- ws - -- (Just $ SDL.Rectangle - -- (SDL.P $ SDL.V2 0 0) - -- (SDL.V2 - -- (fromIntegral screenWidth * 8) - -- (fromIntegral screenHeight * 8))) - -- SDL.updateWindowSurface window + when (rem cycle 300000 == 0) do + ws <- SDL.getWindowSurface window + SDL.surfaceFillRect ws Nothing $ SDL.V4 0x00 0x00 0x00 0xff + void $ + SDL.surfaceBlitScaled + (fbSurface fb) + Nothing + ws + (Just $ SDL.Rectangle + (SDL.P $ SDL.V2 0 0) + (SDL.V2 + (fromIntegral screenWidth * 4) + (fromIntegral screenHeight * 4))) + SDL.updateWindowSurface window r <- use running when r . loop $ cycle + 1 void $ flip (runStateT . runEmulating) cpu do diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs index f0c461f..2b71f2f 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs @@ -20,11 +20,11 @@ instance Pretty Addr where pretty (Addr w) = "$" <> pack (showHex w "") data Component = forall (s :: Type). Component - { compState :: s - , compMatches :: Addr -> Bool - , compUpdate :: s -> Word16 -> IO s - , compWrite :: s -> Addr -> Word8 -> IO s - , compRead :: s -> Addr -> IO Word8 + { compState :: !s + , compMatches :: !(Addr -> Bool) + , compUpdate :: !(s -> Word16 -> IO s) + , compWrite :: !(s -> Addr -> Word8 -> IO s) + , compRead :: !(s -> Addr -> IO Word8) } newtype Bus = Bus { busComponents :: [Component] } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs index 651b27b..26a00de 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs @@ -110,6 +110,7 @@ updateComps t = do decode :: Emulating Instruction decode = do + updateComps 4 b <- use bus pc <- use $ regs . regPC lastPC .= pc @@ -126,6 +127,7 @@ cond CondC = use (regs . regFlagC) read8 :: Addr -> Emulating Word8 read8 a = do + updateComps 4 b <- use bus pc <- use lastPC ins <- use lastIns @@ -149,6 +151,7 @@ read16 a = do write8 :: Addr -> Word8 -> Emulating () write8 a v = do + updateComps 4 b <- use bus b' <- liftIO $ Bus.write b a v bus .= b' @@ -677,7 +680,6 @@ step ins = do CbSetB3R8 (B3 idx) r -> {-# SCC "CbSetB3R8" #-} do v <- r8 r setR8 r $ v .|. shiftL 0b1 idx - updateComps 4 where unimplemented :: Emulating () unimplemented = do diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs new file mode 100644 index 0000000..be15e56 --- /dev/null +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs @@ -0,0 +1,24 @@ +module Fig.Emulator.GB.Component.Misc where + +import Fig.Prelude + +import Fig.Emulator.GB.Utils +import Fig.Emulator.GB.Bus + +newtype MiscError = MiscError Text + deriving Show +instance Exception MiscError +instance Pretty MiscError where + pretty (MiscError b) = mconcat + [ "misc component error: " + , b + ] + +compMisc :: Component +compMisc = Component + { compState = () + , compMatches = (== 0xff4d) + , compUpdate = \s _ -> pure s + , compWrite = \s _ _ -> pure s + , compRead = \_ _ -> pure 0x00 + } diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs index 7a4bceb..3912e5d 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs @@ -14,7 +14,7 @@ newtype SerialError = SerialError Text instance Exception SerialError instance Pretty SerialError where pretty (SerialError b) = mconcat - [ "joystick error: " + [ "serial error: " , b ] @@ -24,9 +24,9 @@ compSerial mh = Component , compMatches = (== 0xff01) , compUpdate = \s _ -> pure s , compWrite = \s _ v -> do - -- log $ mconcat - -- [ "wrote serial byte: ", tshow $ chr $ fromIntegral v - -- ] + log $ mconcat + [ "wrote serial byte: ", tshow $ chr $ fromIntegral v + ] case mh of Nothing -> pure () Just h -> liftIO . hPutChar h . chr $ fromIntegral v diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs index 7ddf8f5..b1ddadc 100644 --- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs +++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs @@ -1,11 +1,12 @@ module Fig.Emulator.GB.Component.Video where import Fig.Prelude -import Prelude (error) +import Prelude (error, ($!)) import qualified Foreign.Ptr as Ptr import qualified Foreign.Storable as St +import Control.DeepSeq (force) import Control.Monad (unless) import Data.Word (Word8, Word16, Word32) @@ -27,10 +28,12 @@ instance Pretty VideoError where ] screenWidth :: Word16 -screenWidth = 160 +-- screenWidth = 160 +screenWidth = 8 * 32 screenHeight :: Word16 -screenHeight = 144 +-- screenHeight = 144 +screenHeight = 8 * 32 newtype Framebuffer = Framebuffer { fbSurface :: SDL.Surface @@ -45,6 +48,7 @@ initializeFramebuffer = do { fbSurface = s } + logTilemap :: V.Vector Word8 -> IO () logTilemap v = do let base = 0x9800 - 0x8000 @@ -64,16 +68,19 @@ blitPixel c (x, y) fb = do liftIO $ St.poke p c SDL.unlockSurface $ fbSurface fb -blitTile :: V.Vector Word8 -> Addr -> (Word8, Word8) -> Framebuffer -> IO () -blitTile v (Addr a) (bx, by) fb = do +blitTile :: Int -> V.Vector Word8 -> Int -> (Word8, Word8) -> Framebuffer -> IO () +blitTile base v num (bx, by) fb = do + let a = num * 16 + log "start" (ps :: [(Word8, Word8, Word8)]) <- mconcat <$> forM [0..7] \y -> do mconcat <$> forM [0..1] \xb -> do - b <- case v V.!? fromIntegral (a + (y * 2 + xb)) of + b <- case v V.!? fromIntegral (base + a + (y * 2 + xb)) of Just b -> pure b Nothing -> throwM . VideoError $ mconcat - [ "tile address ", pretty $ Addr a + [ "tile offset ", pretty . Addr $ fromIntegral a , " out of bounds" ] + log $ show8 b pure [ (bx + fromIntegral xb, by + fromIntegral y, w8bits2 7 b) , (bx + fromIntegral xb + 1, by + fromIntegral y, w8bits2 5 b) @@ -85,15 +92,23 @@ blitTile v (Addr a) (bx, by) fb = do blitPixel (case p of 0x01 -> 0xff0000ff - 0x02 -> 0x990000ff - 0x03 -> 0x330000ff + 0x02 -> 0x00ff00ff + 0x03 -> 0x0000ffff _else -> error "unreachable" ) (x, y) fb +readTileMap :: Int -> V.Vector Word8 -> IO [(Int, Int, Word8)] +readTileMap base vram = do + mconcat <$> forM ([0..32] :: [Int]) \x -> do + forM ([0..32] :: [Int]) \y -> do + case vram V.!? (base + y * 32 + x) of + Nothing -> error "unreachable" + Just a -> pure (x, y, a) + data VideoAddrRange - = VideoAddrVRAM Addr - | VideoAddrStatus Addr + = VideoAddrVRAM !Addr + | VideoAddrStatus !Addr deriving Show videoAddrRange :: Addr -> Maybe VideoAddrRange @@ -110,14 +125,15 @@ data RenderState deriving Show data VideoState = VideoState - { vstFb :: Framebuffer - , vstVRAM :: V.Vector Word8 - , vstScx :: Word8 - , vstScy :: Word8 - , vstLy :: Word8 - , vstLx :: Word8 - , vstRenderState :: RenderState - , vstTick :: Word16 + { vstFb :: !Framebuffer + , vstVRAM :: !(V.Vector Word8) + , vstLcdc :: !Word8 + , vstScx :: !Word8 + , vstScy :: !Word8 + , vstLy :: !Word8 + , vstLx :: !Word8 + , vstRenderState :: !RenderState + , vstTick :: !Word16 } compVideo :: Framebuffer -> Component @@ -125,6 +141,7 @@ compVideo framebuffer = Component { compState = VideoState { vstFb = framebuffer , vstVRAM = V.replicate (8 * 1024) 0 + , vstLcdc = 0 , vstScx = 0 , vstScy = 0 , vstLy = 0 @@ -132,132 +149,96 @@ compVideo framebuffer = Component , vstRenderState = RenderOAMSearch , vstTick = 0 } + , compMatches = isJust . videoAddrRange + , compUpdate = \s t -> {-# SCC "ComponentVideoUpdate" #-} do let tick = vstTick s + t - -- let ly = vstLy s + 1 - let ly = 0 + let ly = vstLy s + 1 case vstRenderState s of RenderOAMSearch - | tick == 40 -> pure s + | tick == 40 -> pure $! s { vstTick = tick , vstRenderState = RenderPixelTransfer } - | otherwise -> pure s + | otherwise -> pure $! s { vstTick = tick } RenderPixelTransfer - | tick == 200 -> pure s + | tick == 200 -> pure $! s { vstTick = tick , vstRenderState = RenderHBlank } - | otherwise -> pure s + | otherwise -> pure $! s { vstTick = tick } RenderHBlank | tick == 456 -> do - pure s + if ly == 144 + then + pure $! s + { vstTick = 0 + , vstLy = ly + , vstRenderState = RenderVBlank + } + else + pure $! s { vstTick = 0 , vstLy = ly , vstRenderState = RenderOAMSearch } - -- let ly = vstLy s + 1 - -- if ly == 144 - -- then - -- pure s - -- { vstTick = 0 - -- , vstLy = ly - -- -- , vstRenderState = RenderVBlank - -- , vstRenderState = RenderOAMSearch - -- } - -- else - -- pure s - -- { vstTick = 0 - -- , vstLy = ly - -- , vstRenderState = RenderOAMSearch - -- } - _ -> pure s { vstTick = tick } - -- case vstRenderState s of - -- RenderOAMSearch - -- | tick == 40 -> pure $! s - -- { vstTick = tick - -- , vstRenderState = RenderPixelTransfer - -- } - -- | otherwise -> pure $! s - -- { vstTick = tick - -- } - -- RenderPixelTransfer - -- | tick == 200 -> pure $! s - -- { vstTick = tick - -- , vstRenderState = RenderHBlank - -- } - -- | otherwise -> pure $! s - -- { vstTick = tick - -- } - -- RenderHBlank - -- | tick == 456 -> do - -- let ly = vstLy s + 1 - -- if ly == 144 - -- then - -- pure $! s - -- { vstTick = 0 - -- , vstLy = ly - -- , vstRenderState = RenderVBlank - -- } - -- else - -- pure $! s - -- { vstTick = 0 - -- , vstLy = ly - -- , vstRenderState = RenderOAMSearch - -- } - -- | otherwise -> pure $! s - -- { vstTick = tick - -- } - -- RenderVBlank - -- | tick == 456 -> do - -- let ly = vstLy s + 1 - -- if ly == 153 - -- then do - -- -- log "vblank" - -- -- logTilemap $ vstVRAM s - -- -- forM_ (zip [0..] [48,52,45,111,112,32,114,44,105,109,109] :: [(Int, Int)]) \(idx, b) -> do - -- -- blitTile (vstVRAM s) - -- -- (fromIntegral $ b * 16) - -- -- (fromIntegral $ idx * 8, 0) - -- -- $ vstFb s - -- -- forM_ ([0..10] :: [Int]) \x -> do - -- -- forM_ ([0..10] :: [Int]) \y -> do - -- -- let i = y * 10 + x - -- -- blitTile (vstVRAM s) - -- -- (0x200 + fromIntegral i * 16) - -- -- (fromIntegral $ x * 8, fromIntegral $ y * 8) - -- -- $ vstFb s - -- pure $! s - -- { vstTick = 0 - -- , vstLy = 0 - -- , vstRenderState = RenderOAMSearch - -- } - -- else - -- pure $! s - -- { vstTick = 0 - -- , vstLy = ly - -- } - -- | otherwise -> pure $! s - -- { vstTick = tick - -- } + | otherwise -> pure $! s + { vstTick = tick + } + RenderVBlank + | tick == 456 -> do + if ly == 153 + then do + -- log "vblank" + -- logTilemap $ vstVRAM s + let bgmapbase = (if w8bit 3 $ vstLcdc s then 0x9c00 else 0x9800) - 0x8000 + let bgbase = (if w8bit 4 $ vstLcdc s then 0x8000 else 0x9000) - 0x8000 + tiles <- readTileMap bgmapbase (vstVRAM s) + blitTile 0 (vstVRAM s) 48 (0, 8) $ vstFb s + -- forM_ tiles \(x, y, tile) -> do + -- blitTile bgbase (vstVRAM s) + -- (fromIntegral $ tile * 16) + -- (fromIntegral x * 8, fromIntegral y * 8) + -- $ vstFb s + -- forM_ (zip [0..] [48,52,45,111,112,32,114,44,105,109,109] :: [(Int, Int)]) \(idx, b) -> do + -- blitTile 0 (vstVRAM s) + -- (fromIntegral b) + -- (fromIntegral $ idx * 8, 0) + -- $ vstFb s + pure $! s + { vstTick = 0 + , vstLy = 0 + , vstRenderState = RenderOAMSearch + } + else + pure $! s + { vstTick = 0 + , vstLy = ly + } + | otherwise -> pure $! s + { vstTick = tick + } + , compWrite = \s a v -> {-# SCC "ComponentVideoWrite" #-} case videoAddrRange a of Nothing -> throwM $ VideoError $ mconcat [ "write address out of bounds for video system: " , pretty a ] Just (VideoAddrVRAM off) -> do - -- log $ "write to vram offset: " <> pretty off + log $ "write to vram: " <> pretty (0x8000 + off) pure s { vstVRAM = V.modify (\ms -> MV.write ms (fromIntegral $ unAddr off) v) $ vstVRAM s } Just (VideoAddrStatus off) -> case off of - 0x0 -> pure s + 0x0 -> do + log $ "write to lcdc: " <> show8 v + pure s { vstLcdc = v } 0x1 -> pure s 0x2 -> pure s { vstScx = v } 0x3 -> pure s { vstScy = v } @@ -270,17 +251,19 @@ compVideo framebuffer = Component 0xa -> pure s 0xb -> pure s _ -> pure s + , compRead = \s a -> {-# SCC "ComponentVideoRead" #-} case videoAddrRange a of Nothing -> throwM $ VideoError $ mconcat [ "read address out of bounds for video system: " , pretty a ] Just (VideoAddrStatus off) -> case off of - 0x0 -> pure 0x00 + 0x0 -> pure $ vstLcdc s 0x1 -> pure 0x00 0x2 -> pure $ vstScx s 0x3 -> pure $ vstScy s 0x4 -> pure $ vstLy s + -- 0x4 -> pure 0x00 0x5 -> pure 0x00 0x6 -> pure 0x00 0x7 -> pure 0x00 -- cgit v1.2.3